set stupid bidding to 0

app/Main.hs

@@ -41,17 +41,17 @@ runAI = do
         trs = filter (isTrump $ TrumpColour Spades) cs
     if length trs >= 5 && any ((==32) . getID) cs
         then do
-            pts <- fst <$> evalStateT turn env
+            pts <- fst <$> evalSkat turn env
             -- if pts > 60 then return 1 else return 0
             return pts
         else runAI
 
 env :: SkatEnv
-env = SkatEnv piles Nothing (Colour Spades Einfach) playersExamp Hand1
+env = SkatEnv piles Nothing (Colour Spades Einfach) playersExamp Hand1 Hand3
     where piles = distribute allCards 
 
 envStupid :: SkatEnv
-envStupid = SkatEnv piles Nothing (Colour Spades Einfach) pls2 Hand1
+envStupid = SkatEnv piles Nothing (Colour Spades Einfach) pls2 Hand1 Hand3
     where piles = distribute allCards 
 
 playersExamp :: Players
@@ -69,22 +69,22 @@ pls2 = Players
 shuffledEnv :: IO SkatEnv
 shuffledEnv = do
     cards <- shuffleCards
-    return $ SkatEnv (distribute cards) Nothing (Colour Spades Einfach) playersExamp Hand1
+    return $ SkatEnv (distribute cards) Nothing (Colour Spades Einfach) playersExamp Hand1 Hand3
 
 shuffledEnv2 :: IO SkatEnv
 shuffledEnv2 = do
     cards <- shuffleCards
-    return $ SkatEnv (distribute cards) Nothing (Colour Spades Einfach) pls2 Hand1
+    return $ SkatEnv (distribute cards) Nothing (Colour Spades Einfach) pls2 Hand1 Hand3
 
 env2 :: SkatEnv
-env2 = SkatEnv piles Nothing (Colour Hearts Einfach) playersExamp Hand2
+env2 = SkatEnv piles Nothing (Colour Hearts Einfach) playersExamp Hand2 Hand3
     where hand1 = [Card Eight Hearts, Card Queen Hearts, Card Ace Clubs, Card Queen Diamonds]
           hand2 = [Card Seven Hearts, Card King Hearts, Card Ten Hearts, Card Queen Spades]
           hand3 = [Card Seven Spades, Card King Spades, Card Ace Spades, Card Queen Clubs]
           piles = emptyPiles hand1 hand2 hand3 []
 
 env3 :: SkatEnv
-env3 = SkatEnv piles Nothing (Colour Diamonds Einfach) pls2 Hand3
+env3 = SkatEnv piles Nothing (Colour Diamonds Einfach) pls2 Hand3 Hand3
     where hand1 = [ Card Jack Diamonds, Card Jack Clubs, Card Nine Spades, Card King Spades
                   , Card Seven Diamonds, Card Nine Diamonds, Card Seven Clubs, Card Eight Clubs
                   , Card Ten Clubs, Card Eight Hearts ]
@@ -109,4 +109,4 @@ application pending = do
         putStrLn $ BS.unpack msg
 
 playSkat :: IO ()
-playSkat = void $ (flip runStateT) env3 playCLI
+playSkat = void $ (flip runSkat) env3 playCLI

app/TestEnvs.hs

@@ -14,7 +14,7 @@ pls2 = Players
     (PL $ Stupid Single Hand3)
 
 env3 :: SkatEnv
-env3 = SkatEnv piles Nothing (Colour Diamonds Einfach) pls2 Hand3
+env3 = SkatEnv piles Nothing (Colour Diamonds Einfach) pls2 Hand3 Hand3
     where hand1 = [ Card Jack Diamonds, Card Jack Clubs, Card Nine Spades, Card King Spades
                   , Card Seven Diamonds, Card Nine Diamonds, Card Seven Clubs, Card Eight Clubs
                   , Card Ten Clubs, Card Eight Hearts ]
@@ -29,4 +29,4 @@ env3 = SkatEnv piles Nothing (Colour Diamonds Einfach) pls2 Hand3
 shuffledEnv2 :: IO SkatEnv
 shuffledEnv2 = do
     cards <- shuffleCards
-    return $ SkatEnv (distribute cards) Nothing (Colour Spades Einfach) pls2 Hand1
+    return $ SkatEnv (distribute cards) Nothing (Colour Spades Einfach) pls2 Hand1 Hand3

package.yaml

@@ -1,5 +1,5 @@
 name:                skat
-version:             0.1.0.7
+version:             0.1.0.8
 github:              "githubuser/skat"
 license:             BSD3
 author:              "flavis"
@@ -34,6 +34,8 @@ dependencies:
 - containers
 - case-insensitive
 - vector
+- transformers
+- exceptions
 
 library:
   source-dirs: src

skat.cabal

@@ -4,10 +4,10 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 9c412ae20820c69f342fb431118c3d2be6a5461e1b5a521d92c1546f163ee94a
+-- hash: a2e08e04140990ba90e6d7b70c6bc70b99d073ba723efa9d5e35708995da45e1
 
 name:           skat
-version:        0.1.0.7
+version:        0.1.0.8
 description:    Please see the README on Gitea at <https://git.flavigny.de/christian/skat>
 homepage:       https://github.com/githubuser/skat#readme
 bug-reports:    https://github.com/githubuser/skat/issues
@@ -56,12 +56,14 @@ library
     , case-insensitive
     , containers
     , deepseq
+    , exceptions
     , mtl
     , network
     , parallel
     , random
     , split
     , text
+    , transformers
     , vector
     , websockets
   default-language: Haskell2010
@@ -81,6 +83,7 @@ executable skat-exe
     , case-insensitive
     , containers
     , deepseq
+    , exceptions
     , mtl
     , network
     , parallel
@@ -88,6 +91,7 @@ executable skat-exe
     , skat
     , split
     , text
+    , transformers
     , vector
     , websockets
   default-language: Haskell2010
@@ -107,6 +111,7 @@ test-suite skat-test
     , case-insensitive
     , containers
     , deepseq
+    , exceptions
     , mtl
     , network
     , parallel
@@ -114,6 +119,7 @@ test-suite skat-test
     , skat
     , split
     , text
+    , transformers
     , vector
     , websockets
   default-language: Haskell2010

src/Skat.hs

@@ -5,6 +5,7 @@
 module Skat where
 
 import Control.Monad.State
+import Control.Monad.Writer
 import Control.Monad.Reader
 import Data.List
 import Data.Vector (Vector)
@@ -17,19 +18,33 @@ import qualified Skat.Player as P
 
 data SkatEnv = SkatEnv { piles :: Piles
                        , turnColour :: Maybe TurnColour
-                       , game :: Game
+                       , skatGame :: Game
                        , players :: Players
-                       , currentHand :: Hand }
+                       , currentHand :: Hand
+                       , skatSinglePlayer :: Hand }
                deriving Show
 
