use minmax for rulebased ai

.gitignore

@@ -2,6 +2,7 @@
 
 !*.*
 !*/
+!LICENSE
 
 *.hi
 *.o

LICENSE

@@ -0,0 +1,30 @@
+Copyright Author name here (c) 2019
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Author name here nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

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

README.md

@@ -1 +1,4 @@
-# skat
+# Skat
+
+This is a Haskell implementation of the famous german card game Skat. It provides
+a library implementing all the game mechanics and a simple AI.

app/Main.hs

@@ -16,6 +16,7 @@ import Skat.Pile
 import Skat.AI.Stupid
 import Skat.AI.Online
 import Skat.AI.Rulebased
+import Skat.AI.Minmax (playCLI)
 
 main :: IO ()
 main = testAI 10
@@ -34,16 +35,17 @@ runAI = do
         trs = filter (isTrump Spades) cs
     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
+            pts <- fst <$> evalStateT turn env
+            -- if pts > 60 then return 1 else return 0
+            return pts
         else runAI
 
 env :: SkatEnv
-env = SkatEnv piles Nothing Spades playersExamp
+env = SkatEnv piles Nothing Spades playersExamp Hand1
     where piles = distribute allCards 
 
 envStupid :: SkatEnv
-envStupid = SkatEnv piles Nothing Spades pls2
+envStupid = SkatEnv piles Nothing Spades pls2 Hand1
     where piles = distribute allCards 
 
 playersExamp :: Players
@@ -56,15 +58,20 @@ pls2 :: Players
 pls2 = Players
     (PL $ Stupid Team Hand1)
     (PL $ Stupid Team Hand2)
-    (PL $ Stupid Team Hand3)
+    (PL $ Stupid Single Hand3)
 
 shuffledEnv :: IO SkatEnv
 shuffledEnv = do
     cards <- shuffleCards
-    return $ SkatEnv (distribute cards) Nothing Spades playersExamp
+    return $ SkatEnv (distribute cards) Nothing Spades playersExamp Hand1
+
+shuffledEnv2 :: IO SkatEnv
+shuffledEnv2 = do
+    cards <- shuffleCards
+    return $ SkatEnv (distribute cards) Nothing Spades pls2 Hand1
 
 env2 :: SkatEnv
-env2 = SkatEnv piles Nothing Spades playersExamp
+env2 = SkatEnv piles Nothing Spades playersExamp Hand1
     where hand1 = [Card Seven Clubs, Card King Clubs, Card Ace Clubs, Card Queen Diamonds]
           hand2 = [Card Seven Hearts, Card King Hearts, Card Ace Hearts, Card Queen Spades]
           hand3 = [Card Seven Spades, Card King Spades, Card Ace Spades, Card Queen Clubs]
@@ -73,6 +80,23 @@ env2 = SkatEnv piles Nothing Spades playersExamp
           h3 = map (putAt Hand3) hand3
           piles = Piles (h1 ++ h2 ++ h3) [] []
 
+env3 :: SkatEnv
+env3 = SkatEnv piles Nothing Diamonds 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 ]
+          hand2 = [ Card Seven Spades, Card Eight Spades, Card Seven Hearts, Card Nine Hearts
+                  , Card Ace Hearts, Card King Diamonds, Card Ace Diamonds, Card Nine Clubs
+                  , Card King Clubs, Card Ace Clubs ]
+          hand3 = [ Card Jack Hearts, Card Jack Spades, Card Ten Spades, Card Ace Spades, Card Eight Diamonds
+                  , Card Queen Diamonds, Card Ten Diamonds, Card Ten Hearts, Card Queen Hearts, Card King Hearts ]
+          skat = [ Card Queen Clubs, Card Queen Spades]
+          h1 = map (putAt Hand1) hand1
+          h2 = map (putAt Hand2) hand2
+          h3 = map (putAt Hand3) hand3
+          skt = map (putAt SkatP) skat
+          piles = Piles (h1 ++ h2 ++ h3) [] skt
+
 runWebSocketServer :: IO ()
 runWebSocketServer = do
     WS.runServer "localhost" 4243 application
@@ -84,3 +108,7 @@ application pending = do
     forever $ do
         msg <- WS.receiveData conn
         putStrLn $ BS.unpack msg
