implement grand and null mechanics, fix some online player issues

app/Main.hs

@@ -12,6 +12,7 @@ import Skat.Card
 import Skat.Operations
 import Skat.Player
 import Skat.Pile
+import Skat.Bidding
 
 import Skat.AI.Stupid
 import Skat.AI.Online
@@ -37,7 +38,7 @@ runAI = do
     env <- shuffledEnv
     let ps = piles env
         cs = handCards Hand3 ps
-        trs = filter (isTrump Spades) cs
+        trs = filter (isTrump $ TrumpColour Spades) cs
     if length trs >= 5 && any ((==32) . getID) cs
         then do
             pts <- fst <$> evalStateT turn env
@@ -46,11 +47,11 @@ runAI = do
         else runAI
 
 env :: SkatEnv
-env = SkatEnv piles Nothing Spades playersExamp Hand1
+env = SkatEnv piles Nothing (Colour Spades Einfach) playersExamp Hand1
     where piles = distribute allCards 
 
 envStupid :: SkatEnv
-envStupid = SkatEnv piles Nothing Spades pls2 Hand1
+envStupid = SkatEnv piles Nothing (Colour Spades Einfach) pls2 Hand1
     where piles = distribute allCards 
 
 playersExamp :: Players
@@ -68,22 +69,22 @@ pls2 = Players
 shuffledEnv :: IO SkatEnv
 shuffledEnv = do
     cards <- shuffleCards
-    return $ SkatEnv (distribute cards) Nothing Spades playersExamp Hand1
+    return $ SkatEnv (distribute cards) Nothing (Colour Spades Einfach) playersExamp Hand1
 
 shuffledEnv2 :: IO SkatEnv
 shuffledEnv2 = do
     cards <- shuffleCards
-    return $ SkatEnv (distribute cards) Nothing Spades pls2 Hand1
+    return $ SkatEnv (distribute cards) Nothing (Colour Spades Einfach) pls2 Hand1
 
 env2 :: SkatEnv
-env2 = SkatEnv piles Nothing Hearts playersExamp Hand2
+env2 = SkatEnv piles Nothing (Colour Hearts Einfach) playersExamp Hand2
     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 Diamonds pls2 Hand3
+env3 = SkatEnv piles Nothing (Colour Diamonds Einfach) pls2 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 ]

app/TestEnvs.hs

@@ -5,6 +5,7 @@ import Skat.Card
 import Skat.Pile
 import Skat.Player
 import Skat.AI.Stupid
+import Skat.Bidding
 
 pls2 :: Players
 pls2 = Players
@@ -13,7 +14,7 @@ pls2 = Players
     (PL $ Stupid Single Hand3)
 
 env3 :: SkatEnv
-env3 = SkatEnv piles Nothing Diamonds pls2 Hand3
+env3 = SkatEnv piles Nothing (Colour Diamonds Einfach) pls2 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 ]
@@ -28,4 +29,4 @@ env3 = SkatEnv piles Nothing Diamonds pls2 Hand3
 shuffledEnv2 :: IO SkatEnv
 shuffledEnv2 = do
     cards <- shuffleCards
-    return $ SkatEnv (distribute cards) Nothing Spades pls2 Hand1
+    return $ SkatEnv (distribute cards) Nothing (Colour Spades Einfach) pls2 Hand1

package.yaml

@@ -1,5 +1,5 @@
 name:                skat
-version:             0.1.0.5
+version:             0.1.0.7
 github:              "githubuser/skat"
 license:             BSD3
 author:              "flavis"

skat.cabal

@@ -4,10 +4,10 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
+-- hash: 9c412ae20820c69f342fb431118c3d2be6a5461e1b5a521d92c1546f163ee94a
 
 name:           skat
-version:        0.1.0.5
+version:        0.1.0.7
 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

src/Skat.hs

@@ -10,13 +10,14 @@ import Data.List
 import Data.Vector (Vector)
 
 import Skat.Card
+import Skat.Bidding
 import Skat.Pile
 import Skat.Player (Players)
 import qualified Skat.Player as P
 
 data SkatEnv = SkatEnv { piles :: Piles
-                       , turnColour :: Maybe Colour
-                       , trumpColour :: Colour
+                       , turnColour :: Maybe TurnColour
+                       , game :: Game
                        , players :: Players
                        , currentHand :: Hand }
                deriving Show
