mcts progress

app/Main.hs

@@ -18,14 +18,18 @@ import Skat.AI.Stupid
 import Skat.AI.Online
 import Skat.AI.Rulebased
 import Skat.AI.Minmax (playCLI)
+import Skat.AI.Games.Skat.Guess
+import Skat.AI.Skat (playSkat)
 
 main :: IO ()
-main = testMinmax 10
+main = playSkat 42
 
+{-
 testMinmax :: Int -> IO ()
 testMinmax n = do
     let acs = repeat playSkat
     sequence_ (take n acs)
+-}
 
 testAI :: Int -> IO ()
 testAI n = do
@@ -47,11 +51,11 @@ runAI = do
         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 +73,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 ]
@@ -108,5 +112,7 @@ application pending = do
         msg <- WS.receiveData conn
         putStrLn $ BS.unpack msg
 
+{-
 playSkat :: IO ()
 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

@@ -1,13 +1,13 @@
 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.31.2.
+-- This file has been generated from package.yaml by hpack version 0.35.0.
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 9c412ae20820c69f342fb431118c3d2be6a5461e1b5a521d92c1546f163ee94a
+-- hash: 8a975ca39edf7adfa4bbf95bd068d1b2f4f3fa9e954eb61fa3cf553f03b7dd56
 
 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
@@ -28,12 +28,18 @@ source-repository head
 library
   exposed-modules:
       Skat
+      Skat.AI.Base
+      Skat.AI.Games.Skat.Guess
       Skat.AI.Human
+      Skat.AI.Markov
       Skat.AI.Minmax
+      Skat.AI.MonteCarlo
       Skat.AI.Online
       Skat.AI.Rulebased
       Skat.AI.Server
+      Skat.AI.Skat
       Skat.AI.Stupid
+      Skat.AI.TicTacToe
       Skat.Bidding
       Skat.Card
       Skat.Matches
@@ -56,12 +62,14 @@ library
     , case-insensitive
     , containers
     , deepseq
+    , exceptions
     , mtl
     , network
     , parallel
     , random
     , split
     , text
+    , transformers
     , vector
     , websockets
   default-language: Haskell2010
@@ -81,6 +89,7 @@ executable skat-exe
     , case-insensitive
     , containers
     , deepseq
+    , exceptions
     , mtl
     , network
     , parallel
@@ -88,6 +97,7 @@ executable skat-exe
     , skat
     , split
     , text
+    , transformers
     , vector
     , websockets
   default-language: Haskell2010
@@ -107,6 +117,7 @@ test-suite skat-test
     , case-insensitive
     , containers
     , deepseq
+    , exceptions
     , mtl
     , network
     , parallel
@@ -114,6 +125,7 @@ test-suite skat-test
     , skat
     , split
     , text
+    , transformers
     , vector
     , websockets
   default-language: Haskell2010

src/Skat.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE TypeSynonymInstances #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
 
 module Skat where
 
@@ -18,12 +19,12 @@ 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 Trick = (CardS Owner, CardS Owner, CardS Owner)
 type Skat = StateT SkatEnv (WriterT [Trick] IO)
 
 runSkat :: Skat a -> SkatEnv -> IO (a, SkatEnv, [Trick])
@@ -38,23 +39,25 @@ 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
 
-modifyp :: (Piles -> Piles) -> Skat ()
+modifyp :: MonadState SkatEnv m => (Piles -> Piles) -> m ()
 modifyp f = modify g
     where g env@(SkatEnv {piles}) = env { piles = f piles}
 
-getp :: (Piles -> a) -> Skat a
+getp :: MonadState SkatEnv m => (Piles -> a) -> m a
 getp f = gets piles >>= return . f
 
-modifyPlayers :: (Players -> Players) -> Skat ()
+modifyPlayers :: MonadState SkatEnv m => (Players -> Players) -> m ()
 modifyPlayers f = modify g
     where g env@(SkatEnv {players}) = env { players = f players }
 
@@ -64,10 +67,10 @@ 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]
+allowedCards :: (P.MonadPlayer m, MonadState SkatEnv m) => m [CardS Owner]
 allowedCards = do
     curHand <- gets currentHand
     pls <- gets players

src/Skat/AI/Base.hs