+
+playSkat :: IO ()
+playSkat = do
+    void $ (flip runStateT) env3 playCLI

package.yaml

@@ -1,10 +1,10 @@
 name:                skat
-version:             0.1.0.0
+version:             0.1.0.1
 github:              "githubuser/skat"
 license:             BSD3
-author:              "Author name here"
-maintainer:          "example@example.com"
-copyright:           "2019 Author name here"
+author:              "flavis"
+maintainer:          "christian@flavigny.de"
+copyright:           "2019"
 
 extra-source-files:
 - README.md
@@ -17,7 +17,7 @@ extra-source-files:
 # To avoid duplicated efforts in documentation and dealing with the
 # complications of embedding Haddock markup inside cabal files, it is
 # common to point users to the README.md file.
-description:         Please see the README on GitHub at <https://github.com/githubuser/skat#readme>
+description:         Please see the README on Gitea at <https://git.flavigny.de/christian/skat>
 
 dependencies:
 - base >= 4.7 && < 5

skat.cabal

@@ -4,16 +4,16 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: e2db48733c92b94d7f2d8f4991dd2f7cec26d59666cd3c618710a8a3c22616d0
+-- hash: 589f4321e3ce9847f3a53afb14e0fa9eaa1b98b3fc7386eac20f8fae7f7b6bf7
 
 name:           skat
-version:        0.1.0.0
-description:    Please see the README on GitHub at <https://github.com/githubuser/skat#readme>
+version:        0.1.0.1
+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
-author:         Author name here
-maintainer:     example@example.com
-copyright:      2019 Author name here
+author:         flavis
+maintainer:     christian@flavigny.de
+copyright:      2019
 license:        BSD3
 license-file:   LICENSE
 build-type:     Simple
@@ -29,11 +29,13 @@ library
   exposed-modules:
       Skat
       Skat.AI.Human
+      Skat.AI.Minmax
       Skat.AI.Online
       Skat.AI.Rulebased
       Skat.AI.Server
       Skat.AI.Stupid
       Skat.Card
+      Skat.Matches
       Skat.Operations
       Skat.Pile
       Skat.Player

src/Skat.hs

@@ -16,7 +16,8 @@ import qualified Skat.Player as P
 data SkatEnv = SkatEnv { piles :: Piles
                        , turnColour :: Maybe Colour
                        , trumpColour :: Colour
-                       , players :: Players }
+                       , players :: Players
+                       , currentHand :: Hand }
                deriving Show
 
 type Skat = StateT SkatEnv IO
@@ -45,5 +46,19 @@ modifyPlayers f = modify g
 setTurnColour :: Maybe Colour -> SkatEnv -> SkatEnv
 setTurnColour col sk = sk { turnColour = col }
 
-mkSkatEnv :: Piles -> Maybe Colour -> Colour -> Players -> SkatEnv
+setCurrentHand :: Hand -> SkatEnv -> SkatEnv
+setCurrentHand hand sk = sk { currentHand = hand }
+
+mkSkatEnv :: Piles -> Maybe Colour -> Colour -> Players -> Hand -> SkatEnv
 mkSkatEnv = SkatEnv
+
+allowedCards :: Skat [Card]
+allowedCards = do
+    curHand <- gets currentHand
+    pls <- gets players
+    turnCol <- gets turnColour
+    trumpCol <- gets trumpColour
+    ps <- gets piles
+    let p = P.player pls curHand
+        cards = handCards curHand ps
+    return $ filter (isAllowed trumpCol turnCol cards) cards

src/Skat/AI/Minmax.hs

