add preconfigured matches and extend online ai

Operations.hs

@@ -1,88 +0,0 @@
-module Operations where
-
-import Control.Monad.State
-import System.Random (newStdGen, randoms)
-import Data.List
-import Data.Ord
-
-import Card
-import Skat
-import Pile
-import Player (chooseCard, Players(..), Player(..), PL(..),
-    updatePlayer, playersToList, player)
-import 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
-
-turnGeneric :: (PL -> Skat Card)
-            -> Int
-            -> Hand
-            -> Skat (Int, Int)
-turnGeneric playFunc depth n = do
-    table <- getp tableCards
-    ps <- gets players
-    let p = player ps n
-    hand <- getp $ handCards n
-    trCol <- gets trumpColour
-    case length table of
-        0 -> playFunc p >> turnGeneric playFunc depth (next n)
-        1 -> do
-            modify $ setTurnColour
-                (Just $ effectiveColour trCol $ head table)
-            playFunc p
-            turnGeneric playFunc depth (next n)
-        2 -> playFunc p >> turnGeneric playFunc depth (next n)
-        3 -> do
-            w <- evaluateTable
-            if depth <= 1 || length hand == 0
-                then countGame
-                else turnGeneric playFunc (depth - 1) w
-
-turn :: Hand -> Skat (Int, Int)
-turn n = turnGeneric play 10 n
-
-evaluateTable :: Skat Hand
-evaluateTable = do
-    trumpCol <- gets trumpColour
-    turnCol <- gets turnColour
-    table <- getp tableCards
-    ps <- gets players
-    let winningCard = highestCard trumpCol turnCol table
-    Just winnerHand <- getp $ originOfCard winningCard
-    let winner = player ps winnerHand
-    modifyp $ cleanTable (team winner)
-    modify $ setTurnColour Nothing
-    return $ hand winner
-
-countGame :: Skat (Int, Int)
-countGame = getp count
-
-play :: (Show p, Player p) => p -> Skat Card
-play p = do
-    liftIO $ putStrLn "playing"
-    table <- getp tableCardsS
-    turnCol <- gets turnColour
-    trump <- gets trumpColour
-    hand <- getp $ handCards (hand p)
-    fallen <- getp played
-    (card, p') <- chooseCard p table fallen hand
-    modifyPlayers $ updatePlayer p'
-    modifyp $ playCard card
-    ps <- fmap playersToList $ gets players
-    table' <- getp tableCardsS
-    ps' <- mapM (\p -> onCardPlayed p (head table')) ps
-    mapM_ (modifyPlayers . updatePlayer) ps'
-    return card
-
-playOpen :: (Show p, Player p) => p -> Skat Card
-playOpen p = do
-    --liftIO $ putStrLn $ show (hand p) ++ " playing open"
-    card <- chooseCardOpen p
-    modifyp $ playCard card
-    return card

app/Main.hs

@@ -35,7 +35,8 @@ runAI = do
     if length trs >= 5 && any ((==32) . getID) cs
         then do
             pts <- fst <$> evalStateT (turn Hand1) env
-            if pts > 60 then return 1 else return 0
+            -- if pts > 60 then return 1 else return 0
+            return pts
         else runAI
 
 env :: SkatEnv

skat.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: fd93323d8ea488caa20459179e7d1d829224ee7976b53721e476514efba64baa
+-- hash: 0d6eafec0c3ba6bb4c0150a39f4dbab784c7a519ec911d0f0344edd1c5d916da
 
 name:           skat
 version:        0.1.0.1
@@ -34,6 +34,7 @@ library
       Skat.AI.Server
       Skat.AI.Stupid
       Skat.Card
+      Skat.Matches
       Skat.Operations
       Skat.Pile
       Skat.Player

src/Skat/AI/Online.hs

@@ -33,6 +33,7 @@ instance Player OnlineEnv where
     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 (onStart singlePlayer) p
 
 type Online m = ReaderT OnlineEnv m
 