@@ -0,0 +1,79 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE TupleSections #-}
+
+module Skat.AI.Base where
+
+import Data.Set (Set)
+import qualified Data.Set as S
+import System.Random (Random)
+import qualified System.Random as Rand
+import Control.Monad.State
+import Control.Exception (assert)
+import Control.Monad.Fail
+import Data.Ord
+import Text.Read (readMaybe)
+import Data.List (maximumBy, sortBy)
+import Debug.Trace
+
+class (Ord v, Eq v) => Value v where
+    invert :: v -> v
+    win :: v
+    loss :: v
+    tie :: v
+    tonum :: v -> Float
+    tonum v
+      | v == win  = 1.0
+      | v == loss = 0.0
+      | v == tie  = 0.5
+
+class Player p where
+    maxing :: p -> Bool
+
+class (Traversable l, Monad m, Value v, Player p, Eq t) => MonadGame t l v p m | m -> t, m -> p, m -> v, m -> l where
+    currentPlayer :: m p
+    turns :: m (l 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 l v p m) => PlayableGame t l 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)
+
+class Choose t m | m -> t where 
+    choose :: m t
+
+class Monad m => MonadRandom m where
+    random :: Random a => m a
+    randomR :: Random a => (a, a) -> m a
+    chooser :: [a] -> m a
+    chooser [] = error "chooser: empty list"
+    chooser os = (os!!) <$> randomR (0, length os - 1)
+    chooserS :: Set a -> m a
+    chooserS set
+        | S.null set = error "chooserS: empty set"
+        | otherwise  = (`S.elemAt` set) <$> randomR (0, S.size set - 1)
+
+instance MonadRandom IO where
+    random = Rand.randomIO
+    randomR = Rand.randomRIO
+
+instance MonadRandom (State Rand.StdGen) where
+    random = do
+        gen <- get
+        let (a, gen') = Rand.random gen
+        put gen'
+        return a
+    randomR bds = do
+        gen <- get
+        let (a, gen') = Rand.randomR bds gen
+        put gen'
+        return a

src/Skat/AI/Games/Skat/Guess.hs

@@ -0,0 +1,338 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE BangPatterns #-}
+
+module Skat.AI.Games.Skat.Guess where
+
+import GHC.Generics (Generic, Generic1) 
+import Data.Ord
+import Data.Aeson
+import Data.Monoid ((<>))
+import Data.List
+import Data.Set (Set)
+import qualified Data.Set as S
+import Control.Monad.State
+import Control.Monad.Reader
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as M
+import Data.List (delete)
+import Data.Bits
+import Debug.Trace
+
+import Skat
+import Skat.AI.Base
+import Skat.Utils
+import Skat.Card
+import Skat.Pile
+import Skat.Player
+import Skat.Player
+import Control.Parallel.Strategies
+import Control.DeepSeq
+
+data Option = H Hand
+            | Skt
+              deriving (Show, Eq, Ord, Generic, NFData, ToJSON)
+
+type Guess = Map Card (Set Option)
+
+newGuess :: Guess
+newGuess = newGuessWith allCards
+
+newGuessWith :: [Card] -> Guess
+newGuessWith cards = M.fromList l
+    where l = map (\c -> (c, S.fromList [H Hand1, H Hand2, H Hand3, Skt])) cards
+
+hasBeenPlayed :: Card -> Guess -> Guess
+hasBeenPlayed card = M.delete card
+
+has :: Hand -> [Card] -> Guess -> Guess
+has hand cs = M.mapWithKey f
+    where f card hands
+            | card `elem` cs = S.singleton (H hand)
+            | otherwise      = hands
+
+hasOnly :: Hand -> [Card] -> Guess -> Guess
+hasOnly hand cs = M.mapWithKey f
+    where f card hands
+            | card `elem` cs = S.singleton (H hand)
+            | otherwise      = S.delete (H hand) hands
+
+hasOnly_ :: Option -> [Card] -> Guess -> Guess
+hasOnly_ option cs = M.mapWithKey f
+    where f card hands
+            | card `elem` cs = S.singleton option
+            | otherwise      = S.delete option hands
+
+hasNoLonger :: Trump -> Hand -> TurnColour -> Guess -> Guess
+hasNoLonger trump hand effCol = M.mapWithKey f
+    where f card hands
+            | effectiveColour trump card == effCol && (H hand) `S.member` hands =
+                S.filter (/=H hand) hands
+            | otherwise = hands
+
+observe :: Trump -> Maybe TurnColour -> [CardS Played] -> Guess -> Guess
+observe _ Nothing _ guess = guess
+observe trpCol (Just turnCol) tbl oldGuess = foldr f oldGuess tbl
+    where f :: CardS Played -> Guess -> Guess
+          f c g = let col = effectiveColour trpCol (toCard c)
+                  in if col /= turnCol
+                      then hasNoLonger trpCol (uorigin $ getPile c) turnCol g
+                      else g
+
+observeS :: Guess -> Skat Guess
+observeS guess = do
+    trpCol <- trump
+    turnCol <- gets Skat.turnColour
+    tbl <- getp tableCards
+    pure $ observe trpCol turnCol tbl guess
+
+isSkat :: [Card] -> Guess -> Guess
+isSkat cs = M.mapWithKey f
+    where f card hands
+            | card `elem` cs = S.singleton Skt
+            | otherwise      = if length cs == 2 then S.delete Skt hands else hands
+
+choosen1 :: Int -> [a] -> [[a]]
+choosen1 !n !cs = map f (filter ((==n) . popCount) [0..(m-1)])
+    where m = 2^(length cs) :: Int
+          f !i = collect $! filter (< length cs) $! getSetBits i
+          collect !idx = map (cs!!) $! idx
+
+getSetBits :: Int -> [Int]
+getSetBits !a = filter (\i -> 2^i .&. a /= 0) [0..a]
+{-# INLINE getSetBits #-}
+
+choosen2 :: Int -> [a] -> [[a]]
+choosen2 !n !cs = map f (filter ((==n) . popCount) [0..(m-1)])
+    where m = 2^(length cs) :: Int
+          f !i = filterMap (g i) fst $! zip cs [0..]
+          g !i (c, k) = 2^k .&. i /= 0
+
+choosen = choosen2
+
+smplguess :: Guess
+smplguess = Hand1 `hasOnly` [(Card Seven Diamonds)..(Card Eight Hearts)] $! newGuess
+
+smplguess2 :: Guess
+smplguess2 = M.fromList
+    [ ( Card Seven Diamonds, S.fromList [H Hand2, H Hand3] )
+    , ( Card Eight Hearts, S.fromList [H Hand2, H Hand1]   )
+    , ( Card Nine Spades, S.fromList [H Hand1, H Hand2]    )
+    , ( Card Nine Diamonds, S.fromList [Skt]               )
+    , ( Card Eight Diamonds, S.fromList [Skt]              )
+    ]
+
+smplguess3 :: Guess
+smplguess3 = M.fromList 
+    [ (Card Nine Clubs, S.fromList [Skt])
+    , (Card Queen Clubs, S.fromList [Skt])
+    , (Card Ten Hearts, S.fromList [H Hand2,H Hand3])
+    , (Card Ace Diamonds, S.fromList [H Hand2])
+    ]
+
+smplguess4 :: Guess
+smplguess4 = M.fromList
+    [ (Card Seven Spades,   S.fromList [H Hand1])
+    , (Card Nine Spades,    S.fromList [H Hand1])
+    , (Card Eight Spades,   S.fromList [H Hand2])
+    , (Card Queen Diamonds, S.fromList [H Hand3])
+    , (Card Ace Diamonds,   S.fromList [H Hand3])
+    , (Card King Clubs,     S.fromList [H Hand2,H Hand3])
+    , (Card Ace Clubs,      S.fromList [H Hand2,H Hand3])
+    , (Card Nine Clubs,     S.fromList [Skt])
+    , (Card Queen Clubs,    S.fromList [Skt])
+    ]
+
+distributions2 :: Guess -> (Int, Int, Int, Int) -> [Distribution]
+distributions2 !guess1 !(n1, n2, n3, nskt) = do
+    let h1cards = M.keys $!! M.filter (H Hand1 `elem`) guess1
+    hand1 <- choosen 10 h1cards
+    let guess2 = Hand1 `hasOnly` hand1 $! guess1
+        h2cards = M.keys $!! M.filter (H Hand2 `elem`) guess2
+    hand2 <- choosen 10 h2cards
+    let guess3 = Hand2 `hasOnly` hand2 $! guess2
+        h3cards = M.keys $!! M.filter (H Hand3 `elem`) guess3
+        x = choosen 10 $!! h3cards
+    hand3 <- x
+    --let guess4 = Hand3 `hasOnly` hand3 $! guess3
+    --    sktcards = M.keys $!! M.filter (Skt `elem`) guess4
+    --skt <- choosen (2 + nskt) sktcards
+    return (hand1, hand2, hand3, [])--, skt)
+
+carddist :: Option -> Int -> Guess -> [[Card]]
+carddist option n guess = choosen n options
+    where options = M.keys $ M.filter (option `S.member`) guess
+
+carddistS :: Option -> Int -> StateT Guess [] [Card]
+carddistS option n = do
+    guess <- get
+    sels <- lift $ carddist option n guess
+    put $ option `hasOnly_` sels $ guess
+    return sels
+
+distributions3 :: Guess -> (Int, Int, Int, Int) -> [Distribution]
+distributions3 guess (n1, n2, n3, n4) = (flip evalStateT) guess $ do
+    hand1 <- carddistS (H Hand1) (cardsPerHand + n1)
+    hand2 <- carddistS (H Hand2) (cardsPerHand + n2)
+    hand3 <- carddistS (H Hand3) (cardsPerHand + n3)
+    skt   <- carddistS Skt       (2 + n4)
+    return (hand1, hand2, hand3, skt)
+  where cardsPerHand = (length guess-2-n1-n2-n3) `div` 3
+
+randomChoice :: (MonadRandom m, Monad m) => Set Option -> StateT (Int, Int, Int, Int) m Option
+randomChoice options = do
+    --when (null options) $ error "randomChoice: options are empty"
+    (n1, n2, n3, n4) <- get
+    let g (H Hand1) = n1 > 0
+        g (H Hand2) = n2 > 0
+        g (H Hand3) = n3 > 0
+        g Skt       = n4 > 0
+        opts = S.toList $ S.filter g options
+    --when (null opts) $ error "randomChoice: after filtering options are empty"
+    option <- if null opts then (error ("randomChoice: opts empty, " ++ show options ++ " " ++ show (n1,n2,n3,n4)))  else lift (chooser opts)
+    let (n1', n2', n3', n4') = case option of
+            H Hand1 -> (n1-1, n2, n3, n4)
+            H Hand2 -> (n1, n2-1, n3, n4)
+            H Hand3 -> (n1, n2, n3-1, n4)
+            Skt     -> (n1, n2, n3, n4-1)
+    put (n1', n2', n3', n4')
+    return option
+
+randomGuess :: (MonadRandom m, Monad m) => Guess -> (Int, Int, Int, Int) -> m Guess
+randomGuess guess (n1, n2, n3, n4) = (flip evalStateT) ( cardsPerHand + n1
+                                                       , cardsPerHand + n2
+                                                       , cardsPerHand + n3
+                                                       , 2 + n4
+                                                       ) $ do
+    foldM helper guess (M.keys guess)
+  where cardsPerHand = (length guess-2-n1-n2-n3) `div` 3
+        helper g card = do
+            let opts = M.findWithDefault (error "findWithDefault") card g
+            o <- randomChoice opts
+            pure $ M.insert card (S.singleton o) g
+
+choosern :: (Eq a, Monad m, MonadRandom m) => Int -> [a] -> m [a]
+choosern 0  _   = pure []
+choosern _  []  = error "chooseRn: list is empty and n /= 0"
+choosern !n !os = do
+    o <- chooser os
+    let !os' = delete o os
+    rest <- choosern (n-1) os'
+    pure $ o : rest
+
+choosernS :: (Ord a, Monad m, MonadRandom m) => Int -> Set a -> m (Set a)
+choosernS 0  _   = pure S.empty
+choosernS !n !os
+    | S.size os == 0 = error "chooseRn: list is empty and n /= 0"
+    | otherwise = do
+        o <- chooserS os
+        let !os' = S.delete o os
+        rest <- choosernS (n-1) os'
+        pure $ S.insert o rest
+
+
+snd3 :: (a,b,c) -> b
+snd3 (a,b,c) = b
+
+randomDistr2 :: (MonadRandom m, Monad m) => Guess -> (Int, Int, Int, Int) -> m Distribution
+randomDistr2 guess1 (n1, n2, n3, _) = do
+    let h1cs = M.keysSet $!! M.filter (H Hand1 `S.member`) guess1
+        h2cs = M.keysSet $!! M.filter (H Hand2 `S.member`) guess1
+        h3cs = M.keysSet $!! M.filter (H Hand3 `S.member`) guess1
+        skcs = M.keysSet $!! M.filter (Skt `S.member`)     guess1
+        priority = M.filter ((==1) . S.size) guess1
+        predist = M.foldrWithKey
+            (\card opts dist -> M.insertWith (++) (S.elemAt 0 opts) [card] dist)
+            M.empty
+            priority
+        banned = M.keysSet priority
+        pots = sortBy (comparing $ \(_, cs, n) -> length cs - n)
+            $ [ (H Hand1, h1cs, nh1 - length (M.findWithDefault [] (H Hand1) predist))
+              , (H Hand2, h2cs, nh2 - length (M.findWithDefault [] (H Hand2) predist))
+              , (H Hand3, h3cs, nh3 - length (M.findWithDefault [] (H Hand3) predist))
+              , (Skt    , skcs, nh4 - length (M.findWithDefault [] Skt       predist))
+              ]
+    (dist, _) <- foldM f (predist, banned) pots
+
+    return ( M.findWithDefault (error "randomDistr: missing option Hand1") (H Hand1) dist
+           , M.findWithDefault (error "randomDistr: missing option Hand2") (H Hand2) dist
+           , M.findWithDefault (error "randomDistr: missing option Hand3") (H Hand3) dist
+           , M.findWithDefault (error "randomDistr: missing option Skt") Skt dist
+           )
+  where cardsPerHand = (length guess1-2-n1-n2-n3) `div` 3
+        nh1 = cardsPerHand + n1
+        nh2 = cardsPerHand + n2
+        nh3 = cardsPerHand + n3
+        nh4 = 2
+        f (dist, banned) (option, cards, n) = do
+            let available = S.filter (not . (`S.member` banned)) cards
+            cs <- if S.size available < n
+                    then error ("Not enough options available: wanted " ++ show n ++ " for " ++ show option ++ " and got " ++ show (length available) ++ ", " ++ show guess1 ++ " with " ++ show (n1, n2, n3))
+                    else choosernS n available
+            let dist' = M.insertWith (++) option (S.toList cs) dist
+            pure (dist', S.union banned cs)
+
+randomDistr :: (MonadRandom m, Monad m) => Guess -> (Int, Int, Int, Int) -> m Distribution
+randomDistr = randomDistr2
+        
+randomDistr1 :: (MonadRandom m, Monad m) => Guess -> (Int, Int, Int, Int) -> m Distribution
+randomDistr1 guess (n1, n2, n3, n4) = (flip evalStateT) ( cardsPerHand + n1
+                                                       , cardsPerHand + n2
+                                                       , cardsPerHand + n3
+                                                       , 2 + n4
+                                                       ) $ do
+    randomGuess <- foldM helper guess (M.keys guess)
+    let [d] = distributions randomGuess (n1, n2, n3, n4)
+    pure d
+  where cardsPerHand = (length guess-2-n1-n2-n3) `div` 3
+        helper g card = do
+            let opts = M.findWithDefault (error "findWithDefault") card g
+            o <- randomChoice opts
+            pure $ M.insert card (S.singleton o) g
+{-
+distributions1 :: Guess -> (Int, Int, Int, Int) -> [Distribution]
+distributions1 guess nos =
+        helper (sortBy compareGuess $ M.toList guess) nos
+        `using` parList rdeepseq
+    where helper []           _ = []
+          helper ((c, hs):[]) ns = map fst (distr c hs ns)
+          helper ((c, hs):gs) ns =
+                let dsWithNs = distr c hs ns
+                    go (d, ns') = map (d <>) (helper gs ns')
+                in concatMap go dsWithNs
+          distr card hands (n1, n2, n3, n4) =
+                let f card (H Hand1) =
+                        (([card], [], [], []), (n1+1, n2, n3, n4))
+                    f card (H Hand2) =
+                        (([], [card], [], []), (n1, n2+1, n3, n4))
+                    f card (H Hand3) =
+                        (([], [], [card], []), (n1, n2, n3+1, n4))
+                    f card Skt =
+                        (([], [], [], [card]), (n1, n2, n3, n4+1))
+                    isOk (H Hand1) = n1 < cardsPerHand
+                    isOk (H Hand2) = n2 < cardsPerHand
+                    isOk (H Hand3) = n3 < cardsPerHand
+                    isOk Skt       = n4 < 2
+                in filterMap isOk (f card) hands
+          cardsPerHand = (length guess - 2) `div` 3
+-}
+
+distributions = distributions3
+
+type Distribution = ([Card], [Card], [Card], [Card])
+
+compareGuess :: (Card, [Option]) -> (Card, [Option]) -> Ordering
+compareGuess (c1, ops1) (c2, ops2)
+    | length ops1 == 1 = LT
+    | length ops2 == 1 = GT
+    | c1 > c2 = LT
+    | c1 < c2 = GT
+
+toPiles :: [CardS Played] -> Distribution -> Piles
+toPiles table (h1, h2, h3, skt) = makePiles h1 h2 h3 table skt
+
+updatePiles :: Distribution -> Piles -> Piles
+updatePiles (h1, h2, h3, skt) piles = piles { _hand1 = fmap (putAt $ P Hand1) h1
+                                            , _hand2 = fmap (putAt $ P Hand2) h2
+                                            , _hand3 = fmap (putAt $ P Hand3) h3
+                                            , _skat  = fmap (putAt S) skt }

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/Markov.hs

@@ -0,0 +1,510 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE ImportQualifiedPost #-}
+
+module Skat.AI.Markov (
+) where
+
+import Control.Monad.State
+import Control.Exception (assert)
+import Control.Monad.Fail
+import Data.Ord
+import Text.Read (readMaybe)
+import Data.List (maximumBy, sortBy, delete)
+import Debug.Trace
+import Data.Ratio
+import Data.Set (Set)
+import qualified Data.Set as Set
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Bits
+import Data.Vector (Vector)
+import qualified Data.Vector as Vector
+
+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 hiding (trumpColour, turnColour)
+import qualified Skat.Render as S
+--import TestEnvs (env3, shuffledEnv2)
+
+data Possibility d a = Possibility { value :: a
+                                   , probability :: d
+                                   }
+
+newtype Distribution d a = Distribution { runDistribution :: [Possibility d a] }
+
+instance Num d => Monad (Distribution d) where
+    return :: a -> Distribution d a
+    return x = Distribution [Possibility x 1]
+    (>>=) :: Distribution d a -> (a -> Distribution d b) -> Distribution d b
+    (Distribution ps) >>= f = Distribution $ do
+        (Possibility x1 p1) <- ps
+        let (Distribution ds) = f x1
+        (Possibility x2 p2) <- ds
+        return $ Possibility x2 (p1*p2)
+
+instance Num d => Applicative (Distribution d) where
+    pure = return
+    (<*>) = ap
+
+instance Num d => Functor (Distribution d) where
+    fmap = liftM
+
+sumDist :: (Num d, Ord a) => Distribution d a -> Distribution d a
+sumDist = distFromMap . distToMap
+    where distToMap (Distribution ps) = Map.fromListWith (+) $ do
+            (Possibility x p) <- ps
+            return (x, p)
+          distFromMap m = Distribution $ do
+            (x, p) <- Map.toList m
+            return $ Possibility x p
+
+deriving instance (Show d, Show a) => Show (Possibility d a)
+deriving instance (Show d, Show a) => Show (Distribution d a)
+deriving instance (Eq d, Eq a) => Eq (Possibility d a)
+deriving instance (Eq d, Eq a) => Eq (Distribution d a)
+deriving instance (Ord d, Ord a) => Ord (Possibility d a)
+deriving instance (Ord d, Ord a) => Ord (Distribution d a)
+
+drawSome :: Int -> StateT (Set S.Card) (Distribution Rational) (Set S.Card)
+drawSome n = do
+    s <- get
+    let ds = sumDist $ runStateT (Set.fromList <$> replicateM n draw) s
+    (d, s') <- lift ds
+    put s'
+    return d
+    --put s'
+
+draw2 = sumDist $ (flip evalStateT) (Set.fromList $ take 22 S.allCards) do
+    ss <- replicateM 5 (drawSome 2)
+    return $ Set.unions ss
+
+basen = 22
+taken = 10
+
+allCards = Vector.fromList $ take basen S.allCards
+
+example = stupid taken (Set.fromList $ take basen S.allCards)
+example2 = stupid2 taken (take basen S.allCards)
+example3 = stupid3 taken (take basen S.allCards)
+example4 = smart taken (take basen S.allCards)
+example5 = stupid4 taken allCards
+example6 = stupid5 taken (take basen S.allCards)
+
+stupid :: Int -> Set S.Card -> Set (Set S.Card)
+stupid 0 _ = Set.singleton Set.empty
+stupid n cs
+    | length cs == 0 = Set.empty
+    | otherwise = xs
+  where f :: S.Card -> Set (Set S.Card)
+        f c = let cs' = Set.delete c cs
+                  distrs = stupid (n-1) cs'
+                  distrs' = Set.map (Set.insert c) distrs
+              in distrs'
+        --xs :: Set (Set (Set S.Card))
+        xs = Set.foldr (\c s -> Set.union s $ f c) Set.empty cs
+
+--stupid2 :: (Monoid f, Foldable f, Functor f) => Int -> f S.Card -> f (f S.Card)
+stupid2 0 _ = [mempty]
+stupid2 n cs
+    | length cs == 0 = mempty
+    | otherwise = xs
+  where f c = let cs' = delete c cs
+                  distrs = stupid2 (n-1) cs'
+                  distrs' = fmap (c:) distrs
+              in distrs'
+        --xs :: Set (Set (Set S.Card))
+        xs = foldr (\c s -> s <> f c) mempty cs
+
+stupid3 :: Int -> [S.Card] -> [[S.Card]]
+stupid3 n cs = map (f cs) (filter ((==n) . popCount) [1..m])
+    where m = 2^(length cs) :: Int
+          f cs i = collect cs $ filter (< length cs) $ getSetBits i
+          collect l idx = map (l!!) idx
+
+getSetBits :: Int -> [Int]
+getSetBits a = filter (\i -> 2^i .&. a /= 0) [0..a]
+
+-- very bad suddenly
+stupid5 :: Int -> [S.Card] -> Set (Set S.Card)
+stupid5 n cs = Set.map (Set.fromList . f cs) (Set.filter ((==n) . popCount) $ Set.fromList [1..m])
+    where m = 2^(length cs) :: Int
+          f cs i = collect cs $ filter (< length cs) $ getSetBits i
+          collect l idx = map (\i -> l!!i) idx
+
+stupid4 :: Int -> Vector S.Card -> Vector [S.Card]
+stupid4 n cs = fmap f (Vector.filter ((==n) . popCount) bs)
+    where bs = Vector.fromList [1..m]
+          m = 2^(length cs) :: Int
+          f i = collect $ filter (< length cs) $ getSetBits i
+          collect idx = map (\i -> cs Vector.! (i-1)) idx
+          getSetBits a = filter ((/=0) . (.&.a)) [1..a]
+          {-
+          getSetBits a
+            | popCount a == n = filter (\k -> (k.&.a) /= 0) [1..a]
+            | otherwise       = []
+        -}
+
+
+smart n = map Set.fromList . stupid3 n
+
+carddist :: Int -> Set S.Card -> Distribution Rational (Set S.Card)
+carddist n cs = Distribution $ fmap (\x -> Possibility x (1%l)) raw
+    where raw = smart n cards
+          l = fromIntegral $ length raw
+          cards = Set.toList cs
+
+carddistS :: Int -> StateT (Set S.Card) (Distribution Rational) (Set S.Card)
+carddistS n = do
+    cards <- get
+    sels <- lift $ carddist n cards
+    put $ cards `Set.difference` sels
+    return sels
+
+draw :: StateT (Set S.Card) (Distribution Rational) S.Card
+draw = do
+    cards <- get
+    card <- lift $ Distribution $ Set.toList $ Set.map (flip Possibility $ (1 % (fromIntegral $ length cards))) cards
+    let cards' = Set.delete (card) cards
+    put cards'
+    return card
+
+{-
+draw2 :: StateT (Set S.Card) Identity (Distribution Rational S.Card)
+draw2 = do
+    cards <- get
+    cards <- get
+    card <- lift $ Distribution $ Set.toList $ Set.map (flip Possibility $ (1 % (fromIntegral $ length cards))) cards
+    let cards' = Set.delete (card) cards
+    put cards'
+    return card
+-}
+
+{-
+coprod :: (Ord a, Num d) => Possibility d a -> Possibility d a -> Possibility d a
+coprod (Possibility x p) (Possibility y q) = Or (Set.fromList [x,  y]) $ p + q
+-}
+
+skat :: Distribution Rational (Set S.Card, Set S.Card, Set S.Card)
+skat = (flip evalStateT) (Set.fromList $ take 22 S.allCards) $ do
+    sndHand <- carddistS 10
+    trdHand <- carddistS 10
+    skt <- carddistS 2
+    return ( sndHand
+           , trdHand
+           , skt
+           )
+
+coin :: Distribution Rational Bool
+coin = Distribution [ Possibility True (1%2), Possibility False (1%2)]
+
+tosstwice :: Distribution Rational (Bool, Bool)
+tosstwice = do
+    c1 <- coin
+    c2 <- coin
+    return (c1, c2)
+
+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 (Traversable l, Monad m, Value v, Player p, Eq t) => MonadGame t l v p m | m -> t, m -> p, m -> v, m -> l where
+    currentPlayer :: m p
+    turns :: m (l 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 l v p m) => PlayableGame t l 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.CardS S.Owner) [] Int S.PL S.Skat where
+    currentPlayer = do
+        hand <- gets S.currentHand
+        pls <- gets S.players
+        return $! S.player pls hand
+    turns = S.allowedCards
+        --player <- currentPlayer
+        --trCol <- gets S.trumpColour
+        --return $! if maxing player
+        --    then sortBy (optimalTeam trCol) cards
+        --    else sortBy (optimalSingle trCol) cards
+    play = S.play_
+    simulate card action = do
+        --oldCurrent <- gets S.currentHand
+        --oldTurnCol <- gets S.turnColour
+        backup <- get
+        play card
+        --oldWinner <- currentPlayer
+        res <- action
+        --S.undo_ card oldCurrent oldTurnCol (S.team oldWinner)
+        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)
+
+potentialByType :: S.Type -> Int
+potentialByType S.Ace = 11
+potentialByType S.Jack = 10
+potentialByType S.Ten = 4
+potentialByType S.Seven = 7
+potentialByType S.Eight = 7
+potentialByType S.Nine = 7
+potentialByType S.Queen = 5
+potentialByType S.King = 5
+
+optimalSingle :: S.Colour -> S.Card -> S.Card -> Ordering
+optimalSingle trCol (S.Card t1 _) (S.Card t2 _) = (comparing potentialByType) t2 t1
+
+optimalTeam :: S.Colour -> S.Card -> S.Card -> Ordering
+optimalTeam trCol (S.Card t1 _) (S.Card t2 _) = (comparing potentialByType) t2 t1
+
+-- 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
+
+toss :: Distribution Rational Coin
+toss = Distribution [Possibility Head (1%2), Possibility Tail (1%2)]
+
+data Coin = Head
+          | Tail
+            deriving (Show, Eq, Ord)
+
+data CoinGameState = CGS { tosses :: [Coin]
+                         , turn :: Int }
+                     deriving (Show, Eq)
+
+initCGS :: CoinGameState
+initCGS = CGS { tosses = []
+              , turn = 0
+              }
+
+markov :: StateT CoinGameState (Distribution Rational) Int
+markov = do
+    coin <- lift toss
+    cgs <- get
+    let newtosses = coin:(tosses cgs)
+        newturn = turn cgs + 1
+    put $ cgs { tosses = newtosses
+              , turn = newturn }
+    if length (filter (==Head) newtosses) >= 3 || (newturn >= 10)
+        then return newturn
+        else markov
+
+{-
+choose :: (MonadIO m, Show v, Show t, Show p, Value v, Eq t, Player p, MonadGame t l v p m)
+       => Int
+       -> m t
+choose depth = fst <$> minmax depth (error "choose") 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.CardS S.Owner) [] 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 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 = 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 l v p m) => m ()
+playCLI = do
+    gameOver <- over
+    if gameOver
+        then announceWinner
+        else do
+            when debug showBoard
+            current <- currentPlayer
+            turn <- choose 10
+            when debug $ showTurn turn
+            play turn
+            playCLI
+   where
+      readTurn :: (MonadFail m, Read t, PlayableGame t l v p m) => m t
+      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/Minmax.hs

@@ -23,73 +23,15 @@ import qualified Skat.Operations as S
 import qualified Skat.Pile as S
 import qualified Skat.Player as S hiding (trumpColour, turnColour)
 import qualified Skat.Render as S
+import Skat.AI.Base hiding (playCLI, Choose(..))
+import Skat.AI.TicTacToe hiding (playCLI)
+import Skat.AI.Skat hiding (playCLI)
 --import TestEnvs (env3, shuffledEnv2)
 
 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 (Traversable l, Monad m, Value v, Player p, Eq t) => MonadGame t l v p m | m -> t, m -> p, m -> v, m -> l where
-    currentPlayer :: m p
-    turns :: m (l 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 l v p m) => PlayableGame t l 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.CardS S.Owner) [] Int S.PL S.Skat where
-    currentPlayer = do
-        hand <- gets S.currentHand
-        pls <- gets S.players
-        return $! S.player pls hand
-    turns = S.allowedCards
-        --player <- currentPlayer
-        --trCol <- gets S.trumpColour
-        --return $! if maxing player
-        --    then sortBy (optimalTeam trCol) cards
-        --    else sortBy (optimalSingle trCol) cards
-    play = S.play_
-    simulate card action = do
-        --oldCurrent <- gets S.currentHand
-        --oldTurnCol <- gets S.turnColour
-        backup <- get
-        play card
-        --oldWinner <- currentPlayer
-        res <- action
-        --S.undo_ card oldCurrent oldTurnCol (S.team oldWinner)
-        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)
-
 potentialByType :: S.Type -> Int
 potentialByType S.Ace = 11
 potentialByType S.Jack = 10