@@ -0,0 +1,299 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE TupleSections #-}
+
+module Skat.AI.Minmax (
+    choose, playCLI
+) where
+
+import Control.Monad.State
+import Control.Monad.Fail
+import Data.Ord
+import Text.Read (readMaybe)
+import Data.List (minimumBy, maximumBy)
+import Debug.Trace
+
+import qualified Skat as S
+import qualified Skat.Card as S
+import qualified Skat.Operations as S
+import qualified Skat.Pile as S
+import qualified Skat.Player as S
+import qualified Skat.Render as S
+
+debug :: Bool
+debug = False
+
+class (Ord v, Eq v) => Value v where
+    invert :: v -> v
+    win :: v
+    loss :: v
+
+class Player p where
+    maxing :: p -> Bool
+
+class (Monad m, Value v, Player p, Eq t) => MonadGame t v p m | m -> t, m -> p, m -> v where
+    currentPlayer :: m p
+    turns :: m [t]
+    play :: t -> m ()
+    simulate :: t -> m a -> m a
+    evaluate :: m v
+    over :: m Bool
+
+class (MonadIO m, Show t, Show v, Show p, MonadGame t v p m) => PlayableGame t v p m | m -> t, m -> p, m -> v where
+    showTurns :: m ()
+    showBoard :: m ()
+    askTurn :: m (Maybe t)
+    showTurn :: t -> m ()
+    winner :: m (Maybe p)
+
+-- Skat implementation
+
+instance Player S.PL where
+    maxing p = S.team p == S.Team
+
+instance Value Int where
+    invert = negate
+    win = 120
+    loss = -120
+
+instance MonadGame S.Card Int S.PL S.Skat where
+    currentPlayer = do
+        hand <- gets S.currentHand
+        pls <- gets S.players
+        return $ S.player pls hand
+    turns = S.allowedCards
+    play = S.play_
+    simulate card action = do
+        backup <- get
+        play card
+        res <- action
+        put backup
+        return res
+    over = ((==0) . length) <$> S.allowedCards
+    evaluate = do
+        player <- currentPlayer
+        piles <- gets S.piles
+        let (sgl, tm) = S.count piles
+        return $ (if maxing player then tm - sgl else sgl - tm)
+
+-- TIC TAC TOE implementation
+
+data TicTacToe = Tic | Tac | Toe
+                 deriving (Eq, Ord)
+
+instance Show TicTacToe where
+    show Tic = "O"
+    show Tac = "X"
+    show Toe = "_"
+
+data WinLossTie = Loss | Tie | Win
+                  deriving (Eq, Show, Ord)
+
+instance Value WinLossTie where
+    invert Win = Loss
+    invert Loss = Win
+    invert Tie = Tie
+    win = Win
+    loss = Loss
+
+data GameState = GameState { getBoard :: [TicTacToe]
+                           , getCurrent :: Bool }
+             deriving Show
+
+instance Player Bool where
+    maxing = id
+
+instance Monad m => MonadGame Int WinLossTie Bool (StateT GameState m) where
+    currentPlayer = gets getCurrent
+    turns = do
+        board <- gets getBoard
+        let fields = zip [0..] board
+        return $ map fst $ filter ((==Toe) . snd) fields
+    play turn = do
+        env <- get
+        let value = if getCurrent env then Tic else Tac
+            board' = updateAt turn (getBoard env) value
+            current' = not $ getCurrent env
+        put $ GameState board' current'
+    simulate turn action = do
+        backup <- get
+        play turn
+        res <- action
+        put backup
+        return res
+    evaluate = do
+        board <- gets getBoard
+        current <- currentPlayer
+        let mayWinner = ticWinner board
+        case mayWinner of
+            Just Tic -> return $ if current then Win else Loss
+            Just Tac -> return $ if current then Loss else Win
+            Just Toe -> return Tie
+            Nothing -> return Tie
+    over = do
+        board <- gets getBoard
+        case ticWinner board of
+            Just _ -> return True
+            _      -> return False
+
+ticWinner :: [TicTacToe] -> Maybe TicTacToe
+ticWinner board
+    | ticWon    = Just Tic
+    | tacWon    = Just Tac
+    | over      = Just Toe
+    | otherwise = Nothing
+  where ticWon = hasWon $ map (==Tic) board
+        tacWon = hasWon $ map (==Tac) board
+        hasWon (True:_:_:True:_:_:True:_:_:[]) = True
+        hasWon (True:_:_:_:True:_:_:_:True:[]) = True
+        hasWon (_:True:_:_:True:_:_:True:_:[]) = True
+        hasWon (_:_:True:_:_:True:_:_:True:[]) = True
+        hasWon (_:_:True:_:True:_:True:_:_:[]) = True
+        hasWon (True:True:True:_:_:_:_:_:_:[]) = True
+        hasWon (_:_:_:True:True:True:_:_:_:[]) = True
+        hasWon (_:_:_:_:_:_:True:True:True:[]) = True
+        hasWon _                               = False
+        over = (length $ filter (==Toe) board) == 0
+
+updateAt :: Int -> [a] -> a -> [a]
+updateAt n xs y = map f $ zip [0..] xs
+    where f (i, x) = if i == n then y else x
+
+minmax :: (MonadIO m, Show v, Show t, Show p, Value v, Eq t, Player p, MonadGame t v p m)
+       => Int
+       -> t
+       -> v
+       -> v
+       -> m (t, v)
+minmax depth turn alpha beta = (flip evalStateT) (alpha, beta) $ do
+    gameOver <- lift over
+    -- if last step or game is over then evaluate situation
+    if depth == 0 || gameOver then do
+        val <- lift evaluate
+        when debug $ liftIO $ putStrLn $ "evaluation: " ++ show val
+        return (turn, val)
+    else do
+        when debug $ liftIO $ putStrLn $ "depth " ++ show depth
+        -- generate a list of possible turns
+        currentlyMaxing <- maxing <$> lift currentPlayer
+        availableTurns <- lift turns
+        (alpha, beta) <- get
+        -- try every turn, StateT wraps current best turn and current max value
+        (flip execStateT) (undefined, alpha) $ forM_ availableTurns $ \turn -> do
+            currentMax <- gets snd
+            when debug $ liftIO $ putStrLn $ "simulating " ++ show turn ++ " with max " ++ show currentMax
+                ++ " and beta " ++ show beta
+            --when (currentMax >= beta && debug) $ liftIO $ putStrLn "beta cutoff"
+            -- beta cutoff
+            unless (currentMax >= beta) $ do
+            --unless False $ do
+                value <- lift $ lift $ simulate turn $ step currentlyMaxing beta currentMax
+                when debug $ liftIO $ putStrLn $ "value " ++ show value
+                when (value > currentMax) (put (turn, value))
+  where step currentlyMaxing beta currentMax = do
+            nextMaxing <- maxing <$> currentPlayer
+            if nextMaxing /= currentlyMaxing
+                then (invert . snd) <$> minmax (depth-1) turn (invert beta) (invert currentMax)
+                else snd <$> minmax (depth-1) turn currentMax beta
+
+choose :: (MonadIO m, Show v, Show t, Show p, Value v, Eq t, Player p, MonadGame t v p m) => m t
+choose = fst <$> minmax 10 undefined loss win
+
+emptyBoard :: [TicTacToe]
+emptyBoard = [Toe, Toe, Toe, Toe, Toe, Toe, Toe, Toe, Toe]
+
+otherBoard :: [TicTacToe]
+otherBoard = [Tic, Tac, Tac, Tic, Tac, Tic, Toe, Tic, Toe]
+
+print9x9 :: (Int -> IO ()) -> IO ()
+print9x9 pr = pr 0 >> pr 1 >> pr 2 >> putStrLn ""
+    >> pr 3 >> pr 4 >> pr 5 >> putStrLn ""
+    >> pr 6 >> pr 7 >> pr 8 >> putStrLn ""
+
+printBoard :: [TicTacToe] -> IO ()
+printBoard board = print9x9 pr >> putStrLn ""
+    where pr n = putStr (show $ board !! n) >> putStr " "
+
+printOptions :: [Int] -> IO ()
+printOptions opts = print9x9 pr
+    where pr n
+            | n `elem` opts = putStr (show n) >> putStr " "
+            | otherwise     = putStr "  "
+
+instance MonadIO m => PlayableGame Int WinLossTie Bool (StateT GameState m) where
+    showBoard = do
+        board <- gets getBoard
+        liftIO $ printBoard board
+    showTurns = turns >>= liftIO . printOptions
+    winner = do
+        board <- gets getBoard
+        let win = ticWinner board
+        case win of
+            Just Toe -> return Nothing
+            Just Tic -> return $ Just True
+            Just Tac -> return $ Just False
+            Nothing -> return Nothing
+    askTurn = readMaybe <$> liftIO getLine
+    showTurn _ = return ()
+
+instance PlayableGame S.Card Int S.PL S.Skat where
+    showBoard = do
+        liftIO $ putStrLn ""
+        table <- S.getp S.tableCards
+        liftIO $ putStr "Table: "
+        liftIO $ print table
+    showTurns = do
+        cards <- turns
+        player <- currentPlayer
+        liftIO $ print player
+        liftIO $ S.render (S.sortRender cards)
+    winner = do
+        piles <- gets S.piles
+        pls <- gets S.players
+        let res = S.count piles :: (Int, Int)
+            winnerTeam = trace (show res) $ if fst res > snd res then S.Single else S.Team
+            winners = filter ((==winnerTeam) . S.team) (S.playersToList pls)
+        return $ Just $ head winners
+    askTurn = do
+        cards <- turns
+        let sorted = S.sortRender cards
+        input <- liftIO getLine
+        case readMaybe input of
+            Just n -> if n >= 0 && n < length sorted then return $ Just (sorted !! n)
+                else return Nothing
+            Nothing -> return Nothing
+    showTurn card = do
+        player <- currentPlayer
+        liftIO $ putStrLn $ show player ++ " plays " ++ show card
+
+playCLI :: (MonadFail m, Read t, PlayableGame t v p m) => m ()
+playCLI = do
+    gameOver <- over
+    if gameOver
+        then announceWinner
+        else do
+            showBoard
+            current <- currentPlayer
+            turn <- if not (maxing current) then readTurn else choose
+            showTurn turn
+            play turn
+            playCLI
+   where
+      readTurn = do
+        options <- turns
+        showTurns
+        liftIO $ putStr "> "
+        mayTurn <- askTurn
+        case mayTurn of
+            Just val -> if val `elem` options then return val else readTurn
+            Nothing -> readTurn
+      announceWinner = do
+        showBoard
+        win <- winner
+        liftIO $ putStrLn $ show win ++ " wins the game!"
+
+playTicTacToe :: IO ()
+playTicTacToe = void $ (flip runStateT) (GameState emptyBoard True) playCLI