@@ -24,7 +25,7 @@ data SkatEnv = SkatEnv { piles :: Piles
 type Skat = StateT SkatEnv IO
 
 instance P.MonadPlayer Skat where
-    trumpColour = gets trumpColour
+    trump = gets $ getTrump . game
     turnColour = gets turnColour
     showSkat p = case P.team p of
         Single -> fmap (Just . skatCards) $ gets piles
@@ -44,19 +45,19 @@ modifyPlayers :: (Players -> Players) -> Skat ()
 modifyPlayers f = modify g
     where g env@(SkatEnv {players}) = env { players = f players }
 
-setTurnColour :: Maybe Colour -> SkatEnv -> SkatEnv
+setTurnColour :: Maybe TurnColour -> SkatEnv -> SkatEnv
 setTurnColour col sk = sk { turnColour = col }
 
 setCurrentHand :: Hand -> SkatEnv -> SkatEnv
 setCurrentHand hand sk = sk { currentHand = hand }
 
-mkSkatEnv :: Piles -> Maybe Colour -> Colour -> Players -> Hand -> SkatEnv
+mkSkatEnv :: Piles -> Maybe TurnColour -> Game -> Players -> Hand -> SkatEnv
 mkSkatEnv = SkatEnv
 
 allowedCards :: Skat [CardS Owner]
 allowedCards = do
     curHand <- gets currentHand
     pls <- gets players
-    turnCol <- gets turnColour
-    trumpCol <- gets trumpColour
+    turnCol <- P.turnColour
+    trumpCol <- P.trump
     getp $ allowed curHand trumpCol turnCol

src/Skat/AI/Human.hs

@@ -16,7 +16,7 @@ instance Player Human where
     team = getTeam
     hand = getHand
     chooseCard p table _ hand = do
-        trumpCol <- trumpColour
+        trumpCol <- trump
         turnCol <- turnColour
         let possible = filter (isAllowed trumpCol turnCol hand) hand
         c <- liftIO $ askIO (map getCard table) (map toCard possible) (map toCard hand)

src/Skat/AI/Online.hs

@@ -6,7 +6,7 @@ module Skat.AI.Online where
 
 import Control.Monad.Reader
 import Control.Concurrent.Chan
-import Data.Aeson
+import Data.Aeson hiding (Result)
 import Data.Maybe
 import qualified Data.ByteString.Lazy.Char8 as BS
 
@@ -49,8 +49,6 @@ instance Communicator c => Player (OnlineEnv c) where
     hand = getHand
     chooseCard p table _ hand = runReaderT (choose table hand) p >>= \c -> return (c, p)
     onCardPlayed p c = runReaderT (cardPlayed c) p >> return p
-    onGameResults p res = runReaderT (onResults res) p
-    onGameStart p singlePlayer = runReaderT (onStartOnline singlePlayer) p
 
 instance Communicator c => Bidder (PrepOnline c) where
     hand = prepHand
@@ -87,8 +85,12 @@ instance Communicator c => Bidder (PrepOnline c) where
             Nothing -> askSkat p bid cards
     toPlayer p tm = PL $ OnlineEnv tm (prepHand p) (prepConnection p)
     onStart p = do
-        let cards = prepCards p
+        let cards = sortRender Jacks $ prepCards p
         liftIO $ send (prepConnection p) (BS.unpack $ encode $ CardsQuery cards)
+    onResult p res =
+        liftIO $ send (prepConnection p) (BS.unpack $ encode $ GameResultsQuery res)
+    onGame p game sglPlayer = do
+        liftIO $ send (prepConnection p) (BS.unpack $ encode $ GameStartQuery game sglPlayer)
 
 type Online a m = ReaderT (OnlineEnv a) m
 
@@ -101,13 +103,13 @@ instance (Communicator c, MonadIO m) => MonadClient (Online c m) where
         liftIO $ receive conn
 
 instance MonadPlayer m => MonadPlayer (Online a m) where
-    trumpColour = lift $ trumpColour
+    trump = lift $ trump
     turnColour = lift $ turnColour
     showSkat = lift . showSkat
 
 choose :: HasCard a => (Communicator c, MonadPlayer m) => [CardS Played] -> [a] -> Online c m Card
 choose table hand' = do
-    let hand = map toCard hand'
+    let hand = sortRender Jacks $ map toCard hand'
     query (BS.unpack $ encode $ ChooseQuery hand table)
     r <- response
     case decode (BS.pack r) of
@@ -119,21 +121,12 @@ choose table hand' = do
 cardPlayed :: (Communicator c, MonadPlayer m) => CardS Played -> Online c m ()
 cardPlayed card = query (BS.unpack $ encode $ CardPlayedQuery card)
 
-onResults :: (Communicator c, MonadIO m) => (Int, Int) -> Online c m ()
-onResults (sgl, tm) = query (BS.unpack $ encode $ GameResultsQuery sgl tm)
-
-onStartOnline :: (Communicator c, MonadPlayer m) => Hand -> Online c m ()
-onStartOnline singlePlayer = do
-    trCol <- trumpColour
-    ownHand <- asks getHand
-    query (BS.unpack $ encode $ GameStartQuery trCol ownHand singlePlayer)
-
 -- | QUERIES AND RESPONSES
     
 data Query = ChooseQuery [Card] [CardS Played]
            | CardPlayedQuery (CardS Played)
-           | GameResultsQuery Int Int
-           | GameStartQuery Colour Hand Hand
+           | GameResultsQuery Result
+           | GameStartQuery Game Hand
            | BidQuery Hand Bid
            | BidResponseQuery Hand Bid
            | AskGameQuery Bid
@@ -153,15 +146,16 @@ instance ToJSON Query where
         object ["query" .= ("choose_card" :: String), "hand" .= hand, "table" .= table]
     toJSON (CardPlayedQuery card) =
         object ["query" .= ("card_played" :: String), "card" .= card]
-    toJSON (GameResultsQuery sgl tm) =
-        object ["query" .= ("results" :: String), "single" .= sgl, "team" .= tm]
-    toJSON (GameStartQuery trumps handNo sglPlayer) =
-        object ["query" .= ("start_game" :: String), "trumps" .= show trumps,
-                "hand" .= toInt handNo, "single" .= toInt sglPlayer ]
+    toJSON (GameResultsQuery result) =
+        object ["query" .= ("results" :: String), "result" .= result]
+    toJSON (GameStartQuery game sglPlayer) =
+        object [ "query" .= ("start_game" :: String)
+               , "game" .= game
+               , "single" .= toInt sglPlayer ]
     toJSON (BidQuery hand bid) =
         object ["query" .= ("bid" :: String), "whom" .= show hand, "current" .= bid]
     toJSON (BidResponseQuery hand bid) =
-        object ["query" .= ("bid_response" :: String), "from" .= show hand ]
+        object ["query" .= ("bid_response" :: String), "from" .= show hand, "bid" .= bid ]
     toJSON (AskHandQuery) =
         object ["query" .= ("play_hand" :: String)]
     toJSON (AskSkatQuery cards bid) =

src/Skat/AI/Rulebased.hs

@@ -26,6 +26,7 @@ import Skat (Skat, modifyp, mkSkatEnv)
 import Skat.Operations
 import qualified Skat.AI.Minmax as Minmax
 import qualified Skat.AI.Stupid as Stupid (Stupid(..))
+import Skat.Bidding
 
 data AIEnv = AIEnv { getTeam :: Team
                    , getHand :: Hand
@@ -55,8 +56,8 @@ modifyg f = modify g
 type AI m = StateT AIEnv m
 
 instance MonadPlayer m => MonadPlayer (AI m) where
-    trumpColour = lift $ trumpColour
-    turnColour = lift $ turnColour
+    trump = lift trump
+    turnColour = lift turnColour
     showSkat = lift . showSkat
 
 instance MonadPlayerOpen m => MonadPlayerOpen (AI m) where
@@ -65,7 +66,7 @@ instance MonadPlayerOpen m => MonadPlayerOpen (AI m) where
 type Simulator m = ReaderT Piles (AI m)
 
 instance MonadPlayer m => MonadPlayer (Simulator m) where
-    trumpColour = lift $ trumpColour
+    trump = lift trump
     turnColour = lift $ turnColour
     showSkat = lift . showSkat
 
@@ -112,15 +113,15 @@ has hand cs = M.mapWithKey f
             | card `elem` cs = [H hand]
             | otherwise      = hands
 
-hasNoLonger :: MonadPlayer m => Hand -> Colour -> AI m ()
+hasNoLonger :: MonadPlayer m => Hand -> TurnColour -> AI m ()
 hasNoLonger hand colour = do
-    trCol <- trumpColour
+    trCol <- trump
     modifyg $ hasNoLonger_ trCol hand colour
 
-hasNoLonger_ :: Colour -> Hand -> Colour -> Guess -> Guess
-hasNoLonger_ trColour hand effCol = M.mapWithKey f
+hasNoLonger_ :: Trump -> Hand -> TurnColour -> Guess -> Guess
+hasNoLonger_ trump hand effCol = M.mapWithKey f
     where f card hands
-            | effectiveColour trColour card == effCol && (H hand) `elem` hands = filter (/=H hand) hands
+            | effectiveColour trump card == effCol && (H hand) `elem` hands = filter (/=H hand) hands
             | otherwise = hands
 
 isSkat :: [Card] -> Guess -> Guess
@@ -136,7 +137,7 @@ analyzeTurn (c1, c2, c3) = do
     modifyg (getCard c1 `hasBeenPlayed`)
     modifyg (getCard c2 `hasBeenPlayed`)
     modifyg (getCard c3 `hasBeenPlayed`)
-    trCol <- trumpColour
+    trCol <- trump
     let turnCol = getColour $ getCard c1
         demanded = effectiveColour trCol (getCard c1)
         col2 = effectiveColour trCol (getCard c2)
@@ -218,7 +219,7 @@ onPlayed :: MonadPlayer m => CardS Played -> AI m ()
 onPlayed c = do
     liftIO $ print c
     modifyg (getCard c `hasBeenPlayed`)
-    trCol <- trumpColour
+    trCol <- trump
     turnCol <- turnColour
     let col = effectiveColour trCol (getCard c)
     case turnCol of
@@ -308,13 +309,14 @@ chooseSimulating :: (MonadState AIEnv m, MonadPlayerOpen m)
 chooseSimulating = do
     piles <- showPiles
     turnCol <- turnColour
-    trumpCol <- trumpColour
+    trumpCol <- trump
     myHand <- gets getHand
     depth <- gets simulationDepth
     let ps = Players (PL $ Stupid.Stupid Team Hand1)
                      (PL $ Stupid.Stupid Team Hand2)
                      (PL $ Stupid.Stupid Single Hand3)
-        env = mkSkatEnv piles turnCol trumpCol ps myHand
+        -- TODO: fix
+        env = mkSkatEnv piles turnCol undefined ps myHand
     liftIO $ evalStateT (toCard <$> (Minmax.choose depth :: Skat (CardS Owner))) env
 
 simulate :: (MonadState AIEnv m, MonadPlayerOpen m)
@@ -323,7 +325,7 @@ simulate card = do
     -- retrieve all relevant info
     piles <- showPiles
     turnCol <- turnColour
-    trumpCol <- trumpColour
+    trumpCol <- trump
     myTeam <- gets getTeam
     myHand <- gets getHand
     depth <- gets simulationDepth
@@ -334,7 +336,8 @@ simulate card = do
             (PL $ mkAIEnv Team Hand1 newDepth)
             (PL $ mkAIEnv Team Hand2 newDepth)
             (PL $ mkAIEnv Single Hand3 newDepth)
-        env = mkSkatEnv piles turnCol trumpCol ps (next myHand)
+        -- TODO: fix
+        env = mkSkatEnv piles turnCol undefined ps (next myHand)
     -- simulate the game after playing the given card
     (sgl, tm) <- liftIO $ evalStateT (do
         modifyp $ playCard myHand card
@@ -357,7 +360,7 @@ predictValue (own, others) = do
 potential :: (MonadState AIEnv m, MonadPlayerOpen m, HasCard c)
           => [c] -> m Int
 potential cs = do
-    tr <- trumpColour
+    tr <- trump
     let trs = filter (isTrump tr) cs
         value = count . map toCard $ cs
     positions <- filter (==0) <$> mapM (position . toCard) cs
@@ -366,7 +369,7 @@ potential cs = do
 position :: (MonadState AIEnv m, MonadPlayer m)
          => Card -> m Int
 position card = do
-    tr <- trumpColour
+    tr <- trump
     guess <- gets guess
     let effCol = effectiveColour tr card
         l = M.toList guess

src/Skat/AI/Stupid.hs

@@ -4,6 +4,7 @@ import Skat.Player
 import Skat.Pile
 import Skat.Card
 import Skat.Preperation
+import Skat.Bidding
 
 data Stupid = Stupid { getTeam :: Team
                      , getHand :: Hand }
@@ -13,7 +14,7 @@ instance Player Stupid where
     team = getTeam
     hand = getHand
     chooseCard p _ _ hand = do
-        trumpCol <- trumpColour
+        trumpCol <- trump
         turnCol <- turnColour
         let possible = filter (isAllowed trumpCol turnCol hand) hand
         return (toCard $ head possible, p)
@@ -24,10 +25,10 @@ newtype NoBidder = NoBidder Hand
 -- | no bidding from that player
 instance Bidder NoBidder where
     hand (NoBidder h) = h
-    askBid _ _ _ = return Nothing
-    askResponse _ _ _ = return False
-    askGame _ _ = undefined -- never called
-    askHand _ _ = return False -- never called
+    askBid _ _ bid = return $ Just 20
+    askResponse _ _ bid = if bid < 24 then return True else return False
+    askGame _ _ = return $ Grand Hand
+    askHand _ _ = return True
     askSkat _ _ _ = undefined -- never called
     toPlayer (NoBidder h) team = PL $ Stupid team h
     onStart _ = return ()

src/Skat/Bidding.hs

@@ -1,15 +1,17 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 module Skat.Bidding (
-    biddingScore, Game(..), Modifier(..), isHand
+    biddingScore, Game(..), Modifier(..), isHand, getTrump, Result(..),
+    getResults
 ) where
 
-import Data.Aeson hiding (Null)
+import Data.Aeson hiding (Null, Result)
 
 import Skat.Card
 import Data.List (sortOn)
 import Data.Ord (Down(..))
 import Control.Monad
+import Skat.Pile
 
 -- | different game types
 data Game = Colour Colour Modifier
@@ -20,6 +22,16 @@ data Game = Colour Colour Modifier
           | NullOuvertHand
             deriving (Show, Eq)
 
+instance ToJSON Game where
+    toJSON (Grand mod) =
+        object ["game" .= ("grand" :: String), "modifier" .= show mod]
+    toJSON (Colour col mod) =
+        object ["game" .= ("colour" :: String), "modifier" .= show mod, "colour" .= show col]
+    toJSON Null           = object ["game" .= ("null" :: String)]
+    toJSON NullHand       = object ["game" .= ("nullhand" :: String)]
+    toJSON NullOuvert     = object ["game" .= ("nullouvert" :: String)]
+    toJSON NullOuvertHand = object ["game" .= ("nullouverthand" :: String)]
+
 instance FromJSON Game where
     parseJSON = withObject "Game" $ \v -> do
         gamekind <- v .: "game"
@@ -118,6 +130,65 @@ spitzen game cards
 
 -- | get all trumps for a given game out of a hand of cards
 getTrumps :: HasCard c => Game -> [c] -> [Card]
-getTrumps (Grand _) cards = sortOn Down $ filter ((==Jack) . getType) $ map toCard cards
-getTrumps (Colour col _) cards = sortOn Down $ filter (isTrump col) $ map toCard cards
+getTrumps (Grand _) cards = sortOn Down $ filter (isTrump Jacks) $ map toCard cards
+getTrumps (Colour col _) cards = sortOn Down $ filter (isTrump $ TrumpColour col) $ map toCard cards
 getTrumps _              _      = []
+
+-- | get trump for a given game
+getTrump :: Game -> Trump
+getTrump (Colour col _) = TrumpColour col
+getTrump (Grand _)      = Jacks
+getTrump _              = None
+
+data Result = Result Game Int Int Int
+              deriving (Show, Eq)
+
+instance ToJSON Result where
+    toJSON (Result game points sgl tm) =
+        object ["game" .= game, "points" .= points, "single" .= sgl, "team" .= tm]
+
+isSchwarz :: Team -> Piles -> Bool
+isSchwarz tm = null . wonCards tm 
+
+hasWon :: Game -> Piles -> (Bool, Game)
+hasWon Null           ps = (Single `isSchwarz` ps, Null)
+hasWon NullHand       ps = (Single `isSchwarz` ps, NullHand)
+hasWon NullOuvert     ps = (Single `isSchwarz` ps, NullOuvert)
+hasWon NullOuvertHand ps = (Single `isSchwarz` ps, NullOuvertHand)
+hasWon (Colour col mod) ps = let (b, mod') = meetsCall mod ps
+                             in (b, Colour col mod')
+hasWon (Grand mod) ps = let (b, mod') = meetsCall mod ps
+                        in (b, Grand mod')
+
+meetsCall :: Modifier -> Piles -> (Bool, Modifier)
+meetsCall Hand ps = case wonByPoints ps of
+    (b, Schneider) -> (b, HandSchneider)
+    (b, Schwarz) -> (b, HandSchneiderSchwarz)
+    (b, Einfach) -> (b, Hand)
+meetsCall HandSchneiderAngesagt ps = case wonByPoints ps of
+    (b, Schneider) -> (b, HandSchneiderAngesagt)
+    (b, Schwarz) -> (b, HandSchneiderAngesagtSchwarz)
+    (b, Einfach) -> (False, HandSchneiderAngesagt)
+meetsCall HandSchwarzAngesagt ps = case wonByPoints ps of
+    (b, Schneider) -> (False, HandSchwarzAngesagt)
+    (b, Schwarz) -> (b, HandSchwarzAngesagt)
+    (b, Einfach) -> (False, HandSchwarzAngesagt)
+meetsCall _ ps = wonByPoints ps
+
+wonByPoints :: Piles -> (Bool, Modifier)
+wonByPoints ps
+    | Team `isSchwarz` ps    = (True,     Schwarz)
+    | sgl              >= 90 = (True,     Schneider)
+    | Single `isSchwarz` ps  = (False,    Schwarz)
+    | sgl              <= 30 = (False,    Schneider)
+    | otherwise              = (sgl > 60, Einfach)
+  where (sgl, _) = count ps :: (Int, Int)
+
+-- | get result of game
+getResults :: Game -> Hand -> Piles -> Piles -> Result
+getResults game sglPlayer before after = Result afterGame score sglPoints teamPoints
+    where (won, afterGame) = hasWon game after
+          hand = skatCards before ++ (map toCard $ handCards sglPlayer before)
+          (sglPoints, teamPoints) = count after
+          gameScore = biddingScore afterGame hand 
+          score = if won then gameScore else (-2) * gameScore

src/Skat/Card.hs

@@ -31,6 +31,16 @@ data Type = Seven
           | Jack
             deriving (Eq, Ord, Show, Enum, Read)
 
+data NullType = NSeven
+              | NEight
+              | NNine
+              | NTen
+              | NJack
+              | NQueen
+              | NKing
+              | NAce
+                deriving (Eq, Ord, Show, Enum, Read)
+
 instance Countable Type Int where
     count Ace   = 11
     count Ten   = 10
@@ -45,6 +55,15 @@ data Colour = Diamonds
             | Clubs
               deriving (Eq, Ord, Show, Enum, Read)
 
+data Trump = TrumpColour Colour
+           | Jacks
+           | None
+             deriving (Show, Eq)
+
+data TurnColour = TurnColour Colour
+                | Trump
+                  deriving (Show, Eq)
+
 data Card = Card Type Colour
             deriving (Eq, Show, Ord, Read)
 
@@ -98,50 +117,85 @@ instance Countable (S.Set Card) Int where
 instance NFData Card where
     rnf (Card t c) = t `seq` c `seq` ()
 
-equals :: Colour -> Maybe Colour -> Bool
+equals :: TurnColour -> Maybe TurnColour -> Bool
 equals col (Just x) = col == x
 equals col Nothing = True
 
-isTrump :: HasCard c => Colour -> c -> Bool
-isTrump trumpCol crd
+isTrump :: HasCard c => Trump -> c -> Bool
+isTrump None crd = False
+isTrump Jacks crd = getType (toCard crd) == Jack
+isTrump (TrumpColour trumpCol) crd
     | getType (toCard crd) == Jack = True
     | otherwise = getColour (toCard crd) == trumpCol
 
-effectiveColour :: HasCard c => Colour -> c -> Colour
-effectiveColour trumpCol crd = if trump then trumpCol else getColour (toCard crd)
-  where trump = isTrump trumpCol crd
+effectiveColour :: HasCard c => Trump -> c -> TurnColour
+effectiveColour trump card
+    | isTrump trump card = Trump
+    | otherwise          = TurnColour $ getColour (toCard card)
 
-isAllowed :: (Foldable t, HasCard c1, HasCard c2) => Colour -> Maybe Colour -> t c1 -> c2 -> Bool
-isAllowed trumpCol turnCol cs crd =
+isAllowed :: (Foldable t, HasCard c1, HasCard c2) => Trump -> Maybe TurnColour -> t c1 -> c2 -> Bool
+isAllowed trump turnCol cs crd =
     if col `equals` turnCol
         then True
-        else not $ F.any (\ca -> effectiveColour trumpCol ca `equals` turnCol && toCard ca /= toCard crd) cs
-  where col = effectiveColour trumpCol (toCard crd)
+        else not $ F.any (\ca -> effectiveColour trump ca `equals` turnCol && toCard ca /= toCard crd) cs
+  where col = effectiveColour trump (toCard crd)
 
-compareCards :: Colour
-             -> Maybe Colour
+compareCards :: Trump
+             -> Maybe TurnColour
              -> Card
              -> Card
              -> Ordering
 compareCards _ _ (Card Jack col1) (Card Jack col2) = compare col1 col2
-compareCards trumpCol turnCol c1@(Card tp1 col1) c2@(Card tp2 col2) =
+compareCards trump turnCol c1@(Card tp1 col1) c2@(Card tp2 col2) =
     case (trp1, trp2) of
         (True, True) -> compare tp1 tp2
-        (False, False) -> case compare (col1 `equals` turnCol)
-                                       (col2 `equals` turnCol) of
-                            EQ -> compare tp1 tp2
-                            v -> v
+        (False, False) -> case ( effectiveColour trump c1 `equals` turnCol
+                               , effectiveColour trump c2 `equals` turnCol ) of
+                            (True, True) -> compareTypes trump tp1 tp2
+                            (True, False) -> GT
+                            (False, True) -> LT
+                            _             -> EQ
         _ -> compare trp1 trp2
-  where trp1 = isTrump trumpCol c1
-        trp2 = isTrump trumpCol c2
+  where trp1 = isTrump trump c1
+        trp2 = isTrump trump c2
 
-sortCards :: HasCard c => Colour -> Maybe Colour -> [c] -> [c]
-sortCards trumpCol turnCol cs = sortBy f cs
-    where f c1 c2 = compareCards trumpCol turnCol (toCard c1) (toCard c2)
+compareRender :: Trump -> Card -> Card -> Ordering
+compareRender trump c1@(Card tp1 col1) c2@(Card tp2 col2) =
+    case (trp1, trp2) of
+        (True, True) -> compare tp1 tp2
+        (False, False) -> case compare col1 col2 of
+                            EQ -> compare tp1 tp2
+                            v  -> v
+        _ -> compare trp1 trp2
+  where trp1 = isTrump trump c1
+        trp2 = isTrump trump c2
 
-highestCard :: HasCard c => Colour -> Maybe Colour -> [c] -> c
-highestCard trumpCol turnCol cs = maximumBy f cs
-    where f c1 c2 = compareCards trumpCol turnCol (toCard c1) (toCard c2)
+compareTypes :: Trump
+             -> Type
+             -> Type
+             -> Ordering
+compareTypes None tp1 tp2 = compare (toNullType tp1) (toNullType tp2)
+    where toNullType Seven = NSeven
+          toNullType Eight = NEight
+          toNullType Nine = NNine
+          toNullType Ten = NTen
+          toNullType Jack = NJack
+          toNullType Queen = NQueen
+          toNullType King = NKing
+          toNullType Ace = NAce
+compareTypes _ tp1 tp2 = compare tp1 tp2
+
+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)
+
+sortRender :: HasCard c => Trump -> [c] -> [c]
+sortRender trump cs = sortBy f cs
+    where f c1 c2 = compareRender trump (toCard c2) (toCard c1)
+
+highestCard :: HasCard c => Trump -> Maybe TurnColour -> [c] -> c
+highestCard trump turnCol cs = maximumBy f cs
+    where f c1 c2 = compareCards trump turnCol (toCard c1) (toCard c2)
 
 shuffleCards :: IO [Card]
 shuffleCards = do

src/Skat/Matches.hs

@@ -1,5 +1,5 @@
 module Skat.Matches (
-    singleVsBots, pvp, pvpWithBidding, singleWithBidding
+    singleVsBots, pvp, singleWithBidding
 ) where
 
 import Control.Monad.State
@@ -12,11 +12,26 @@ import Skat.Player
 import Skat.Pile
 import Skat.Card
 import Skat.Preperation
+import Skat.Bidding
 
 import Skat.AI.Rulebased
 import Skat.AI.Online
 import Skat.AI.Stupid
 
+match :: PrepEnv -> IO ()
+match prepEnv = do
+    maySkatEnv <- runReaderT runPreperation prepEnv
+    case maySkatEnv of
+        Just (sglPlayer, skatEnv) -> do
+            finished <- execStateT turn skatEnv
+            let res = getResults
+                    (game skatEnv)
+                    sglPlayer
+                    (Skat.piles skatEnv)
+                    (Skat.piles finished)
+            publishGameResults res (bidders prepEnv)
+        Nothing -> putStrLn "no one wanted to play"
+
 -- | predefined card distribution for testing purposes
 cardDistr :: Piles
 cardDistr = emptyPiles hand1 hand2 hand3 skt
@@ -38,8 +53,8 @@ singleVsBots comm = do
                 (PL $ OnlineEnv Team Hand1 comm)
                 (PL $ Stupid Team Hand2)
                 (PL $ mkAIEnv Single Hand3 10)
-        env = SkatEnv (distribute cards) Nothing Spades ps Hand1
-    liftIO $ evalStateT (publishGameStart >> turn >>= publishGameResults) env
+        env = SkatEnv (distribute cards) Nothing (Colour Spades Einfach) ps Hand1
+    void $ evalStateT turn env
 
 singleWithBidding :: Communicator c => c -> IO ()
 singleWithBidding comm = do
@@ -51,24 +66,10 @@ singleWithBidding comm = do
                 (BD $ NoBidder Hand2)
                 (BD $ NoBidder Hand3)
         env = PrepEnv ps bs
-    maySkatEnv <- liftIO $ runReaderT runPreperation env
-    case maySkatEnv of
-        Just skatEnv ->
-            liftIO $ evalStateT (publishGameStart >> turn >>= publishGameResults) skatEnv
-        Nothing -> putStrLn "No one wanted to play."
+    match env
 
 pvp :: Communicator c => c -> c -> c -> IO ()
 pvp comm1 comm2 comm3 = do
-    cards <- shuffleCards
-    let ps = Players
-                (PL $ OnlineEnv Team Hand1 comm1)
-                (PL $ OnlineEnv Team Hand2 comm2)
-                (PL $ OnlineEnv Team Hand3 comm3)
-        env = SkatEnv (distribute cards) Nothing Spades ps Hand1
-    liftIO $ evalStateT (publishGameStart >> turn >>= publishGameResults) env
-
-pvpWithBidding :: Communicator c => c -> c -> c -> IO ()
-pvpWithBidding comm1 comm2 comm3 = do
     cards <- shuffleCards
     let ps = distribute cards
         h1 = map toCard $ handCards Hand1 ps
@@ -79,8 +80,4 @@ pvpWithBidding comm1 comm2 comm3 = do
                 (BD $ PrepOnline Hand2 comm2 $ h2)
                 (BD $ PrepOnline Hand3 comm3 $ h3)
         env = PrepEnv ps bs
-    maySkatEnv <- liftIO $ runReaderT runPreperation env
-    case maySkatEnv of
-        Just skatEnv ->
-            liftIO $ evalStateT (publishGameStart >> turn >>= publishGameResults) skatEnv
-        Nothing -> putStrLn "No one wanted to play."
+    match env

src/Skat/Operations.hs

@@ -1,6 +1,6 @@
 module Skat.Operations (
-    turn, turnGeneric, play, playOpen, publishGameResults,
-    publishGameStart, play_, sortRender, undo_
+    turn, turnGeneric, play, playOpen,
+    play_, sortRender, undo_
 ) where
 
 import Control.Monad.State
@@ -13,21 +13,13 @@ import Skat
 import Skat.Card
 import Skat.Pile
 import Skat.Player (chooseCard, Players(..), Player(..), PL(..),
-    updatePlayer, playersToList, player, MonadPlayer, getSinglePlayer)
+    updatePlayer, playersToList, player, MonadPlayer, getSinglePlayer, trump)
 import Skat.Utils (shuffle)
 
-compareRender :: Card -> Card -> Ordering
-compareRender (Card t1 c1) (Card t2 c2) = case compare c1 c2 of
-    EQ -> compare t1 t2
-    v  -> v
-
-sortRender :: [Card] -> [Card]
-sortRender = sortBy compareRender
-
 play_ :: HasCard c => c -> Skat ()
 play_ card = do
     hand <- gets currentHand
-    trCol <- gets trumpColour
+    trCol <- trump
     modifyp $ playCard hand card
     table <- getp tableCards
     case length table of
@@ -36,7 +28,7 @@ play_ card = do
         3 -> evaluateTable >>= modify . setCurrentHand
         _ -> modify (setCurrentHand $ next hand)
 
-undo_ :: HasCard c => c -> Hand -> Maybe Colour -> Team -> Skat ()
+undo_ :: HasCard c => c -> Hand -> Maybe TurnColour -> Team -> Skat ()
 undo_ card oldCurrent oldTurnCol oldWinner = do
     modify $ setCurrentHand oldCurrent
     modify $ setTurnColour oldTurnCol
@@ -51,7 +43,7 @@ turnGeneric playFunc depth = do
     ps <- gets players
     let p = player ps n
     over <- getp $ handEmpty n
-    trCol <- gets trumpColour
+    trCol <- trump
     case length table of
         0 -> playFunc p >> modify (setCurrentHand $ next n) >> turnGeneric playFunc depth
         1 -> do
@@ -72,7 +64,7 @@ turn = turnGeneric play 10
 
 evaluateTable :: Skat Hand
 evaluateTable = do
-    trumpCol <- gets trumpColour
+    trumpCol <- trump
     turnCol <- gets turnColour
     table <- getp tableCards
     ps <- gets players
@@ -89,7 +81,7 @@ play :: (Show p, Player p) => p -> Skat Card
 play p = do
     table <- getp tableCards
     turnCol <- gets turnColour
-    trump <- gets trumpColour
+    trump <- trump
     cards <- getp $ handCards (hand p)
     fallen <- getp played
     (card, p') <- chooseCard p table fallen cards
@@ -107,14 +99,3 @@ playOpen p = do
     card <- chooseCardOpen p
     modifyp $ playCard (hand p) card
     return card
-
-publishGameResults :: (Int, Int) -> Skat ()
-publishGameResults res = do
-    pls <- gets players
-    mapM_ (\p -> onGameResults p res) (playersToList pls)
-
-publishGameStart :: Skat ()
-publishGameStart = do
-    pls <- gets players
-    let sglPlayer = getSinglePlayer pls
-    mapM_ (\p -> onGameStart p sglPlayer) (playersToList pls)

src/Skat/Pile.hs

@@ -153,12 +153,12 @@ handCards Hand1 = _hand1
 handCards Hand2 = _hand2
 handCards Hand3 = _hand3
 
-allowed :: Hand -> Colour -> Maybe Colour -> Piles -> [CardS Owner]
-allowed hand trCol turnCol ps
+allowed :: Hand -> Trump -> Maybe TurnColour -> Piles -> [CardS Owner]
+allowed hand trump turnCol ps
         | null sameColour = cards
         | otherwise = sameColour
     where cards = handCards hand ps
-          sameColour = filter (\ca -> effectiveColour trCol ca `equals` turnCol) cards
+          sameColour = filter (\ca -> effectiveColour trump ca `equals` turnCol) cards
 
 skatCards :: Piles -> [Card]
 skatCards = map getCard . _skat

src/Skat/Player.hs

@@ -8,8 +8,8 @@ import Skat.Card
 import Skat.Pile
 
 class (Monad m, MonadIO m) => MonadPlayer m where
-    trumpColour :: m Colour
-    turnColour :: m (Maybe Colour)
+    trump :: m Trump
+    turnColour :: m (Maybe TurnColour)
     showSkat :: Player p => p -> m (Maybe [Card])
 
 class (Monad m, MonadIO m, MonadPlayer m) => MonadPlayerOpen m where
@@ -38,16 +38,6 @@ class Player p where
             fallen = played piles
             myCards = handCards (hand p) piles
         fst <$> chooseCard p table fallen myCards
-    onGameResults :: MonadIO m
-                  => p
-                  -> (Int, Int)
-                  -> m ()
-    onGameResults _ _ = return ()
-    onGameStart :: MonadPlayer m
-                => p
-                -> Hand
-                -> m ()
-    onGameStart _ _ = return ()
 
 data PL = forall p. (Show p, Player p) => PL p
 
@@ -64,8 +54,6 @@ instance Player PL where
         v <- onCardPlayed p card
         return $ PL v
     chooseCardOpen (PL p) = chooseCardOpen p
-    onGameResults (PL p) res = onGameResults p res
-    onGameStart (PL p) singlePlayer = onGameStart p singlePlayer
 
 data Players = Players PL PL PL
                deriving Show

src/Skat/Player/Utils.hs

@@ -8,11 +8,11 @@ import Skat.Card (Card, HasCard(..))
 
 isAllowed :: (HasCard c, MonadPlayer m) => [c] -> c -> m Bool
 isAllowed hand card = do
-    trCol <- trumpColour
+    tr <- trump
     turnCol <- turnColour
-    return $ C.isAllowed trCol turnCol hand card
+    return $ C.isAllowed tr turnCol hand card
 
 isTrump :: MonadPlayer m => Card -> m Bool
 isTrump card = do
-    trCol <- trumpColour
-    return $ C.isTrump trCol card
+    tr <- trump
+    return $ C.isTrump tr card

src/Skat/Preperation.hs

@@ -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