@@ -65,23 +66,30 @@ cardPlayed card = query (BS.unpack $ encode $ CardPlayedQuery card)
 onResults :: MonadIO m => (Int, Int) -> Online m ()
 onResults (sgl, tm) = query (BS.unpack $ encode $ GameResultsQuery sgl tm)
 
-data ChooseQuery = ChooseQuery [Card] [CardS Played]
+onStart :: MonadPlayer m => Hand -> Online m ()
-data CardPlayedQuery = CardPlayedQuery (CardS Played)
+onStart singlePlayer = do
-data GameResultsQuery = GameResultsQuery Int Int
+    trCol <- trumpColour
-data ChosenResponse = ChosenResponse Card
+    ownHand <- asks getHand
+    query (BS.unpack $ encode $ GameStartQuery trCol ownHand singlePlayer)
     
-instance ToJSON ChooseQuery where
+data Query = ChooseQuery [Card] [CardS Played]
+           | CardPlayedQuery (CardS Played)
+           | GameResultsQuery Int Int
+           | GameStartQuery Colour Hand Hand
+
+data Response = ChosenResponse Card
+     
+instance ToJSON Query where
     toJSON (ChooseQuery hand table) =
         object ["query" .= ("choose_card" :: String), "hand" .= hand, "table" .= table]
-
-instance ToJSON CardPlayedQuery where
     toJSON (CardPlayedQuery card) =
         object ["query" .= ("card_played" :: String), "card" .= card]
-
-instance ToJSON GameResultsQuery where
     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]
 
-instance FromJSON ChosenResponse where
+instance FromJSON Response where
     parseJSON = withObject "ChosenResponse" $ \v -> ChosenResponse
         <$> v .: "card"

src/Skat/Matches.hs

@@ -0,0 +1,25 @@
+module Skat.Matches (
+    singleVsBots
+) where
+
+import Control.Monad.State
+
+import Skat
+import Skat.Operations
+import Skat.Player
+import Skat.Pile
+import Skat.Card
+
+import Skat.AI.Rulebased
+import Skat.AI.Online
+import Skat.AI.Stupid
+
+singleVsBots :: (Team -> Hand -> OnlineEnv) -> IO ()
+singleVsBots mkPlayer = do
+    cards <- liftIO $ shuffleCards
+    let ps = Players
+                (PL $ mkPlayer Team Hand1)
+                (PL $ Stupid Team Hand2)
+                (PL $ mkAIEnv Single Hand3 10)
+        env = SkatEnv (distribute cards) Nothing Spades ps
+    liftIO $ evalStateT (turn Hand1 >>= publishGameResults) env

src/Skat/Operations.hs

@@ -1,4 +1,6 @@
-module Skat.Operations where
+module Skat.Operations (
+    turn, turnGeneric, play, playOpen, publishGameResults
+) where
 
 import Control.Monad.State
 import System.Random (newStdGen, randoms)
@@ -86,3 +88,8 @@ playOpen p = do
     card <- chooseCardOpen p
     modifyp $ playCard card
     return card
+
+publishGameResults :: (Int, Int) -> Skat ()
+publishGameResults res = do
+    pls <- gets players
+    mapM_ (\p -> onGameResults p res) (playersToList pls)

src/Skat/Pile.hs

@@ -28,6 +28,11 @@ instance ToJSON p => ToJSON (CardS p) where
 data Hand = Hand1 | Hand2 | Hand3
             deriving (Show, Eq, Ord)
 
+toInt :: Hand -> Int
+toInt Hand1 = 1
+toInt Hand2 = 2
+toInt Hand3 = 3
+
 next :: Hand -> Hand
 next Hand1 = Hand2
 next Hand2 = Hand3

src/Skat/Player.hs

@@ -43,6 +43,11 @@ class Player p where
                   -> (Int, Int)
                   -> m ()
     onGameResults _ _ = return ()
+    onGameStart :: MonadPlayer m
+                => p
+                -> Hand
+                -> m ()
+    onGameStart _ _ = return ()
 
 data PL = forall p. (Show p, Player p) => PL p
 
@@ -60,6 +65,7 @@ instance Player PL where
         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