src/Skat/AI/Online.hs

@@ -5,7 +5,6 @@
 module Skat.AI.Online where
 
 import Control.Monad.Reader
-import Network.WebSockets (Connection, sendTextData, receiveData)
 import Data.Aeson
 import qualified Data.ByteString.Lazy.Char8 as BS
 
@@ -15,41 +14,45 @@ import Skat.Pile
 import Skat.Card
 import Skat.Render
 
+class Communicator a where
+    send :: a -> String -> IO ()
+    receive :: a -> IO String
+
 class Monad m => MonadClient m where
     query :: String -> m ()
     response :: m String
 
-data OnlineEnv = OnlineEnv { getTeam :: Team
-                           , getHand :: Hand
-                           , connection :: Connection }
-                 deriving Show
+data OnlineEnv c = OnlineEnv { getTeam :: Team
+                             , getHand :: Hand
+                             , connection :: c }
 
-instance Show Connection where
-    show _ = "A connection"
+instance Show (OnlineEnv c) where
+    show _ = "An online env"
 
-instance Player OnlineEnv 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)
     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
+type Online a m = ReaderT (OnlineEnv a) m
 
-instance MonadIO m => MonadClient (Online m) where
+instance (Communicator c, MonadIO m) => MonadClient (Online c m) where
     query s = do
         conn <- asks connection