@@ -106,89 +48,6 @@ optimalSingle trCol (S.Card t1 _) (S.Card t2 _) = (comparing potentialByType) t2
 optimalTeam :: S.Colour -> S.Card -> S.Card -> Ordering
 optimalTeam trCol (S.Card t1 _) (S.Card t2 _) = (comparing potentialByType) t2 t1
 
--- 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 l v p m)
        => Int
        -> t
@@ -221,73 +80,6 @@ choose :: (MonadIO m, Show v, Show t, Show p, Value v, Eq t, Player p, MonadGame
        -> m t
 choose depth = fst <$> minmax depth (error "choose") 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.CardS S.Owner) [] 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 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 = 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 l v p m) => m ()
 playCLI = do
     gameOver <- over

src/Skat/AI/MonteCarlo.hs

@@ -0,0 +1,251 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE DeriveGeneric #-}
+
+module Skat.AI.MonteCarlo where
+
+import GHC.Generics
+import Control.Monad.State
+import Control.Exception (assert)
+import Control.Monad.Fail
+import Data.Ord
+import Text.Read (readMaybe)
+import Data.List (maximumBy, minimumBy, sortBy, delete, intercalate)
+import Debug.Trace
+import Data.Ratio
+import Data.Set (Set)
+import qualified Data.Set as Set
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Bits
+import Data.Vector (Vector)
+import qualified Data.Vector as Vector
+import System.Random (Random)
+import qualified System.Random as Rand
+import Text.Printf
+import Data.List.Split
+import Data.Aeson hiding (Value)
+
+import Skat.AI.Base hiding (simulate)
+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 hiding (trumpColour, turnColour)
+import qualified Skat.Render as S
+import Skat.Utils
+--import TestEnvs (env3, shuffledEnv2)
+
+type WinCount = Float
+type SimCount = Int
+
+data Tree t s = Leaf    s Bool (WinCount, SimCount)
+              | Node    s Bool (WinCount, SimCount) [Tree t s]
+              | Pending s t
+                deriving (Generic)
+
+instance (ToJSON t, ToJSON s) => ToJSON (Tree t s) where
+    toJSON x@Leaf{} = object [ "state" .= toJSON (treestate x)
+                             , "valuation" .= toJSON (valuation x)
+                             ]
+    toJSON x@(Node _ _ _ children) = object [ "state" .= toJSON (treestate x)
+                                            , "valuation" .= toJSON (valuation x)
+                                            , "children" .= toJSON children
+                                            ]
+    toJSON x@(Pending _ t) = object [ "valuation" .= ("pending" :: String)
+                                    , "turn" .= toJSON t
+                                    ]
+
+simruns :: Tree t s -> SimCount
+simruns (Leaf _ _ d)   = snd d
+simruns (Node _ _ d _) = snd d
+simruns Pending{}      = 0
+
+wins :: Tree t s -> WinCount
+wins (Leaf _ _ d)   = fst d
+wins (Node _ _ d _) = fst d
+wins Pending{}      = 0
+
+childrenwins :: Tree t s -> WinCount
+childrenwins (Node _ _ _ cs) = sum $ fmap wins cs
+childrenwins _               = 0
+
+treestate :: Tree t s -> s
+treestate (Leaf s _ _) = s
+treestate (Node s _ _ _) = s
+treestate (Pending s _) = s
+
+isterminal :: Tree t s -> Bool
+isterminal (Leaf _ b _)   = b
+isterminal (Node _ b _ _) = b
+isterminal Pending{}      = False
+
+class Draw s where
+    draw :: s -> String
+
+instance Draw Int where
+    draw = show
+
+indent :: Int -> String -> String
+indent n s = intercalate ("\n" ++ replicate n ' ') $ splitOn "\n" s
+
+visualise :: (HasGameState t p d s, Draw s, Draw t) => Tree t s -> String
+visualise (Node s _ d children) = printf "[%f/%d]: %s %s:\n%s" (fst d) (snd d) (show . maxing . current $ s) (indent 14 $ draw s) (intercalate "\n" $ fmap f children)
+    where f c = printf "---%s" (indent 3 $ visualise c)
+visualise (Leaf s _ d) = printf "[%f/%d]: %s" (fst d) (snd d) (indent 9 $ draw s)
+visualise (Pending s t) = printf "[pend]: %s %s" (indent 9 $ draw s) (indent 9 $ draw t)
+
+emptytree :: s -> Tree t s
+emptytree s = Leaf s False (0, 0)
+
+valuation :: Tree t s -> (WinCount, SimCount)
+valuation (Leaf _ _ d)   = d
+valuation (Node _ _ d _) = d
+valuation Pending{}      = (0,0)
+
+deriving instance (Show s, Show t) => Show (Tree t s)
+
+{-
+valuetonum  :: (Fractional a, Value v) => v -> a
+valuetonum v
+    | v == win  = 1
+    | v == loss = 0
+    | v == tie  = 0.5
+-}
+
+{-
+restoint :: (Player p, Value v) => p -> v -> Float
+restoint p v = tonum $ if maxing p then v else invert v
+-}
+
+{-
+updateval :: (Player p, Value d) => p -> [d] -> (WinCount, SimCount) -> (WinCount, SimCount)
+updateval team xs d =
+    let newSimCount = snd d + fromIntegral (length xs)
+        newWinCount = fst d + sum (fmap (tonum . cvt) xs)
+        cvt = if maxing team then id else invert
+    in (newWinCount, newSimCount)
+-}
+
+class (Player p, Value d) => HasGameState t p d s | s -> d, s -> p, s -> t where
+    moves :: s -> [t]
+    execute :: t -> s -> s
+    monteevaluate :: s -> d
+    current :: s -> p
+    simulate :: (Monad m, MonadRandom m) => s -> m d
+    simulate = montesimulate
+
+montecarlo :: (Show s, Show t, Eq p, Show d, Monad m, HasGameState t p d s, MonadRandom m)
+           => Tree t s
+           -> m (Tree t s)
+montecarlo (Pending state turn) = do
+    let currentTeam = current state
+        state' = execute turn state
+    -- objectively get a final score of random playout (independent of perspective)
+    values <- replicateM 1000 (simulate state')
+    let --tr = if maxing (current state) then id else invert
+        tr = id
+        vs = fmap (tonum . tr) values
+        n = sum vs
+    --let v = if maxing (current state') then value else invert value
+    let val = (n, 1000)
+    pure $ Leaf state' False val
+montecarlo (Leaf state terminal d)
+   | terminal || length ms == 0 = pure $ Leaf state True d
+   | otherwise = let children = map (Pending state) ms in pure $ Node state False d children
+  where ms = moves state
+montecarlo (Node state _ d []) = pure $ Leaf state True d
+montecarlo n@(Node state True d children) = pure n
+montecarlo n@(Node state _ d children)
+  | all isterminal children =
+        let d' = reevaluateminmax n
+        in pure $ Node state True d' children
+  | otherwise = do
+        let myruns = snd d
+            cmp c
+                | isterminal c = -1
+                | otherwise = selectcoeff (maxing $ current state) myruns $ valuation c
+            (idx, bestChild) =
+                maximumBy (comparing $ cmp . snd) $ zipWith (,) [0..] children
+        updated <- montecarlo bestChild
+        let cs = updateAt idx children updated
+            newSimRuns = simruns updated - simruns bestChild + snd d
+            diff = wins updated - wins bestChild
+            --diff2 = 
+            --    if newSimRuns == snd d then 0
+            --    else
+            --        if current state == current (treestate updated)
+            --                then diff
+            --                else fromIntegral (simruns updated) - diff
+            newWins = diff + fst d
+        --return $ trace ("updating node " ++ show diff2 ++ "\n" ++ show updated ++ "\n" ++ show bestChild) (Node state False (newWins, newSimRuns) cs)
+        return $ Node state False (newWins, newSimRuns) cs
+
+montesimulate :: (Monad m, MonadRandom m, HasGameState t p d s)
+              => s
+              -> m d
+montesimulate state = case moves state of
+    [] -> pure $ monteevaluate state
+    allowed -> do
+        turn <- chooser allowed
+        montesimulate $ execute turn state
+
+runmonte :: Int -> State Rand.StdGen (Tree t s) -> Tree t s
+runmonte n action = evalState action (Rand.mkStdGen n)
+
+{-
+bestmove :: Tree s -> s
+bestmove (Leaf s _ _) = s
+bestmove (Node s _ _ cs) = treestate $ selection (comparing $ rate . valuation) cs
+    where rate (w, s) = w / fromIntegral s
+          mxing = maxing . current $ s
+          selection = if mxing then maximumBy else minimumBy
+-}
+bestmove :: (HasGameState t p d s, Player p) => Tree t s -> s
+bestmove (Leaf s _ _) = s
+bestmove (Node s _ _ cs) = treestate $ choice (comparing $ rate . valuation) cs
+    where rate (w, s) = w / fromIntegral s
+          choice = if maxing (current s) then maximumBy else minimumBy
+
+selectcoeff :: Bool -> SimCount -> (WinCount, SimCount) -> Float
+selectcoeff _ _ (_, 0) = 10000000
+selectcoeff m t (w, s) = w' / fromIntegral s + explorationParam * sqrt (log (fromIntegral t) / fromIntegral s)
+    where explorationParam = sqrt 2
+          w' = if m then w else fromIntegral s - w 
+
+reevaluate :: Tree t s -> (WinCount, SimCount)
+reevaluate tree
+    | isterminal tree = valuation tree
+    | otherwise = case tree of
+        (Pending{}) -> valuation tree
+        (Leaf{}) -> valuation tree
+        (Node _ _ _ children) -> let total = sum $ fmap simruns children
+                                     wns = fromIntegral total - sum (fmap wins children)
+                                 in (wns, total)
+
+reevaluateminmax :: HasGameState t p d s => Tree t s -> (WinCount, SimCount)
+reevaluateminmax tree
+    | isterminal tree = valuation tree
+    | otherwise = case tree of
+        (Pending{}) -> valuation tree
+        (Leaf{}) -> valuation tree
+        (Node state _ _ children) ->
+            let vals = fmap ((\(w, s) -> w / fromIntegral s) . valuation) children
+        --        m = maxing . current $ state
+                --childrenMaxing = all (maxing . current . treestate) children
+                selfMaxing = maxing . current $ state
+                choice = if selfMaxing then maximum else minimum
+                newval = choice vals
+            in (newval, 1)
+
+--playCLI :: (MonadFail m, Read t, Choose t m, PlayableGame t l v p m) => m ()

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
@@ -95,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
 
@@ -110,27 +112,31 @@ 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 :: (MonadIO m, 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 :: (MonadIO m, 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
@@ -139,6 +145,7 @@ data Query = ChooseQuery [Card] [CardS Played]
            | CardsQuery [Card]
            | BidEvent (Maybe Bid) Hand Hand
            | ResponseEvent Bool Hand Hand
+           | NoGameQuery
 
 newtype ChosenResponse = ChosenResponse Card
 newtype BidResponse = BidResponse Int
@@ -148,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) =
@@ -157,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) =
@@ -183,6 +191,8 @@ instance ToJSON Query where
                , "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

@@ -70,7 +70,7 @@ instance MonadPlayer m => MonadPlayer (Simulator m) where
     turnColour = lift $ turnColour
     showSkat = lift . showSkat
 
-instance MonadPlayer m => MonadPlayerOpen (Simulator m) where
+instance (MonadIO m, MonadPlayer m) => MonadPlayerOpen (Simulator m) where
     showPiles = ask
 
 runWithPiles :: MonadPlayer m
@@ -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
@@ -215,7 +215,7 @@ simplify :: Hand -> [Distribution] -> [(Distribution, Int)]
 simplify hand ds = M.elems cleaned
     where cleaned = remove789s hand ds
 
-onPlayed :: MonadPlayer m => CardS Played -> AI m ()
+onPlayed :: (MonadIO m, MonadPlayer m) => CardS Played -> AI m ()
 onPlayed c = do
     liftIO $ print c
     modifyg (getCard c `hasBeenPlayed`)
@@ -227,10 +227,10 @@ onPlayed c = do
             then uorigin (getPile c) `hasNoLonger` demanded else return ()
         Nothing -> return ()
 
-choose :: MonadPlayer m => AI m Card
+choose :: (MonadIO m, MonadPlayer m) => AI m Card
 choose = chooseStatistic
 
-chooseStatistic :: MonadPlayer m => AI m Card
+chooseStatistic :: (MonadIO m, MonadPlayer m) => AI m Card
 chooseStatistic = do
     h <- gets getHand
     handCards <- gets myHand
@@ -284,13 +284,13 @@ foldWithLimit limit f start (x:xs) = do
                 foldWithLimit limit f m xs
         _ -> return start
 
-runOnPiles :: MonadPlayer m
+runOnPiles :: (MonadIO m, MonadPlayer m)
            => M.Map Card Int -> (Piles, Int) -> AI m (M.Map Card Int)
 runOnPiles m (ps, n) = do
     c <- runWithPiles ps chooseOpen
     return $ M.insertWith (+) c n m
 
-chooseOpen :: (MonadState AIEnv m, MonadPlayerOpen m) => m Card
+chooseOpen :: (MonadIO m, MonadState AIEnv m, MonadPlayerOpen m) => m Card
 chooseOpen = do
     piles <- showPiles
     hand <- gets getHand
@@ -316,7 +316,7 @@ 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 $ evalSkat (toCard <$> (Minmax.choose depth :: Skat (CardS Owner))) env
 
 simulate :: (MonadState AIEnv m, MonadPlayerOpen m)
@@ -337,7 +337,7 @@ 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 $ evalSkat (do
         modifyp $ playCard myHand card
@@ -388,7 +388,7 @@ leadPotential card = do
         0 -> return value
         _ -> return $ -value
 
-chooseLead :: (MonadState AIEnv m, MonadPlayer m) => m Card
+chooseLead :: (MonadIO m, MonadState AIEnv m, MonadPlayer m) => m Card
 chooseLead = do
     cards <- gets myHand
     possible <- filterM (P.isAllowed cards) cards

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/Skat.hs

@@ -0,0 +1,318 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE DeriveGeneric #-}
+
+module Skat.AI.Skat where
+
+import Data.String
+import System.IO
+import GHC.Generics
+import Control.Monad.State
+import Control.Exception (assert)
+import Control.Monad.Fail
+import Control.Monad.Writer
+import Data.Ord
+import Data.Aeson hiding (Value)
+import Text.Read (readMaybe)
+import Data.List (maximumBy, sortBy)
+import Debug.Trace
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+import qualified System.Random as Rand
+import qualified Data.ByteString.Lazy.Char8 as BS8
+
+import System.IO.Unsafe
+
+import qualified Skat as S
+import qualified Skat.Card as S
+import qualified Skat.Utils as S
+import qualified Skat.AI.Stupid as S
+import qualified Skat.Operations as S
+import qualified Skat.Pile as S
+import qualified Skat.Player as P hiding (trumpColour)
+import qualified Skat.Render as S
+import qualified Skat.Bidding as S
+import Skat.AI.Base hiding (playCLI, Choose(..))
+import Skat.AI.MonteCarlo
+import Skat.AI.Games.Skat.Guess
+
+instance Player P.PL where
+    maxing p = P.team p == S.Team
+
+instance Player Bool where
+    maxing = id
+
+instance Value Float where
+    invert = (1-)
+    win = undefined
+    loss = undefined
+    tie = undefined
+    tonum = id
+
+instance P.MonadPlayer (StateT S.SkatEnv (Writer [S.Trick])) where
+    trump = S.getTrump <$> P.game
+    turnColour = gets S.turnColour
+    showSkat p = case P.team p of
+        S.Single -> fmap (Just . S.skatCards) $ gets S.piles
+        S.Team -> return Nothing
+    singlePlayer = gets S.skatSinglePlayer
+    game = gets S.skatGame
+
+data SkatState = SkatState { skatEnv :: S.SkatEnv
+                           , self :: S.Hand
+                           , guess :: Guess
+                           }
+                 deriving (Show, Generic)
+
+instance ToJSON SkatState where
+    toJSON state = object [ "guess" .= toJSON (guess state)
+                          , "table" .= toJSON (S.tableCards $ S.piles $ skatEnv state)
+                          , "won_single" .= toJSON (S.wonCards S.Single $ S.piles $ skatEnv state)
+                          , "won_team" .= toJSON (S.wonCards S.Team $ S.piles $ skatEnv state)
+                          ]
+
+instance Draw SkatState where
+    draw = show . S.tableCards . S.piles . skatEnv
+
+instance PlayableGame (S.CardS S.Owner) [] Float P.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 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) . P.team) (P.playersToList pls)
+        return $ Just $ head winners
+    askTurn = do
+        cards <- turns
+        let sorted = 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
+
+instance MonadGame (S.CardS S.Owner) [] Float P.PL S.Skat where
+    currentPlayer = do
+        hand <- gets S.currentHand
+        pls <- gets S.players
+        return $! P.player pls hand
+    turns = S.allowedCards
+        --player <- currentPlayer
+        --trCol <- gets S.trumpColour
+        --return $! if maxing player
+        --    then sortBy (optimalTeam trCol) cards
+        --    else sortBy (optimalSingle trCol) cards
+    play = S.play_
+    simulate card action = do
+        --oldCurrent <- gets S.currentHand
+        --oldTurnCol <- gets S.turnColour
+        backup <- get
+        play card
+        --oldWinner <- currentPlayer
+        res <- action
+        --S.undo_ card oldCurrent oldTurnCol (P.team oldWinner)
+        put backup
+        return $! res
+    over = ((==0) . length) <$!> S.allowedCards
+    evaluate = do
+        player <- currentPlayer
+        piles <- gets S.piles
+        let (sgl, tm) = S.count piles :: (Int, Int)
+        return $! fromIntegral (if maxing player then tm - sgl else sgl - tm)
+
+data Turn = Turn { turnStartingEnv :: S.SkatEnv
+                 , turnCard :: S.Card }
+            deriving Show
+
+instance ToJSON Turn where
+    toJSON turn = object [ "turn_card" .= turnCard turn ]
+
+instance Draw Turn where
+    draw = show . turnCard
+
+instance HasGameState Turn Bool Float SkatState where
+    current s =
+        let curhand = S.currentHand $ skatEnv s
+            sglhand = S.skatSinglePlayer $ skatEnv s
+        in sglhand == curhand
+    monteevaluate s = let (sgl, tm) = ev S.countGame (skatEnv s)
+        in if sgl > tm then 1.0 else 0.0 --fromIntegral sgl / (fromIntegral $ sgl + tm)
+    execute turn state =
+        let tbl = ev (S.getp S.tableCards) env
+            curhand = S.currentHand env
+            trpCol :: S.Trump
+            trpCol = ev (S.getTrump <$> gets S.skatGame) env
+            turnCol = ev (gets S.turnColour) env
+            observed = observe trpCol turnCol (card':tbl) (guess state)
+            guess' = card `hasBeenPlayed` observed
+            card' = S.CardS card (S.P curhand)
+            newEnv = ex (S.play_ card) env
+        in  state { skatEnv = newEnv
+                  , guess = guess'
+                  }
+      where env = turnStartingEnv turn
+            card = turnCard turn
+    moves s
+        | S.currentHand env == self s =
+            let options = fmap S.toCard $ ev S.allowedCards env
+            in fmap (Turn env) options
+        | otherwise =
+            let currentPiles = ev (gets S.piles) env
+                table = S.tableCards currentPiles
+                n1 = length $ filter ((S.P S.Hand1==) . S.getPile) table
+                n2 = length $ filter ((S.P S.Hand2==) . S.getPile) table
+                n3 = length $ filter ((S.P S.Hand3==) . S.getPile) table
+                ns = (-n1, -n2, -n3, 0)
+                possibleDistrs = distributions (guess s) ns
+                piless = fmap ((flip updatePiles) currentPiles) possibleDistrs
+            in do
+                piles <- piless
+                let newEnv = env { S.piles = piles }
+                card <- ev S.allowedCards newEnv
+                pure $ Turn newEnv (S.toCard card)
+      where env = skatEnv s
+    simulate s
+        | Map.size (guess s) <= 2 = pure $ monteevaluate s
+        | otherwise = do
+            let currentPiles = ev (gets S.piles) env
+                table = S.tableCards currentPiles
+                n1 = length $ filter ((S.P S.Hand1==) . S.getPile) table
+                n2 = length $ filter ((S.P S.Hand2==) . S.getPile) table
+                n3 = length $ filter ((S.P S.Hand3==) . S.getPile) table
+                ns = (-n1, -n2, -n3, 0)
+            d <- randomDistr (guess s) ns
+            let newEnv = env { S.piles = updatePiles d (S.piles env) }
+                cards = ev S.allowedCards newEnv
+            card <- chooser cards
+            let newState = execute (Turn newEnv (S.toCard card)) s
+            Skat.AI.MonteCarlo.simulate newState
+      where env = skatEnv s
+
+ev :: StateT S.SkatEnv (Writer [S.Trick]) a -> S.SkatEnv -> a
+ev action = fst . runWriter . evalStateT action
+ev2 = flip ev
+ex :: StateT S.SkatEnv (Writer [S.Trick]) a -> S.SkatEnv -> S.SkatEnv
+ex action = fst . runWriter . execStateT action
+ex2 = flip ex
+
+playCLI :: Int -> StateT SkatState S.Skat ()
+playCLI n = do
+    gameOver <- lift over
+    if gameOver
+        then lift announceWinner
+        else do
+            current <- (lift currentPlayer) :: StateT SkatState S.Skat (P.PL)
+            self <- gets self
+            --let current = False
+            if P.hand current == self then do
+                liftIO $ putStrLn "iterating"
+                s <- get
+                let tree = Leaf s False (0, 0)
+                    l = length $ guess s
+                    depth
+                      | l >= 26   = 15
+                      | l >= 20   = 100
+                      | l >= 14   = 2000
+                      | otherwise = 5000
+                    t = runmonte n (foldM (\tree _ -> montecarlo tree) tree [1..depth])
+                    newstate = bestmove t
+                    json :: String
+                    json = BS8.unpack $ encode t
+                liftIO $ print newstate
+                --liftIO $ withFile "tree.json" WriteMode $ \handle ->
+                --    hPutStrLn handle json
+                --liftIO $ putStrLn $ visualise t
+                put newstate
+                lift (put $ skatEnv newstate)
+            else do
+                liftIO $ putStrLn "new turn"
+                lift $ showBoard
+                t <- lift readTurn
+                lift $ play t
+                s <- get
+                env <- lift get
+                let guess' = (S.toCard t) `hasBeenPlayed` (guess s)
+                observed <- lift $ observeS guess'
+                let s' = s { skatEnv = env
+                           , guess = observed
+                           }
+                put s'
+            {-
+            showBoard
+            liftIO $ getLine
+            -}
+            --playCLI n
+   where
+      --readTurn :: (MonadFail m, Read t, PlayableGame t l v p m) => m t
+      readTurn :: S.Skat (S.CardS S.Owner)
+      readTurn = do
+        v <- evaluate :: S.Skat Float
+        options <- (turns :: S.Skat [S.CardS S.Owner])
+        showTurns
+        liftIO $ putStr "> "
+        mayTurn <- askTurn
+        case mayTurn of
+            Just val -> if val `elem` options then return val else readTurn
+            Nothing -> readTurn
+      announceWinner :: S.Skat ()
+      announceWinner = do
+        showBoard
+        win <- (winner :: S.Skat (Maybe P.PL))
+        liftIO $ putStrLn $ show win ++ " wins the game!"
+
+initSkatEnv :: Int -> S.SkatEnv
+initSkatEnv n =
+    let gen = Rand.mkStdGen n
+        --cards = S.shuffle gen S.allCards
+        --piles = S.distribute cards
+        piles = S.cardDistr9
+        players = P.Players
+            (P.PL $ S.Stupid S.Single S.Hand1)
+            (P.PL $ S.Stupid S.Team S.Hand2)
+            (P.PL $ S.Stupid S.Team S.Hand3)
+    in S.SkatEnv { S.piles = piles
+                 , S.turnColour = Just (S.TurnColour S.Hearts)
+                 , S.skatGame = S.Colour S.Spades S.Einfach
+                 , S.players = players
+                 , S.currentHand = S.Hand1
+                 , S.skatSinglePlayer = S.Hand1
+                 }
+
+initSkatState :: SkatState
+initSkatState =
+    let env = initSkatEnv 42
+        ownCards = S.handCards S.Hand1 $ S.piles env
+        sktCards = S.skatCards $ S.piles env
+        tblCards = fmap S.toCard $ S.tableCards $ S.piles env
+        totalcards = fmap S.toCard $ S.fromPiles $ S.piles env
+        guess = (\g -> foldr hasBeenPlayed g tblCards) . isSkat sktCards . (S.Hand1 `hasOnly` (fmap S.toCard ownCards)) $ newGuessWith totalcards
+    in SkatState { skatEnv = env
+                 , self = S.Hand1
+                 , guess = guess
+                 }
+
+playSkat :: Int -> IO ()
+playSkat n = let env = skatEnv initSkatState
+    in void $ S.evalSkat ( (flip runStateT) initSkatState (playCLI n) ) env
+
+skattree :: Tree Turn SkatState
+skattree = Leaf initSkatState False (0,0)

src/Skat/AI/Stupid.hs

@@ -16,10 +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
+        --liftIO $ threadDelay 1000000
         let possible = filter (isAllowed trumpCol turnCol hand) hand
         return (toCard $ head possible, p)
 
@@ -29,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/AI/TicTacToe.hs

@@ -0,0 +1,242 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module Skat.AI.TicTacToe where
+
+import Control.Monad.State
+import Control.Exception (assert)
+import Control.Monad.Fail
+import Data.Ord
+import Text.Read (readMaybe)
+import Data.List (maximumBy, sortBy)
+import Debug.Trace
+import Text.Printf
+import Data.Maybe
+import qualified System.Random as Rand
+
+import Skat.AI.Base
+import Skat.AI.MonteCarlo
+import Skat.Utils
+-- 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
+    tie = Tie
+
+data GameState = GameState { getBoard :: [TicTacToe]
+                           , getCurrent :: Bool }
+             deriving Show
+
+instance HasGameState Int Bool WinLossTie GameState where
+    execute turn state = execState (play turn) state
+    moves state = evalState turns state
+    monteevaluate s = let b = getBoard s 
+                          w = fromMaybe Toe $ ticWinner b
+                      in case w of
+                            Tac -> Win
+                            Tic -> Loss
+                            Toe -> Tie
+    current s = evalState currentPlayer s
+
+instance Player Bool where
+    maxing = id
+
+instance Monad m => MonadGame Int [] WinLossTie Bool (StateT GameState m) where
+    currentPlayer = gets getCurrent
+    turns = do
+        o <- over
+        if o then return [] else 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
+
+-- some consts
+
+emptyBoard :: [TicTacToe]
+emptyBoard = [Toe, Toe, Toe, Toe, Toe, Toe, Toe, Toe, Toe]
+
+otherBoard2 :: [TicTacToe]
+otherBoard2 = [Tic, Tac, Toe, Tac, Tac, Tic, Tic, Toe, Toe]
+
+otherBoard3 :: [TicTacToe]
+otherBoard3 = [Tic, Toe, Toe, Tac, Tic, Toe, Toe, Tac, Toe]
+
+tree2 = emptytree (initGameState { getBoard = otherBoard2
+                                 , getCurrent = True })
+
+tree3 = emptytree (initGameState { getBoard = otherBoard3
+                                 , getCurrent = False })
+
+initGameState :: GameState
+initGameState = GameState { getBoard = emptyBoard
+                          , getCurrent = False }
+
+tictree :: Tree Int GameState
+tictree = emptytree initGameState
+
+instance Draw GameState where
+    draw s = let b = getBoard s
+        in printf "%s %s %s\n%s %s %s\n%s %s %s"
+            (show $ b !! 0)
+            (show $ b !! 1)
+            (show $ b !! 2)
+            (show $ b !! 3)
+            (show $ b !! 4)
+            (show $ b !! 5)
+            (show $ b !! 6)
+            (show $ b !! 7)
+            (show $ b !! 8)
+
+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 ()
+
+playTicTacToe :: Int -> IO ()
+playTicTacToe n = void $ (flip runStateT) (GameState emptyBoard False) (playCLI n)
+
+playoften :: Int -> IO ()
+playoften n = mapM_ playTicTacToe [1..n]
+
+{-
+newtype TicMCTS a = TicMCTS (StateT GameState (State Rand.StdGen) a)
+                    deriving (Functor, Applicative, Monad, MonadState GameState)
+
+instance Choose Int TicMCTS where
+    choose = do
+        s <- get
+-}
+playCLI :: Int -> StateT GameState IO ()
+playCLI n = do
+    gameOver <- over
+    if gameOver
+        then announceWinner
+        else do
+            --current <- currentPlayer
+            let current = False
+            if not current then do
+                s <- get
+                let tree = Leaf s False (0, 0)
+                    t = bestmove $ runmonte n (foldM (\tree _ -> montecarlo tree) tree [1..1000])
+                put t
+            else do
+                showBoard
+                t <- readTurn
+                play t
+            showBoard
+            {-
+            liftIO $ getLine
+            -}
+            playCLI n
+   where
+      readTurn :: (MonadFail m, Read t, PlayableGame t l v p m) => m t
+      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!"

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
@@ -111,6 +153,7 @@ modifierFactor Ouvert                       = 7
 allTrumps :: Game -> [Card]
 allTrumps (Grand _) = jacks
 allTrumps (Colour col _) = jacks ++ [Card t col | t <- [Ace,Ten .. Seven] ]
+allTrumps _              = []
 
 jacks :: [Card]
 jacks = [ Card Jack Clubs, Card Jack Spades, Card Jack Hearts, Card Jack Diamonds ]
@@ -166,16 +209,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)
@@ -188,10 +251,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