-type Skat = StateT SkatEnv IO
+type Skat = StateT SkatEnv (WriterT [Trick] IO)
+
+runSkat :: Skat a -> SkatEnv -> IO (a, SkatEnv, [Trick])
+runSkat action env = do
+    ((val, env'), tricks) <- runWriterT $ runStateT action env
+    return (val, env', tricks)
+
+evalSkat :: Skat a -> SkatEnv -> IO a
+evalSkat action = (fmap fst) . runWriterT . evalStateT action
+
+execSkat :: Skat a -> SkatEnv -> IO SkatEnv
+execSkat action = (fmap fst) . runWriterT . execStateT action
 
 instance P.MonadPlayer Skat where
-    trump = gets $ getTrump . game
+    trump = getTrump <$> P.game
     turnColour = gets turnColour
     showSkat p = case P.team p of
         Single -> fmap (Just . skatCards) $ gets piles
         Team -> return Nothing
+    singlePlayer = gets skatSinglePlayer
+    game = gets skatGame
 
 instance P.MonadPlayerOpen Skat where
     showPiles = gets piles
@@ -51,7 +66,7 @@ setTurnColour col sk = sk { turnColour = col }
 setCurrentHand :: Hand -> SkatEnv -> SkatEnv
 setCurrentHand hand sk = sk { currentHand = hand }
 
-mkSkatEnv :: Piles -> Maybe TurnColour -> Game -> Players -> Hand -> SkatEnv
+mkSkatEnv :: Piles -> Maybe TurnColour -> Game -> Players -> Hand -> Hand -> SkatEnv
 mkSkatEnv = SkatEnv
 
 allowedCards :: Skat [CardS Owner]

src/Skat/AI/Human.hs

@@ -15,7 +15,7 @@ data Human = Human { getTeam :: Team
 instance Player Human where
     team = getTeam
     hand = getHand
-    chooseCard p table _ hand = do
+    chooseCard p table _ _ hand = do
         trumpCol <- trump
         turnCol <- turnColour
         let possible = filter (isAllowed trumpCol turnCol hand) hand

src/Skat/AI/Online.hs

@@ -47,7 +47,7 @@ instance Show (PrepOnline c) where
 instance Communicator c => Player (OnlineEnv c) where
     team = getTeam
     hand = getHand
-    chooseCard p table _ hand = runReaderT (choose table hand) p >>= \c -> return (c, p)
+    chooseCard p table _ mayOuvert hand = runReaderT (choose table mayOuvert hand) p >>= \c -> return (c, p)
     onCardPlayed p c = runReaderT (cardPlayed c) p >> return p
 
 instance Communicator c => Bidder (PrepOnline c) where
@@ -84,6 +84,10 @@ instance Communicator c => Bidder (PrepOnline c) where
             Just (ChosenCards cards) -> return cards
             Nothing -> askSkat p bid cards
     toPlayer p tm = PL $ OnlineEnv tm (prepHand p) (prepConnection p)
+    onBid p mayBid reizer gereizter =
+        liftIO $ send (prepConnection p) (BS.unpack $ encode $ BidEvent mayBid reizer gereizter)
+    onResponse p response reizer gereizter =
+        liftIO $ send (prepConnection p) (BS.unpack $ encode $ ResponseEvent response reizer gereizter)
     onStart p = do
         let cards = sortRender Jacks $ prepCards p
         liftIO $ send (prepConnection p) (BS.unpack $ encode $ CardsQuery cards)
@@ -91,6 +95,8 @@ instance Communicator c => Bidder (PrepOnline c) where
         liftIO $ send (prepConnection p) (BS.unpack $ encode $ GameResultsQuery res)
     onGame p game sglPlayer = do
         liftIO $ send (prepConnection p) (BS.unpack $ encode $ GameStartQuery game sglPlayer)
+    onNoGame p = do
+        liftIO $ send (prepConnection p) (BS.unpack $ encode $ NoGameQuery)
 
 type Online a m = ReaderT (OnlineEnv a) m
 
@@ -106,33 +112,40 @@ instance MonadPlayer m => MonadPlayer (Online a m) where
     trump = lift $ trump
     turnColour = lift $ turnColour
     showSkat = lift . showSkat
+    singlePlayer = lift singlePlayer
+    game = lift game
 
-choose :: HasCard a => (Communicator c, MonadPlayer m) => [CardS Played] -> [a] -> Online c m Card
+choose :: (HasCard b, HasCard a) => (Communicator c, MonadPlayer m) => [CardS Played] -> Maybe [b] -> [a] -> Online c m Card
-choose table hand' = do
+choose table mayOuvert hand' = do
-    let hand = sortRender Jacks $ map toCard hand'
+    gm <- game
-    query (BS.unpack $ encode $ ChooseQuery hand table)
+    let hand = sortRender (getTrump gm) $ map toCard hand'
+        ouvertCards = fmap (sortRender (getTrump gm) . map toCard) mayOuvert
+    query (BS.unpack $ encode $ ChooseQuery hand table ouvertCards)
     r <- response
     case decode (BS.pack r) of
         Just (ChosenResponse card) -> do
             allowed <- P.isAllowed hand card
-            if card `elem` hand && allowed then return card else choose table hand'
+            if card `elem` hand && allowed then return card else choose table mayOuvert hand'
-        Nothing -> choose table hand'
+        Nothing -> choose table mayOuvert hand'
 
 cardPlayed :: (Communicator c, MonadPlayer m) => CardS Played -> Online c m ()
 cardPlayed card = query (BS.unpack $ encode $ CardPlayedQuery card)
 
 -- | QUERIES AND RESPONSES
     
-data Query = ChooseQuery [Card] [CardS Played]
+data Query = ChooseQuery [Card] [CardS Played] (Maybe [Card])
            | CardPlayedQuery (CardS Played)
            | GameResultsQuery Result
-           | GameStartQuery Game Hand
+           | GameStartQuery HideGame Hand
            | BidQuery Hand Bid
            | BidResponseQuery Hand Bid
            | AskGameQuery Bid
            | AskHandQuery
            | AskSkatQuery [Card] Bid
            | CardsQuery [Card]
+           | BidEvent (Maybe Bid) Hand Hand
+           | ResponseEvent Bool Hand Hand
+           | NoGameQuery
 
 newtype ChosenResponse = ChosenResponse Card
 newtype BidResponse = BidResponse Int
@@ -142,8 +155,9 @@ newtype GameResponse = GameResponse Game
 newtype ChosenCards = ChosenCards [Card]
      
 instance ToJSON Query where
-    toJSON (ChooseQuery hand table) =
+    toJSON (ChooseQuery hand table mayOuvert) =
-        object ["query" .= ("choose_card" :: String), "hand" .= hand, "table" .= table]
+        object [ "query" .= ("choose_card" :: String), "hand" .= hand, "table" .= table
+               , "single_hand" .= mayOuvert]
     toJSON (CardPlayedQuery card) =
         object ["query" .= ("card_played" :: String), "card" .= card]
     toJSON (GameResultsQuery result) =
@@ -151,7 +165,7 @@ instance ToJSON Query where
     toJSON (GameStartQuery game sglPlayer) =
         object [ "query" .= ("start_game" :: String)
                , "game" .= game
-               , "single" .= toInt sglPlayer ]
+               , "single" .= show sglPlayer ]
     toJSON (BidQuery hand bid) =
         object ["query" .= ("bid" :: String), "whom" .= show hand, "current" .= bid]
     toJSON (BidResponseQuery hand bid) =
@@ -164,6 +178,21 @@ instance ToJSON Query where
         object ["query" .= ("cards" :: String), "cards" .= cards ]
     toJSON (AskGameQuery bid) =
         object ["query" .= ("ask_game" :: String), "bid" .= bid]
+    toJSON (BidEvent (Just bid) reizer gereizter) =
+        object ["query" .= ("bid_event" :: String), "bid" .= bid, "reizer" .= show reizer,
+                "gereizter" .= show gereizter ]
+    toJSON (BidEvent Nothing reizer gereizter) =
+        object [ "query" .= ("bid_event" :: String)
+               , "bid" .= ("weg" :: String)
+               , "reizer" .= show reizer
+               , "gereizter" .= show gereizter ]
+    toJSON (ResponseEvent response reizer gereizter) =
+        object [ "query" .= ("response_event" :: String)
+               , "response" .= response
+               , "reizer" .= show reizer
+               , "gereizter" .= show gereizter ]
+    toJSON NoGameQuery =
+        object [ "query" .= ("no_game" :: String) ]
 
 instance FromJSON ChosenResponse where
     parseJSON = withObject "ChosenResponse" $ \v -> ChosenResponse

src/Skat/AI/Rulebased.hs

@@ -22,7 +22,7 @@ import qualified Skat.Player.Utils as P
 import Skat.Pile hiding (isSkat)
 import Skat.Card
 import Skat.Utils
-import Skat (Skat, modifyp, mkSkatEnv) 
+import Skat (Skat, modifyp, mkSkatEnv, evalSkat)
 import Skat.Operations
 import qualified Skat.AI.Minmax as Minmax
 import qualified Skat.AI.Stupid as Stupid (Stupid(..))
@@ -80,7 +80,7 @@ runWithPiles ps sim = runReaderT sim ps
 instance Player AIEnv where
     team = getTeam
     hand = getHand
-    chooseCard p table fallen hand = runStateT (do
+    chooseCard p table fallen _ hand = runStateT (do
         modify $ setTable table
         modify $ setHand (map toCard hand)
         modify $ setFallen fallen
@@ -316,8 +316,8 @@ chooseSimulating = do
                      (PL $ Stupid.Stupid Team Hand2)
                      (PL $ Stupid.Stupid Single Hand3)
         -- TODO: fix
-        env = mkSkatEnv piles turnCol undefined ps myHand
+        env = mkSkatEnv piles turnCol undefined ps myHand undefined
-    liftIO $ evalStateT (toCard <$> (Minmax.choose depth :: Skat (CardS Owner))) env
+    liftIO $ evalSkat (toCard <$> (Minmax.choose depth :: Skat (CardS Owner))) env
 
 simulate :: (MonadState AIEnv m, MonadPlayerOpen m)
          => Card -> m Int
@@ -337,9 +337,9 @@ simulate card = do
             (PL $ mkAIEnv Team Hand2 newDepth)
             (PL $ mkAIEnv Single Hand3 newDepth)
         -- TODO: fix
-        env = mkSkatEnv piles turnCol undefined ps (next myHand)
+        env = mkSkatEnv piles turnCol undefined ps (next myHand) undefined
     -- simulate the game after playing the given card
-    (sgl, tm) <- liftIO $ evalStateT (do
+    (sgl, tm) <- liftIO $ evalSkat (do
         modifyp $ playCard myHand card
         turnGeneric playOpen depth) env
     let v = if myTeam == Single then (sgl, tm) else (tm, sgl)

src/Skat/AI/Server.hs

@@ -48,13 +48,18 @@ initServer :: Net.PortNumber -> Buffering -> OnReceive -> IO ServerEnv
 initServer port buffermode handler = do
     sock <- Net.socket Net.AF_INET Net.Stream 0
     Net.setSocketOption sock Net.ReuseAddr 1
-    Net.bind sock (Net.SockAddrInet port Net.iNADDR_ANY)
+    addr <- Net.addrAddress <$> resolve
+    Net.bind sock addr
     Net.listen sock 5
     chan <- newChan
     forkIO $ forever $ do
         msg <- readChan chan -- clearing the main channel
         return ()
     return (ServerEnv buffermode sock chan handler)
+  where resolve = do
+            let hints = Net.defaultHints { Net.addrSocketType = Net.Stream }
+            addrs <- Net.getAddrInfo (Just hints) (Just "127.0.0.1") (Just $ show port)
+            return $ head addrs
 
 close :: ServerEnv -> IO ()
 close = Net.close . socket

src/Skat/AI/Stupid.hs

@@ -1,5 +1,8 @@
 module Skat.AI.Stupid where
 
+import Control.Concurrent
+import Control.Monad.State
+
 import Skat.Player
 import Skat.Pile
 import Skat.Card
@@ -13,9 +16,10 @@ data Stupid = Stupid { getTeam :: Team
 instance Player Stupid where
     team = getTeam
     hand = getHand
-    chooseCard p _ _ hand = do
+    chooseCard p _ _ _ hand = do
         trumpCol <- trump
         turnCol <- turnColour
+        liftIO $ threadDelay 1000000
         let possible = filter (isAllowed trumpCol turnCol hand) hand
         return (toCard $ head possible, p)
 
@@ -25,7 +29,7 @@ newtype NoBidder = NoBidder Hand
 -- | no bidding from that player
 instance Bidder NoBidder where
     hand (NoBidder h) = h
-    askBid _ _ bid = return $ Just 20
+    askBid _ _ bid = return Nothing
     askResponse _ _ bid = if bid < 24 then return True else return False
     askGame _ _ = return $ Grand Hand
     askHand _ _ = return True

src/Skat/Bidding.hs

@@ -2,7 +2,7 @@
 
 module Skat.Bidding (
     biddingScore, Game(..), Modifier(..), isHand, getTrump, Result(..),
-    getResults
+    getResults, isOuvert, isSchwarz, Bid, checkGame, HideGame(..)
 ) where
 
 import Data.Aeson hiding (Null, Result)
@@ -13,6 +13,8 @@ import Data.Ord (Down(..))
 import Control.Monad
 import Skat.Pile
 
+type Bid = Int
+
 -- | different game types
 data Game = Colour Colour Modifier
           | Grand Modifier
@@ -22,6 +24,9 @@ data Game = Colour Colour Modifier
           | NullOuvertHand
             deriving (Show, Eq)
 
+newtype HideGame = HideGame Game
+                   deriving (Show, Eq)
+
 instance ToJSON Game where
     toJSON (Grand mod) =
         object ["game" .= ("grand" :: String), "modifier" .= show mod]
@@ -32,6 +37,13 @@ instance ToJSON Game where
     toJSON NullOuvert     = object ["game" .= ("nullouvert" :: String)]
     toJSON NullOuvertHand = object ["game" .= ("nullouverthand" :: String)]
 
+instance ToJSON HideGame where
+    toJSON (HideGame (Grand mod)) =
+        object ["game" .= ("grand" :: String), "modifier" .= prettyShow mod]
+    toJSON (HideGame (Colour col mod)) =
+        object ["game" .= ("colour" :: String), "modifier" .= prettyShow mod, "colour" .= show col]
+    toJSON (HideGame game) = toJSON game
+
 instance FromJSON Game where
     parseJSON = withObject "Game" $ \v -> do
         gamekind <- v .: "game"
@@ -56,7 +68,7 @@ data Modifier = Einfach
               | Hand
               | HandSchneider
               | HandSchneiderAngesagt
-              | HandSchneiderSchwarz
+              | HandSchwarz
               | HandSchneiderAngesagtSchwarz
               | HandSchwarzAngesagt
               | Ouvert
@@ -76,11 +88,44 @@ instance FromJSON Modifier where
                 _ -> return Hand
         else return Einfach
 
-isHand :: Modifier -> Bool
+prettyShow :: Modifier -> String
-isHand Einfach   = False
+prettyShow Schneider                    = show Einfach
-isHand Schneider = False
+prettyShow Schwarz                      = show Einfach
-isHand Schwarz   = False
+prettyShow HandSchneider                = show Hand
-isHand _         = True
+prettyShow HandSchwarz                  = show Hand
+prettyShow HandSchneiderAngesagtSchwarz = show HandSchneiderAngesagt
+prettyShow mod                          = show mod
+
+isHand :: Game -> Bool
+isHand NullHand = True
+isHand NullOuvertHand = True
+isHand (Colour _ mod) = modIsHand mod
+isHand (Grand mod) = modIsHand mod
+isHand _ = False
+
+modIsHand :: Modifier -> Bool
+modIsHand Einfach   = False
+modIsHand Schneider = False
+modIsHand Schwarz   = False
+modIsHand _         = True
+
+isOuvert :: Game -> Bool
+isOuvert NullOuvert        = True
+isOuvert NullOuvertHand    = True
+isOuvert (Grand Ouvert)    = True
+isOuvert (Colour _ Ouvert) = True
+isOuvert _                 = False
+
+baseFactor :: Game -> Int
+baseFactor (Grand _)           = 24
+baseFactor (Colour Clubs _)    = 12
+baseFactor (Colour Spades _)   = 11
+baseFactor (Colour Hearts _)   = 10
+baseFactor (Colour Diamonds _) = 9
+baseFactor Null                = 23
+baseFactor NullHand            = 35
+baseFactor NullOuvert          = 46
+baseFactor NullOuvertHand      = 59
 
 -- | calculate the value of a game with given cards
 biddingScore :: HasCard c => Game -> [c] -> Int
@@ -89,10 +134,7 @@ biddingScore game@(Colour Clubs    mod) cards = (spitzen game cards + modifierFa
 biddingScore game@(Colour Spades   mod) cards = (spitzen game cards + modifierFactor mod) * 11
 biddingScore game@(Colour Hearts   mod) cards = (spitzen game cards + modifierFactor mod) * 10
 biddingScore game@(Colour Diamonds mod) cards = (spitzen game cards + modifierFactor mod) * 9
-biddingScore Null                       _     = 23
+biddingScore game                       _     = baseFactor game
-biddingScore NullHand                   _     = 35
-biddingScore NullOuvert                 _     = 46
-biddingScore NullOuvertHand             _     = 59
 
 -- | calculate the modifier based on the game kind
 modifierFactor :: Modifier -> Int
@@ -102,7 +144,7 @@ modifierFactor Schwarz                      = 3
 modifierFactor Hand                         = 2
 modifierFactor HandSchneider                = 3
 modifierFactor HandSchneiderAngesagt        = 4
-modifierFactor HandSchneiderSchwarz         = 4
+modifierFactor HandSchwarz                  = 4
 modifierFactor HandSchneiderAngesagtSchwarz = 5
 modifierFactor HandSchwarzAngesagt          = 6
 modifierFactor Ouvert                       = 7
@@ -140,7 +182,10 @@ getTrump (Colour col _) = TrumpColour col
 getTrump (Grand _)      = Jacks
 getTrump _              = None
 
-data Result = Result Game Int Int Int
+data Result = Result { resultGame :: Game
+                     , resultScore :: Int
+                     , resultSinglePoints :: Int
+                     , resultTeamPoints :: Int }
               deriving (Show, Eq)
 
 instance ToJSON Result where
@@ -163,16 +208,36 @@ hasWon (Grand mod) ps = let (b, mod') = meetsCall mod ps
 meetsCall :: Modifier -> Piles -> (Bool, Modifier)
 meetsCall Hand ps = case wonByPoints ps of
     (b, Schneider) -> (b, HandSchneider)
-    (b, Schwarz) -> (b, HandSchneiderSchwarz)
+    (b, Schwarz) -> (b, HandSchwarz)
     (b, Einfach) -> (b, Hand)
+meetsCall Schneider ps = case wonByPoints ps of
+    (b, Schneider) -> (b, Schneider)
+    (b, Schwarz) -> (b, Schwarz)
+    (b, Einfach) -> (False, Schneider)
+meetsCall Schwarz ps = case wonByPoints ps of
+    (b, Schneider) -> (False, Schwarz)
+    (b, Schwarz) -> (b, Schwarz)
+    (b, Einfach) -> (False, Schwarz)
+meetsCall HandSchneider ps = case wonByPoints ps of
+    (b, Schneider) -> (b, HandSchneider)
+    (b, Schwarz) -> (b, HandSchwarz)
+    (b, Einfach) -> (False, HandSchneider)
 meetsCall HandSchneiderAngesagt ps = case wonByPoints ps of
     (b, Schneider) -> (b, HandSchneiderAngesagt)
     (b, Schwarz) -> (b, HandSchneiderAngesagtSchwarz)
     (b, Einfach) -> (False, HandSchneiderAngesagt)
+meetsCall HandSchwarz ps = case wonByPoints ps of
+    (b, Schneider) -> (False, HandSchwarz)
+    (b, Schwarz) -> (b, HandSchwarz)
+    (b, Einfach) -> (False, HandSchwarz)
 meetsCall HandSchwarzAngesagt ps = case wonByPoints ps of
     (b, Schneider) -> (False, HandSchwarzAngesagt)
     (b, Schwarz) -> (b, HandSchwarzAngesagt)
     (b, Einfach) -> (False, HandSchwarzAngesagt)
+meetsCall Ouvert ps = case wonByPoints ps of
+    (b, Schneider) -> (False, Ouvert)
+    (b, Schwarz) -> (b, Ouvert)
+    (b, Einfach) -> (False, Ouvert)
 meetsCall _ ps = wonByPoints ps
 
 wonByPoints :: Piles -> (Bool, Modifier)
@@ -185,10 +250,33 @@ wonByPoints ps
   where (sgl, _) = count ps :: (Int, Int)
 
 -- | get result of game
-getResults :: Game -> Hand -> Piles -> Piles -> Result
+getResults :: Game -> Bid -> Hand -> Piles -> Piles -> Result
-getResults game sglPlayer before after = Result afterGame score sglPoints teamPoints
+getResults game bid sglPlayer before after = case checkGame bid hand game of
-    where (won, afterGame) = hasWon game after
+        Just game' -> let (won, afterGame) = hasWon game' after
-          hand = skatCards before ++ (map toCard $ handCards sglPlayer before)
+                          gameScore = biddingScore afterGame hand 
+                          score = if won then gameScore else (-2) * gameScore
+            in Result afterGame score sglPoints teamPoints
+        Nothing -> let gameScore = baseFactor game * ceiling (fromIntegral bid / fromIntegral (baseFactor game))
+                       score = (-2) * gameScore
+            in Result game score sglPoints teamPoints
+    where hand = skatCards before ++ (map toCard $ handCards sglPlayer before)
           (sglPoints, teamPoints) = count after
-          gameScore = biddingScore afterGame hand 
+
-          score = if won then gameScore else (-2) * gameScore
+checkGame :: HasCard c => Bid -> [c] -> Game -> Maybe Game
+checkGame bid cards game@(Colour col mod)
+    | biddingScore game cards >= bid = Just game
+    | otherwise                      = upgrade mod >>= \mod' -> checkGame bid cards (Colour col mod')
+checkGame bid cards game@(Grand mod)
+    | biddingScore game cards >= bid = Just game
+    | otherwise                      = upgrade mod >>= \mod' -> checkGame bid cards (Grand mod')
+checkGame bid cards game
+    | biddingScore game cards >= bid = Just game
+    | otherwise                      = Nothing
+
+upgrade :: Modifier -> Maybe Modifier
+upgrade Einfach               = Just Schneider
+upgrade Schneider             = Just Schwarz
+upgrade Hand                  = Just HandSchneider
+upgrade HandSchneider         = Just HandSchwarz
+upgrade HandSchneiderAngesagt = Just HandSchneiderAngesagtSchwarz
+upgrade _                     = Nothing

src/Skat/Card.hs

@@ -29,7 +29,7 @@ data Type = Seven
           | Ten
           | Ace
           | Jack
-            deriving (Eq, Ord, Show, Enum, Read)
+            deriving (Eq, Ord, Show, Enum, Read, Bounded)
 
 data NullType = NSeven
               | NEight
@@ -39,7 +39,7 @@ data NullType = NSeven
               | NQueen
               | NKing
               | NAce
-                deriving (Eq, Ord, Show, Enum, Read)
+                deriving (Eq, Ord, Show, Enum, Read, Bounded)
 
 instance Countable Type Int where
     count Ace   = 11
@@ -53,7 +53,7 @@ data Colour = Diamonds
             | Hearts
             | Spades
             | Clubs
-              deriving (Eq, Ord, Show, Enum, Read)
+              deriving (Eq, Ord, Show, Enum, Read, Bounded)
 
 data Trump = TrumpColour Colour
            | Jacks
@@ -65,7 +65,7 @@ data TurnColour = TurnColour Colour
                   deriving (Show, Eq)
 
 data Card = Card Type Colour
-            deriving (Eq, Show, Ord, Read)
+            deriving (Eq, Show, Ord, Read, Bounded)
 
 getType :: Card -> Type
 getType (Card t _) = t
@@ -117,6 +117,17 @@ instance Countable (S.Set Card) Int where
 instance NFData Card where
     rnf (Card t c) = t `seq` c `seq` ()
 
+base64table :: [Char]
+base64table = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
+
+class Serialize c a where
+    serialize :: a -> c
+    deserialize :: c -> Maybe a
+
+instance Serialize Char Card where
+    serialize card = base64table !! fromEnum card
+    deserialize char = base64table `indexOf` char >>= safeToEnum 
+
 equals :: TurnColour -> Maybe TurnColour -> Bool
 equals col (Just x) = col == x
 equals col Nothing = True
@@ -162,9 +173,11 @@ compareCards trump turnCol c1@(Card tp1 col1) c2@(Card tp2 col2) =
 compareRender :: Trump -> Card -> Card -> Ordering
 compareRender trump c1@(Card tp1 col1) c2@(Card tp2 col2) =
     case (trp1, trp2) of
-        (True, True) -> compare tp1 tp2
+        (True, True) -> case compare tp1 tp2 of
+            EQ -> compare col1 col2
+            v  -> v
         (False, False) -> case compare col1 col2 of
-                            EQ -> compare tp1 tp2
+                            EQ -> compareTypes trump tp1 tp2
                             v  -> v
         _ -> compare trp1 trp2
   where trp1 = isTrump trump c1
@@ -185,12 +198,15 @@ compareTypes None tp1 tp2 = compare (toNullType tp1) (toNullType tp2)
           toNullType Ace = NAce
 compareTypes _ tp1 tp2 = compare tp1 tp2
 
+-- | ascending sort of cards, depending on turn colour
 sortCards :: HasCard c => Trump -> Maybe TurnColour -> [c] -> [c]
 sortCards trump turnCol cs = sortBy f cs
     where f c1 c2 = compareCards trump turnCol (toCard c1) (toCard c2)
 
+-- | descending sort of cards, independent of turn colour
 sortRender :: HasCard c => Trump -> [c] -> [c]
 sortRender trump cs = sortBy f cs
+    -- note: reversed order of c1 and c2 to get a descending sort
     where f c1 c2 = compareRender trump (toCard c2) (toCard c1)
 
 highestCard :: HasCard c => Trump -> Maybe TurnColour -> [c] -> c

src/Skat/Matches.hs

@@ -1,36 +1,91 @@
 module Skat.Matches (
-    singleVsBots, pvp, singleWithBidding
+    singleVsBots, pvp, singleWithBidding, Match(..), Unfinished(..), continue,
+    Table(..), twoWithBidding, H(..), randomPositions
 ) where
 
 import Control.Monad.State
 import Control.Monad.Reader
-import System.Random (mkStdGen)
+import System.Random (mkStdGen, newStdGen)
 
 import Skat
 import Skat.Operations
-import Skat.Player
+import Skat.Player as P
 import Skat.Pile
 import Skat.Card
 import Skat.Preperation
 import Skat.Bidding
+import Skat.Utils (shuffle)
 
 import Skat.AI.Rulebased
 import Skat.AI.Online
 import Skat.AI.Stupid
 
-match :: PrepEnv -> IO ()
+data Table = Unfinished Unfinished
+           | Finished Match
+           | Pass { tablePiles :: Piles }
+             deriving Show
+
+data Match = Match { matchPiles :: Piles
+                   , matchResult :: Result
+                   , matchTricks :: [Trick]
+                   , matchSingle :: Hand }
+             deriving Show
+
+data Unfinished = UnfinishedGame { unfinishedGame :: SkatEnv
+                                 , unfinishedPrep :: PrepEnv
+                                 , unfinishedTricks :: [Trick] }
+                | UnfinishedPrep { unfinishedPrep :: PrepEnv }
+                  deriving Show
+
+continue :: Communicator c => Unfinished -> c -> c -> c -> IO Table
+continue (UnfinishedGame skatEnv prepEnv tricks) comm1 comm2 comm3 = do
+    let ps = players skatEnv
+        ps' = Players
+            (PL $ OnlineEnv (P.team $ player ps Hand1) (P.hand $ player ps Hand1) comm1)
+            (PL $ OnlineEnv (P.team $ player ps Hand2) (P.hand $ player ps Hand2) comm2)
+            (PL $ OnlineEnv (P.team $ player ps Hand3) (P.hand $ player ps Hand3) comm3)
+        bs = bidders prepEnv
+        bs' = Bidders
+            (BD $ PrepOnline (Skat.Preperation.hand $ bidder bs Hand1) comm1 [])
+            (BD $ PrepOnline (Skat.Preperation.hand $ bidder bs Hand2) comm2 [])
+            (BD $ PrepOnline (Skat.Preperation.hand $ bidder bs Hand3) comm3 [])
+        skatEnv' = skatEnv { players = ps' }
+        prepEnv' = prepEnv { bidders = bs' }
+    runGame prepEnv' skatEnv'
+
+match :: PrepEnv -> IO Table
 match prepEnv = do
-    maySkatEnv <- runReaderT runPreperation prepEnv
+    (maySkatEnv, prepEnv') <- runStateT runPreperation prepEnv
     case maySkatEnv of
-        Just (sglPlayer, skatEnv) -> do
+        Just skatEnv -> runGame prepEnv' skatEnv
-            finished <- execStateT turn skatEnv
+        Nothing -> do
-            let res = getResults
+            putStrLn "no one wanted to play"
-                    (game skatEnv)
+            return $ Pass $ Skat.Preperation.piles prepEnv'
-                    sglPlayer
+
-                    (Skat.piles skatEnv)
+runGame :: PrepEnv -> SkatEnv -> IO Table
-                    (Skat.piles finished)
+runGame prepEnv skatEnv = do
-            publishGameResults res (bidders prepEnv)
+    (isFinished, finalEnv, tricks) <- (flip runSkat) skatEnv $ do
-        Nothing -> putStrLn "no one wanted to play"
+        -- send current table cards to clients
+        -- only relevant if this is a continued game
+        -- otherwise table is empty
+        table <- getp tableCards
+        ps <- playersToList <$> gets players
+        mapM_ (\card -> mapM_ (\p -> onCardPlayed p card) ps) (reverse table)
+        -- run game
+        turn
+        -- return if game has finished
+        gameOver
+    if isFinished then do
+        let res = getResults
+                (skatGame skatEnv)
+                (Skat.Preperation.current prepEnv)
+                (skatSinglePlayer skatEnv)
+                (Skat.Preperation.piles prepEnv)
+                (Skat.piles finalEnv)
+        publishGameResults res (bidders prepEnv)
+        return $ Finished $ Match (Skat.Preperation.piles prepEnv) res tricks (skatSinglePlayer skatEnv)
+    else do -- if not finished an error has occured, thus returning unfinished game state
+        return $ Unfinished $ UnfinishedGame finalEnv prepEnv tricks
 
 -- | predefined card distribution for testing purposes
 cardDistr :: Piles
@@ -53,8 +108,8 @@ singleVsBots comm = do
                 (PL $ OnlineEnv Team Hand1 comm)
                 (PL $ Stupid Team Hand2)
                 (PL $ mkAIEnv Single Hand3 10)
-        env = SkatEnv (distribute cards) Nothing (Colour Spades Einfach) ps Hand1
+        env = SkatEnv (distribute cards) Nothing (Colour Spades Einfach) ps Hand1 Hand3
-    void $ evalStateT turn env
+    void $ evalSkat turn env
 
 singleWithBidding :: Communicator c => c -> IO ()
 singleWithBidding comm = do
@@ -65,10 +120,30 @@ singleWithBidding comm = do
                 (BD $ PrepOnline Hand1 comm h1)
                 (BD $ NoBidder Hand2)
                 (BD $ NoBidder Hand3)
-        env = PrepEnv ps bs
+        env = makePrep ps bs
-    match env
+    void $ match env
 
-pvp :: Communicator c => c -> c -> c -> IO ()
+--- helper object for twoWithBidding
+data H = P1 | P2 | AI
+
+randomPositions :: IO [H]
+randomPositions = do
+    gen <- newStdGen
+    return $ shuffle gen [P1, P2, AI]
+
+twoWithBidding :: Communicator c => [H] -> c -> c -> IO ()
+twoWithBidding positions comm1 comm2 = do
+    cards <- shuffleCards
+    let bds = zipWith mkBidder [Hand1, Hand2, Hand3] positions
+        ps = distribute cards
+        mkBidder hand P1 = BD $ PrepOnline hand comm1 (map toCard $ handCards hand ps)
+        mkBidder hand P2 = BD $ PrepOnline hand comm2 (map toCard $ handCards hand ps)
+        mkBidder hand AI = BD $ NoBidder hand
+        bs = Bidders (bds !! 0) (bds !! 1) (bds !! 2)
+        env = makePrep ps bs
+    void $ match env
+
+pvp :: Communicator c => c -> c -> c -> IO Table
 pvp comm1 comm2 comm3 = do
     cards <- shuffleCards
     let ps = distribute cards
@@ -79,5 +154,5 @@ pvp comm1 comm2 comm3 = do
                 (BD $ PrepOnline Hand1 comm1 $ h1)
                 (BD $ PrepOnline Hand2 comm2 $ h2)
                 (BD $ PrepOnline Hand3 comm3 $ h3)
-        env = PrepEnv ps bs
+        env = makePrep ps bs
     match env

src/Skat/Operations.hs

@@ -1,9 +1,12 @@
 module Skat.Operations (
     turn, turnGeneric, play, playOpen,
-    play_, sortRender, undo_
+    play_, sortRender, undo_, gameOver
 ) where
 
 import Control.Monad.State
+import Control.Monad.Catch
+import Control.Exception hiding (catch, bracketOnError)
+import Control.Monad.Writer (tell)
 import System.Random (newStdGen, randoms)
 import Data.List
 import Data.Ord
@@ -13,8 +16,10 @@ import Skat
 import Skat.Card
 import Skat.Pile
 import Skat.Player (chooseCard, Players(..), Player(..), PL(..),
-    updatePlayer, playersToList, player, MonadPlayer, getSinglePlayer, trump)
+    updatePlayer, playersToList, player, MonadPlayer, getSinglePlayer, trump, game,
+    singlePlayer)
 import Skat.Utils (shuffle)
+import Skat.Bidding
 
 play_ :: HasCard c => c -> Skat ()
 play_ card = do
@@ -42,19 +47,34 @@ turnGeneric playFunc depth = do
     table <- getp tableCards
     ps <- gets players
     let p = player ps n
-    over <- getp $ handEmpty n
     trCol <- trump
     case length table of
-        0 -> playFunc p >> modify (setCurrentHand $ next n) >> turnGeneric playFunc depth
+        0 -> do
+            catchAll
+                (do
+                    playFunc p
+                    modify (setCurrentHand $ next n)
+                    turnGeneric playFunc depth)
+                (\_ -> countGame)
         1 -> do
             modify $ setTurnColour
                 (Just $ effectiveColour trCol $ head table)
-            playFunc p
+            catchAll
-            modify (setCurrentHand $ next n)
+                (do
-            turnGeneric playFunc depth
+                    playFunc p
-        2 -> playFunc p >> modify (setCurrentHand $ next n) >> turnGeneric playFunc depth
+                    modify (setCurrentHand $ next n)
+                    turnGeneric playFunc depth)
+                (\_ -> countGame)
+        2 -> do
+            catchAll
+                (do
+                    playFunc p
+                    modify (setCurrentHand $ next n)
+                    turnGeneric playFunc depth)
+                (\_ -> countGame)
         3 -> do
             w <- evaluateTable
+            over <- gameOver
             if depth <= 1 || over
                 then countGame
                 else modify (setCurrentHand w) >> turnGeneric playFunc (depth - 1)
@@ -72,6 +92,7 @@ evaluateTable = do
         winner = player ps winnerHand
     modifyp $ cleanTable (team winner)
     modify $ setTurnColour Nothing
+    tell [(table !! 2, table !! 1, table !! 0)]
     return $ hand winner
 
 countGame :: Skat (Int, Int)
@@ -84,7 +105,10 @@ play p = do
     trump <- trump
     cards <- getp $ handCards (hand p)
     fallen <- getp played
-    (card, p') <- chooseCard p table fallen cards
+    ouvert <- isOuvert <$> game
+    mayOuvert <- if ouvert then Just <$> (singlePlayer >>= getp . handCards)
+        else return Nothing
+    (card, p') <- chooseCard p table fallen mayOuvert cards
     modifyPlayers $ updatePlayer p'
     modifyp $ playCard (hand p) card
     ps <- fmap playersToList $ gets players
@@ -99,3 +123,13 @@ playOpen p = do
     card <- chooseCardOpen p
     modifyp $ playCard (hand p) card
     return card
+
+gameOver :: Skat Bool
+gameOver = do
+    tr <- trump
+    case tr of
+        None -> do
+            singleLost <- gets piles >>= return . not . (Single `isSchwarz`)
+            if singleLost then return True
+            else gets currentHand >>= getp . handCards >>= return . null
+        _ -> gets currentHand >>= getp . handCards >>= return . null

src/Skat/Pile.hs

@@ -6,6 +6,9 @@
 
 module Skat.Pile where
 
+import Control.Monad.State
+import Control.Monad.Trans.Maybe
+
 import Prelude hiding (lookup)
 import qualified Data.Map.Strict as M
 import qualified Data.Vector as V
@@ -15,6 +18,8 @@ import Data.Maybe
 import Data.Aeson
 import Control.Exception
 import Data.List (delete)
+import Text.Read (readMaybe)
+import Debug.Trace
 
 import Skat.Card
 import Skat.Utils
@@ -41,7 +46,7 @@ instance ToJSON p => ToJSON (CardS p) where
         object ["card" .= card, "pile" .= pile]
 
 data Hand = Hand1 | Hand2 | Hand3
-            deriving (Show, Eq, Ord, Read)
+            deriving (Show, Eq, Ord, Read, Enum, Bounded)
 
 toInt :: Hand -> Int
 toInt Hand1 = 1
@@ -61,12 +66,33 @@ prev Hand3 = Hand2
 data Owner = P Hand | S
              deriving (Show, Eq, Ord, Read)
 
+instance Enum Owner where
+    fromEnum (P hand) = fromEnum hand
+    fromEnum S        = 3
+    toEnum 0          = P Hand1
+    toEnum 1          = P Hand2
+    toEnum 2          = P Hand3
+    toEnum 3          = S
+
+instance Bounded Owner where
+    maxBound = S
+    minBound = P Hand1
+
 instance ToJSON Owner where
     toJSON (P hand) = object ["owner" .= show hand]
     toJSON S        = object ["owner" .= ("skat" :: String) ]
 
+instance Serialize String (CardS Owner) where
+    serialize (CardS card owner) = show (fromEnum owner) ++ [serialize card]
+    deserialize str = (flip evalState) str $ runMaybeT $ do
+        owner <- pop >>= MaybeT . return . (>>= safeToEnum) . readMaybe . (:[])
+        card <- pop >>= MaybeT . return . deserialize
+        return $ CardS card owner
+
 type Played = Owner -- TODO: remove
 
+type Trick = (CardS Owner, CardS Owner, CardS Owner)
+
 data Piles = Piles { _hand1 :: [CardS Owner]
                    , _hand2 :: [CardS Owner]
                    , _hand3 :: [CardS Owner]
@@ -185,3 +211,28 @@ distribute cards = emptyPiles hand1 hand2 hand3 skt
           hand1 = concatMap (!! 0) [round1, round2, round3]
           hand2 = concatMap (!! 1) [round1, round2, round3]
           hand3 = concatMap (!! 2) [round1, round2, round3]
+
+instance Serialize String Piles where
+    serialize piles = sers (_hand1 piles) ++ sers (_hand2 piles) ++ sers (_hand3 piles)
+            ++ sers (_skat piles)
+        where sers cards = map (serialize . toCard) cards
+    deserialize str = (flip evalState) str $ runMaybeT $ do
+            hand1 <- takeG 10 >>= mapM deser
+            hand2 <- takeG 10 >>= mapM deser
+            hand3 <- takeG 10 >>= mapM deser
+            skat <- takeG 2 >>= mapM deser
+            return $ emptyPiles hand1 hand2 hand3 skat
+        where deser char = MaybeT $ return $ deserialize char
+
+instance Serialize String [Trick] where
+    serialize []                    = ""
+    serialize ((c1, c2, c3):tricks) = serialize c1 ++ serialize c2 ++ serialize c3
+        ++ serialize tricks
+    deserialize str = (flip evalState) str $ runMaybeT $ reverse <$> go []
+        where go acc = do
+                empty <- isEmpty
+                if empty then return acc else do
+                   card1 <- takeG 2 >>= MaybeT . return . deserialize
+                   card2 <- takeG 2 >>= MaybeT . return . deserialize
+                   card3 <- takeG 2 >>= MaybeT . return . deserialize
+                   go ((card1, card2, card3):acc)

src/Skat/Player.hs

@@ -6,11 +6,14 @@ import Control.Monad.IO.Class
 
 import Skat.Card
 import Skat.Pile
+import Skat.Bidding
 
 class (Monad m, MonadIO m) => MonadPlayer m where
     trump :: m Trump
     turnColour :: m (Maybe TurnColour)
     showSkat :: Player p => p -> m (Maybe [Card])
+    singlePlayer :: m Hand
+    game :: m Game
 
 class (Monad m, MonadIO m, MonadPlayer m) => MonadPlayerOpen m where
     showPiles :: m (Piles)
@@ -18,10 +21,11 @@ class (Monad m, MonadIO m, MonadPlayer m) => MonadPlayerOpen m where
 class Player p where
     team :: p -> Team
     hand :: p -> Hand
-    chooseCard :: (HasCard c, MonadPlayer m)
+    chooseCard :: (HasCard d, HasCard c, MonadPlayer m)
                => p
                -> [CardS Played]
                -> [CardS Played]
+               -> Maybe [d]
                -> [c]
                -> m (Card, p)
     onCardPlayed :: MonadPlayer m
@@ -37,7 +41,10 @@ class Player p where
         let table = tableCards piles
             fallen = played piles
             myCards = handCards (hand p) piles
-        fst <$> chooseCard p table fallen myCards
+        ouvert <- isOuvert <$> game
+        mayOuvert <- if ouvert then Just <$> (singlePlayer >>= \hnd -> return $ handCards hnd piles)
+            else return Nothing
+        fst <$> chooseCard p table fallen mayOuvert myCards
 
 data PL = forall p. (Show p, Player p) => PL p
 
@@ -47,8 +54,8 @@ instance Show PL where
 instance Player PL where
     team (PL p) = team p
     hand (PL p) = hand p
-    chooseCard (PL p) table fallen hand = do
+    chooseCard (PL p) table fallen mayOuvert hand = do
-        (v, a) <- chooseCard p table fallen hand
+        (v, a) <- chooseCard p table fallen mayOuvert hand
         return $ (v, PL a)
     onCardPlayed (PL p) card = do
         v <- onCardPlayed p card

src/Skat/Preperation.hs

@@ -3,11 +3,11 @@
 
 module Skat.Preperation (
     Bidder(..), Bid, BD(..), Bidders(..), PrepEnv(..), runPreperation,
-    publishGameResults
+    publishGameResults, bidder, makePrep
 ) where
 
 import Control.Monad.IO.Class
-import Control.Monad.Reader
+import Control.Monad.State
 
 import Skat.Pile
 import Skat.Card
@@ -15,13 +15,15 @@ import Skat.Player (PL, Players(..))
 import Skat.Bidding
 import Skat (SkatEnv, mkSkatEnv)
 
-type Bid = Int
-
 data PrepEnv = PrepEnv { piles :: Piles
-                       , bidders :: Bidders }
+                       , bidders :: Bidders
+                       , current :: Bid }
                deriving Show
 
-type Preperation = ReaderT PrepEnv IO
+makePrep :: Piles -> Bidders -> PrepEnv
+makePrep ps bd = PrepEnv ps bd 0
+
+type Preperation = StateT PrepEnv IO
 
 class Bidder a where
     hand :: a -> Hand
@@ -32,10 +34,16 @@ 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 ()
+    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
@@ -54,6 +62,9 @@ instance Bidder BD where
     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
@@ -69,9 +80,9 @@ 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 (Hand, SkatEnv))
+runPreperation :: Preperation (Maybe SkatEnv)
 runPreperation = do
-    bds <- asks bidders
+    bds <- gets bidders
     onStart (bidder bds Hand1)
     onStart (bidder bds Hand2)
     onStart (bidder bds Hand3)
@@ -79,10 +90,11 @@ runPreperation = do
     (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 . (finalWinner,)) <$> initGame finalWinner val
+            Just val -> Just <$> initGame finalWinner val
-            Nothing -> return Nothing
+            Nothing -> publishNoGame >> return Nothing
-        else (Just . (finalWinner,)) <$> initGame finalWinner finalBid
+        else Just <$> initGame finalWinner finalBid
 
 runBidding :: Bid -> BD -> BD -> Preperation (Hand, Bid)
 runBidding startingBid reizer gereizter = do
@@ -90,16 +102,23 @@ runBidding startingBid reizer gereizter = do
     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 -> return (hand gereizter, startingBid)
+            | otherwise -> do
-        Nothing -> return (hand gereizter, startingBid)
+                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 <- asks piles
+    ps <- gets piles
-    bds <- asks bidders
+    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
@@ -109,19 +128,15 @@ initGame single bid = do
     -- publish game start
     publishGameStart game single
     -- construct skat env
-    return $ mkSkatEnv ps' Nothing game (toPlayers single bds) Hand1
+    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
-    case proposal of
+    if isHand proposal == noSkat then return proposal else handleGame bd bid noSkat
-        g@(Colour col mod) -> if isHand mod == noSkat
-            then return g else handleGame bd bid noSkat
-        g@(Grand mod) -> if isHand mod == noSkat
-            then return g else handleGame bd bid noSkat
-        g -> return g
 
 handleSkat :: BD -> Bid -> Piles -> Preperation Piles
 handleSkat bd bid ps = do
@@ -139,8 +154,20 @@ publishGameResults res bidders = do
     onResult (bidder bidders Hand3) res
 
 publishGameStart :: Game -> Hand -> Preperation ()
-publishGameStart game sglPlayer = do
+publishGameStart game sglPlayer = mapBidders (\b -> onGame b (HideGame game) sglPlayer)
-    bds <- asks bidders
+
-    onGame (bidder bds Hand1) game sglPlayer
+publishBid :: Maybe Bid -> Hand -> Hand -> Preperation ()
-    onGame (bidder bds Hand2) game sglPlayer
+publishBid bid reizer gereizter = mapBidders (\b -> onBid b bid reizer gereizter)
-    onGame (bidder bds Hand3) game sglPlayer
+
+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)

src/Skat/Utils.hs

@@ -1,7 +1,12 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
 module Skat.Utils where
 
+import Control.Monad.State
+import Control.Monad.Trans.Maybe
+
 import System.Random
-import Text.Read
+import Text.Read hiding (get, lift)
 import qualified Data.ByteString.Char8 as B (ByteString, unpack, pack)
 import qualified Data.Text as T (Text, unpack, pack)
 import Data.List (foldl')
@@ -57,3 +62,36 @@ instance Stringy B.ByteString where
 instance Stringy T.Text where
     toString = T.unpack
     fromString = T.pack
+
+indexOf :: Eq a => [a] -> a -> Maybe Int
+indexOf [] _ = Nothing
+indexOf (x:xs) item
+    | x == item = Just 0
+    | otherwise = (1+) <$> xs `indexOf` item
+
+type Generator c = MaybeT (State [c])
+
+pop :: Generator c c
+pop = do
+    cs <- get
+    if null cs then mzero else put (tail cs) >> return (head cs)
+
+isEmpty :: Generator c Bool
+isEmpty = get >>= return . null
+
+takeG :: Int -> Generator c [c]
+takeG n = do
+    cs <- lift get
+    if length cs >= n
+        then do
+            put (drop n cs)
+            return (take n cs)
+        else mzero
+
+-- forall is needed to allow scoped type variables
+safeToEnum :: forall a. (Enum a, Bounded a) => Int -> Maybe a
+safeToEnum n
+    | maxN < n || minN > n = Nothing
+    | otherwise            = Just $ toEnum n
+  where maxN = fromEnum (maxBound :: a)
+        minN = fromEnum (minBound :: a)

stack.yaml

@@ -17,7 +17,7 @@
 #
 # resolver: ./custom-snapshot.yaml
 # resolver: https://example.com/snapshots/2018-01-01.yaml
-resolver: lts-14.3
+resolver: lts-18.18
 
 # User packages to be built.
 # Various formats can be used as shown in the example below.