-        liftIO $ sendTextData conn (BS.pack s)
+        liftIO $ send conn s
     response = do
         conn <- asks connection
-        liftIO $ BS.unpack <$> receiveData conn
+        liftIO $ receive conn
 
-instance MonadPlayer m => MonadPlayer (Online m) where
+instance MonadPlayer m => MonadPlayer (Online a m) where
     trumpColour = lift $ trumpColour
     turnColour = lift $ turnColour
     showSkat = lift . showSkat
 
-choose :: MonadPlayer m => [CardS Played] -> [Card] -> Online m Card
+choose :: (Communicator c, MonadPlayer m) => [CardS Played] -> [Card] -> Online c m Card
 choose table hand = do
     query (BS.unpack $ encode $ ChooseQuery hand table)
     r <- response
@@ -59,29 +62,36 @@ choose table hand = do
             if card `elem` hand && allowed then return card else choose table hand
         Nothing -> choose table hand
 
-cardPlayed :: MonadPlayer m => CardS Played -> Online m ()
+cardPlayed :: (Communicator c, MonadPlayer m) => CardS Played -> Online c m ()
 cardPlayed card = query (BS.unpack $ encode $ CardPlayedQuery card)
 
-onResults :: MonadIO m => (Int, Int) -> Online m ()
+onResults :: (Communicator c, MonadIO m) => (Int, Int) -> Online c m ()
 onResults (sgl, tm) = query (BS.unpack $ encode $ GameResultsQuery sgl tm)
 