@@ -2,9 +2,13 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE BangPatterns #-}
 
 module Skat.Card where
 
+import GHC.Generics (Generic, Generic1) 
 import Data.List
 import Data.Foldable (Foldable)
 import qualified Data.Foldable as F
@@ -29,7 +33,7 @@ data Type = Seven
           | Ten
           | Ace
           | Jack
-            deriving (Eq, Ord, Show, Enum, Read)
+            deriving (Eq, Ord, Show, Enum, Read, Bounded, Generic, NFData, ToJSON)
 
 data NullType = NSeven
               | NEight
@@ -39,7 +43,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 +57,7 @@ data Colour = Diamonds
             | Hearts
             | Spades
             | Clubs
-              deriving (Eq, Ord, Show, Enum, Read)
+              deriving (Eq, Ord, Show, Enum, Read, Bounded, Generic, NFData, ToJSON)
 
 data Trump = TrumpColour Colour
            | Jacks
@@ -64,8 +68,8 @@ data TurnColour = TurnColour Colour
                 | Trump
                   deriving (Show, Eq)
 
-data Card = Card Type Colour
+data Card = Card !Type !Colour
-            deriving (Eq, Show, Ord, Read)
+            deriving (Eq, Show, Ord, Read, Bounded, Generic, ToJSONKey)
 
 getType :: Card -> Type
 getType (Card t _) = t
@@ -117,6 +121,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 +177,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 +202,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,43 +1,91 @@
 module Skat.Matches (
-    singleVsBots, pvp, singleWithBidding, Match(..)
+    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
 
+data Table = Unfinished Unfinished
+           | Finished Match
+           | Pass { tablePiles :: Piles }
+             deriving Show
+
 data Match = Match { matchPiles :: Piles
                    , matchResult :: Result
                    , matchTricks :: [Trick]
                    , matchSingle :: Hand }
              deriving Show
 
-match :: PrepEnv -> IO (Maybe Match)
+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, tricks) <- runSkat 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
-            return $ Just $ Match (Skat.piles skatEnv) res tricks sglPlayer
+        -- send current table cards to clients
-        Nothing -> putStrLn "no one wanted to play" >> return Nothing
+        -- 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
@@ -60,7 +108,7 @@ 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 $ evalSkat turn env
 
 singleWithBidding :: Communicator c => c -> IO ()
@@ -72,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
     void $ match env
 
-pvp :: Communicator c => c -> c -> c -> IO (Maybe Match)
+--- 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
@@ -86,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,10 +1,15 @@
+{-# LANGUAGE FlexibleContexts #-}
+
 module Skat.Operations (
     turn, turnGeneric, play, playOpen,
-    play_, sortRender, undo_
+    play_, sortRender, undo_, gameOver,
+    countGame
 ) where
 
 import Control.Monad.State
-import Control.Monad.Writer (tell)
+import Control.Monad.Catch
+import Control.Exception hiding (catch, bracketOnError)
+import Control.Monad.Writer
 import System.Random (newStdGen, randoms)
 import Data.List
 import Data.Ord
@@ -14,10 +19,12 @@ 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_ :: (MonadWriter [Trick] m, MonadPlayer m, MonadState SkatEnv m, HasCard c) => c -> m ()
 play_ card = do
     hand <- gets currentHand
     trCol <- trump
@@ -43,19 +50,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)
@@ -63,7 +85,7 @@ turnGeneric playFunc depth = do
 turn :: Skat (Int, Int)
 turn = turnGeneric play 10
 