-data ChooseQuery = ChooseQuery [Card] [CardS Played]
-data CardPlayedQuery = CardPlayedQuery (CardS Played)
-data GameResultsQuery = GameResultsQuery Int Int
-data ChosenResponse = ChosenResponse Card
+onStart :: (Communicator c, MonadPlayer m) => Hand -> Online c m ()
+onStart singlePlayer = do
+    trCol <- trumpColour
+    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/AI/Rulebased.hs

@@ -24,6 +24,8 @@ import Skat.Card
 import Skat.Utils
 import Skat (Skat, modifyp, mkSkatEnv) 
 import Skat.Operations
+import qualified Skat.AI.Minmax as Minmax
+import qualified Skat.AI.Stupid as Stupid (Stupid(..))
 
 data AIEnv = AIEnv { getTeam :: Team
                    , getHand :: Hand
@@ -229,34 +231,12 @@ onPlayed c = do
         Nothing -> return ()
 
 choose :: MonadPlayer m => AI m Card
-choose = do
-    handCards <- gets myHand
-    table <- gets table
-    case length table of
-        0 -> if length handCards >= 7
-            then chooseLead
-            else chooseStatistic
-        n -> chooseStatistic
+choose = chooseStatistic
 
 chooseStatistic :: MonadPlayer m => AI m Card
 chooseStatistic = do
     h <- gets getHand
     handCards <- gets myHand
-    let depth = case length handCards of
-                    0 -> 0
-                    1 -> 1
-                    -- simulate whole game
-                    2 -> 2
-                    3 -> 3
-                    -- simulate only partially
-                    4 -> 3
-                    5 -> 2
-                    6 -> 2
-                    7 -> 1
-                    8 -> 1
-                    9 -> 1
-                    10 -> 1
-    modify $ setDepth depth
     guess__ <- gets guess
     self <- get
     maySkat <- showSkat self
@@ -274,9 +254,8 @@ chooseStatistic = do
         reducedDis = simplify Hand3 realDis
         reducedDisNo = length reducedDis
         piless = map (\(d, n) -> (toPiles table d, n)) reducedDis
-        limit = if depth == 1 && length table == 2
-            then 1
-            else min 10000 $ realDisNo `div` 2
+        limit = min 10000 $ realDisNo `div` 2
+    liftIO $ putStrLn $ "players hand" ++ show handCards
     liftIO $ putStrLn $ "possible distrs without simp " ++ show realDisNo
     liftIO $ putStrLn $ "possible distrs " ++ show reducedDisNo
     vals <- M.toList <$> foldWithLimit limit runOnPiles M.empty piless
@@ -307,29 +286,28 @@ chooseOpen = do
     piles <- showPiles
     hand <- gets getHand
     let myCards = handCards hand piles
+    liftIO $ putStrLn $ show hand ++ " chooses from " ++ show myCards
     possible <- filterM (P.isAllowed myCards) myCards
-    case length myCards of
+    case length possible of
         0 -> do
             liftIO $ print hand
             liftIO $ print piles
             error "no cards left to choose from"
-        1 -> return $ head myCards
+        1 -> return $ head possible
         _ -> chooseSimulating
 
 chooseSimulating :: (MonadState AIEnv m, MonadPlayerOpen m)
                  => m Card
 chooseSimulating = do
     piles <- showPiles
-    hand <- gets getHand
-    let myCards = handCards hand piles
-    possible <- filterM (P.isAllowed myCards) myCards
-    case possible of
-        [card] -> return card
-        cs -> do
-            results <- mapM simulate cs
-            let both = zip results cs
-                best = maximumBy (comparing fst) both
-            return $ snd best
+    turnCol <- turnColour
+    trumpCol <- trumpColour
+    myHand <- gets getHand
+    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
+    liftIO $ evalStateT (Minmax.choose :: Skat Card) env
 
 simulate :: (MonadState AIEnv m, MonadPlayerOpen m)
          => Card -> m Int
@@ -341,17 +319,18 @@ simulate card = do
     myTeam <- gets getTeam
     myHand <- gets getHand
     depth <- gets simulationDepth
+    liftIO $ putStrLn $ "simulate: " ++ show myHand ++ " plays " ++ show card
     let newDepth = depth - 1
         -- create a virtual env with 3 ai players
         ps = Players
             (PL $ mkAIEnv Team Hand1 newDepth)
             (PL $ mkAIEnv Team Hand2 newDepth)
             (PL $ mkAIEnv Single Hand3 newDepth)
-        env = mkSkatEnv piles turnCol trumpCol ps
+        env = mkSkatEnv piles turnCol trumpCol ps (next myHand)
     -- simulate the game after playing the given card
     (sgl, tm) <- liftIO $ evalStateT (do
         modifyp $ playCard card
-        turnGeneric playOpen depth (next myHand)) env
+        turnGeneric playOpen depth) env
     let v = if myTeam == Single then (sgl, tm) else (tm, sgl)
     -- put the value into context for when not the whole game is
     -- simulated