-evaluateTable :: Skat Hand
+evaluateTable :: (MonadPlayer m, MonadState SkatEnv m, MonadWriter [Trick] m) => m Hand
 evaluateTable = do
     trumpCol <- trump
     turnCol <- gets turnColour
@@ -76,7 +98,7 @@ evaluateTable = do
     tell [(table !! 2, table !! 1, table !! 0)]
     return $ hand winner
 
-countGame :: Skat (Int, Int)
+countGame :: (MonadState SkatEnv m) => m (Int, Int)
 countGame = getp count
 
 play :: (Show p, Player p) => p -> Skat Card
@@ -86,7 +108,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
@@ -101,3 +126,13 @@ playOpen p = do
     card <- chooseCardOpen p
     modifyp $ playCard (hand p) card
     return card
+
+gameOver :: (MonadPlayer m, MonadState SkatEnv m) => m 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

@@ -3,9 +3,16 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TupleSections #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveAnyClass #-}
 
 module Skat.Pile where
 
+import Control.Monad.State
+import Control.Monad.Trans.Maybe
+
+import GHC.Generics
+import Control.DeepSeq
 import Prelude hiding (lookup)
 import qualified Data.Map.Strict as M
 import qualified Data.Vector as V
@@ -15,6 +22,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
@@ -24,7 +33,10 @@ data Team = Team | Single
 
 data CardS p = CardS { getCard :: Card
                      , getPile :: p }