@@ -364,7 +343,8 @@ predictValue (own, others) = do
     piles <- showPiles
     let cs = handCards hand piles
     pot <- potential cs
-    return $ own + pot
+    --return $ own + pot
+    return (own-others)
 
 potential :: (MonadState AIEnv m, MonadPlayerOpen m)
           => [Card] -> m Int
@@ -383,7 +363,7 @@ position card = do
     let effCol = effectiveColour tr card
         l = M.toList guess
         cs = filterMap ((==effCol) . effectiveColour tr . fst) fst l
-        csInd = zip [0..] cs
+        csInd = zip [0..] (reverse cs)
         Just (pos, _) = find ((== card) . snd) csInd
     return pos
 
@@ -401,8 +381,11 @@ chooseLead :: (MonadState AIEnv m, MonadPlayer m) => m Card
 chooseLead = do
     cards <- gets myHand
     possible <- filterM (P.isAllowed cards) cards
+    liftIO $ putStrLn $ "choosing lead from " ++ show possible
     pots <- mapM leadPotential possible
-    return $ snd $ maximumBy (comparing fst) (zip pots possible)
+    let ps = zip pots possible
+    liftIO $ putStrLn $ "lead potential of cards " ++ show ps
+    return $ snd $ maximumBy (comparing fst) ps
 
 mkAIEnv :: Team -> Hand -> Int -> AIEnv
 mkAIEnv tm h depth = AIEnv tm h [] [] [] newGuess depth

src/Skat/Card.hs

@@ -6,7 +6,7 @@ module Skat.Card where
 
 import Data.List
 import Data.Aeson
-import System.Random (newStdGen)
+import System.Random (newStdGen, StdGen)
 import Control.DeepSeq
 
 import Skat.Utils
@@ -39,7 +39,7 @@ data Colour = Diamonds
               deriving (Eq, Ord, Show, Enum, Read)
 
 data Card = Card Type Colour
-            deriving (Eq, Show, Ord)
+            deriving (Eq, Show, Ord, Read)
 
 instance ToJSON Card where
     toJSON (Card t c) =
@@ -123,6 +123,9 @@ shuffleCards = do
     gen <- newStdGen
     return $ shuffle gen allCards
 
+shuffleCardsWithGen :: StdGen -> [Card]
+shuffleCardsWithGen gen = shuffle gen allCards
+
 -- TESTING VARS
 
 c1 :: Card

src/Skat/Matches.hs