-               deriving (Show, Eq, Ord, Read)
+               deriving (Eq, Ord, Read)
+
+instance (Show p) => Show (CardS p) where
+    show (CardS card pile) = show card ++ " from " ++ show pile
 
 instance HasCard (CardS p) where
     toCard = getCard
@@ -41,7 +53,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, Generic, NFData, ToJSON)
 
 toInt :: Hand -> Int
 toInt Hand1 = 1
@@ -61,12 +73,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]
@@ -76,6 +109,9 @@ data Piles = Piles { _hand1 :: [CardS Owner]
                    , _skat :: [CardS Owner] }
              deriving (Show, Eq, Ord)
 
+fromPiles :: Piles -> [CardS Owner]
+fromPiles ps = _hand1 ps ++ _hand2 ps ++ _hand3 ps ++ _table ps ++ _wonSingle ps ++ _wonTeam ps ++ _skat ps
+
 toTable :: Hand -> Card -> Piles -> Piles
 toTable hand card ps = ps { _table = (CardS card (P hand)) : _table ps }
 
@@ -185,3 +221,112 @@ 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)
+
+cardDistr :: Piles
+cardDistr = emptyPiles hand1 hand2 hand3 skt
+    where hand1 = [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]
+          hand3 = [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]
+          skt = [Card Nine Clubs, Card Queen Clubs]
+
+cardDistr2 :: Piles
+cardDistr2 = emptyPiles hand1 hand2 hand3 skt
+    where hand3 = [Card Ace Spades, Card Eight Spades, Card Queen Diamonds, Card Ace Clubs]
+          hand1 = [Card Jack Spades, Card Seven Spades, Card Ten Diamonds, Card Nine Spades]
+          hand2 = [Card Ten Hearts, Card Eight Hearts, Card Ace Diamonds, Card King Clubs]
+          skt = [Card Nine Clubs, Card Queen Clubs]
+
+cardDistr3 :: Piles
+cardDistr3 = emptyPiles hand1 hand2 hand3 skt
+    where hand3 = [Card Ace Spades, Card Eight Spades, Card Ace Clubs]
+          hand1 = [Card Jack Spades, Card Seven Spades, Card Nine Spades]
+          hand2 = [Card Ten Hearts, Card Ace Hearts, Card Ten Clubs]
+          skt = [Card Nine Clubs, Card Seven Clubs]
+
+cardDistr4 :: Piles
+cardDistr4 = makePiles hand1 hand2 hand3 tbl skt
+    where hand3 = [Card Ace Spades]
+          hand1 = [Card Jack Spades, Card Nine Spades]
+          hand2 = [Card Eight Spades]
+          skt = [Card Nine Clubs, Card Eight Clubs]
+          tbl = [CardS (Card Ace Clubs) (P Hand3), CardS (Card King Clubs) (P Hand2)]
+
+cardDistr5 :: Piles
+cardDistr5 = makePiles hand1 hand2 hand3 tbl skt
+    where hand3 = [Card Ace Spades]
+          hand1 = []
+          hand2 = []
+          skt = [Card Nine Clubs, Card Queen Clubs]
+          tbl = [CardS (Card Jack Spades) (P Hand1), CardS (Card Eight Spades) (P Hand2)]
+
+cardDistr6 :: Piles
+cardDistr6 = emptyPiles hand1 hand2 hand3 skt
+    where hand1 = [Card Jack Diamonds, Card Jack Clubs, Card King Spades,
+                   Card Nine Spades, Card Ace Diamonds, Card Queen Diamonds
+                   ]
+          hand3 = [Card Jack Spades, Card Ten Spades, Card Ace Hearts,
+                   Card Ten Hearts, Card Nine Hearts, Card Seven Clubs
+                   ]
+          hand2 = [Card Queen Spades, Card Seven Spades, Card Seven Diamonds,
+                   Card Seven Hearts, Card Eight Hearts, Card Queen Hearts
+                   ]
+          skt = [Card Nine Clubs, Card Queen Clubs]
+
+cardDistr7 :: Piles
+cardDistr7 = emptyPiles hand1 hand2 hand3 skt
+    where hand3 = [Card Eight Spades, Card Ace Clubs]
+          hand1 = [Card Seven Spades, Card Nine Spades]
+          hand2 = [Card Ace Hearts, Card Ten Clubs]
+          skt = [Card Nine Clubs, Card Seven Clubs]
+
+cardDistr8 :: Piles
+cardDistr8 = emptyPiles hand1 hand2 hand3 skt
+    where hand3 = [Card Ace Spades, Card Ace Clubs]
+          hand1 = [Card Jack Spades, Card Seven Spades]
+          hand2 = [Card Eight Hearts, Card King Clubs]
+          skt = [Card Nine Clubs, Card Seven Clubs]
+
+cardDistr9 :: Piles
+cardDistr9 = makePiles hand1 hand2 hand3 tbl skt
+    where hand1 = [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]
+          hand3 = [Card Jack Spades, Card Jack Hearts, Card Ten Spades, Card Ten Hearts,
+                   Card Nine Hearts, Card Seven Clubs, Card King Diamonds,
+                   Card Ten Diamonds]
+          hand2 = [Card Eight Spades, Card Seven Spades, Card Seven Diamonds,
+                   Card Seven Hearts, Card Eight Hearts, Card Queen Hearts,
+                   Card Nine Diamonds, Card Eight Diamonds]
+          skt = [Card Nine Clubs, Card Queen Clubs]
+          tbl = [CardS (Card Ace Hearts) (P Hand3), CardS (Card King Hearts) (P Hand2)]

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
+class Monad 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,18 +21,19 @@ 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 :: (MonadIO m, HasCard d, HasCard c, MonadPlayer m)
                => p
                -> [CardS Played]
                -> [CardS Played]
+               -> Maybe [d]
                -> [c]
                -> m (Card, p)
-    onCardPlayed :: MonadPlayer m
+    onCardPlayed :: (MonadPlayer m, MonadIO m)
                  => p
                  -> CardS Played
                  -> m p
     onCardPlayed p _ = return p
-    chooseCardOpen :: MonadPlayerOpen m
+    chooseCardOpen :: (MonadIO m, MonadPlayerOpen m)
                    => p
                    -> m Card
     chooseCardOpen p = do
@@ -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
@@ -36,10 +38,12 @@ class Bidder a where
     onBid _ _ _ _ = return ()
     onResponse :: MonadIO m => a -> Bool -> Hand -> Hand -> m ()
     onResponse _ _ _ _ = return ()
-    onGame :: MonadIO m => a -> Game -> Hand -> m ()
+    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
@@ -60,6 +64,7 @@ instance Bidder BD where
     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
@@ -75,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)
@@ -87,9 +92,9 @@ runPreperation = 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
@@ -98,6 +103,7 @@ runBidding startingBid reizer gereizter = do
         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
@@ -111,8 +117,8 @@ runBidding startingBid reizer gereizter = do
 
 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
@@ -122,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
@@ -152,7 +154,7 @@ publishGameResults res bidders = do
     onResult (bidder bidders Hand3) res
 
 publishGameStart :: Game -> Hand -> Preperation ()
-publishGameStart game sglPlayer = mapBidders (\b -> onGame b game sglPlayer)
+publishGameStart game sglPlayer = mapBidders (\b -> onGame b (HideGame game) sglPlayer)
 
 publishBid :: Maybe Bid -> Hand -> Hand -> Preperation ()
 publishBid bid reizer gereizter = mapBidders (\b -> onBid b bid reizer gereizter)
@@ -160,9 +162,12 @@ publishBid bid reizer gereizter = mapBidders (\b -> onBid b bid reizer gereizter
 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 <- asks bidders
+    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,40 @@ 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)
+
+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

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.