@@ -0,0 +1,44 @@
+module Skat.Matches (
+    singleVsBots
+) where
+
+import Control.Monad.State
+import System.Random (mkStdGen)
+
+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
+
+-- | predefined card distribution for testing purposes
+cardDistr :: Piles
+cardDistr = Piles hands [] (map (putAt SkatP) skt)
+    where hand3 = [Card Ace Spades, Card Jack Diamonds, Card Jack Clubs, Card King Spades,
+                   Card Nine Spades, Card Ace Diamonds, Card Queen Diamonds, Card Ten Clubs,
+                   Card Eight Clubs, Card King Clubs]
+          hand1 = [Card Jack Spades, Card Jack Hearts, Card Ten Spades, Card Ace Hearts, Card Ten Hearts,
+                   Card Nine Hearts, Card Seven Clubs, Card Ace Clubs, Card King Diamonds,
+                   Card Ten Diamonds]
+          hand2 = [Card Eight Spades, Card Queen Spades, Card Seven Spades, Card Seven Diamonds,
+                   Card Seven Hearts, Card Eight Hearts, Card Queen Hearts, Card King Hearts,
+                   Card Nine Diamonds, Card Eight Diamonds]
+          hands = map (putAt Hand1) hand1
+            ++ map (putAt Hand2) hand2
+            ++ map (putAt Hand3) hand3
+          skt = [Card Nine Clubs, Card Queen Clubs]
+
+singleVsBots :: Communicator c => c -> IO ()
+singleVsBots comm = do
+    --let gen = mkStdGen 123
+    --    cards = shuffleCardsWithGen gen
+    let ps = Players
+                (PL $ OnlineEnv Team Hand1 comm)
+                (PL $ Stupid Team Hand2)
+                (PL $ mkAIEnv Single Hand3 10)
+        env = SkatEnv cardDistr Nothing Spades ps Hand1
+    liftIO $ evalStateT (publishGameStart Hand3 >> turn >>= publishGameResults) env

src/Skat/Operations.hs

@@ -1,4 +1,7 @@
-module Skat.Operations where
+module Skat.Operations (
+    turn, turnGeneric, play, playOpen, publishGameResults,
+    publishGameStart, play_, sortRender
+) where
 
 import Control.Monad.State
 import System.Random (newStdGen, randoms)
@@ -20,32 +23,45 @@ compareRender (Card t1 c1) (Card t2 c2) = case compare c1 c2 of
 sortRender :: [Card] -> [Card]
 sortRender = sortBy compareRender
 
+play_ :: Card -> Skat ()
+play_ card = do
+    hand <- gets currentHand
+    trCol <- gets trumpColour
+    modifyp $ playCard card
+    table <- getp tableCards
+    case length table of
+        1 -> do modify (setCurrentHand $ next hand)
+                modify $ setTurnColour (Just $ effectiveColour trCol $ head table)
+        3 -> evaluateTable >>= modify . setCurrentHand
+        _ -> modify (setCurrentHand $ next hand)
+
 turnGeneric :: (PL -> Skat Card)
             -> Int
-            -> Hand
             -> Skat (Int, Int)
-turnGeneric playFunc depth n = do
+turnGeneric playFunc depth = do
+    n <- gets currentHand
     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)
+        0 -> playFunc p >> modify (setCurrentHand $ next n) >> turnGeneric playFunc depth
         1 -> do
             modify $ setTurnColour
                 (Just $ effectiveColour trCol $ head table)
             playFunc p
-            turnGeneric playFunc depth (next n)
-        2 -> playFunc p >> turnGeneric playFunc depth (next n)
+            modify (setCurrentHand $ next n)
+            turnGeneric playFunc depth
+        2 -> playFunc p >> modify (setCurrentHand $ next n) >> turnGeneric playFunc depth
         3 -> do
             w <- evaluateTable
             if depth <= 1 || length hand == 0
                 then countGame
-                else turnGeneric playFunc (depth - 1) w
+                else modify (setCurrentHand w) >> turnGeneric playFunc (depth - 1)
 
-turn :: Hand -> Skat (Int, Int)
-turn n = turnGeneric play 10 n
+turn :: Skat (Int, Int)
+turn = turnGeneric play 10
 
 evaluateTable :: Skat Hand
 evaluateTable = do
@@ -86,3 +102,13 @@ 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)
+
+publishGameStart :: Hand -> Skat ()
+publishGameStart sglPlayer = do
+    pls <- gets players
+    mapM_ (\p -> onGameStart p sglPlayer) (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