diff --git a/app/Main.hs b/app/Main.hs index 342833f..a59af8d 100644 --- a/app/Main.hs +++ b/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 @@ -108,5 +112,7 @@ application pending = do msg <- WS.receiveData conn putStrLn $ BS.unpack msg +{- playSkat :: IO () playSkat = void $ (flip runSkat) env3 playCLI +-} diff --git a/skat.cabal b/skat.cabal index 10be9ef..9091db3 100644 --- a/skat.cabal +++ b/skat.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: ad886ff4da12419d3067287c82ddcc50c9a54d9d56bd4d4d640929eac6c0bbc5 +-- hash: 8a975ca39edf7adfa4bbf95bd068d1b2f4f3fa9e954eb61fa3cf553f03b7dd56 name: skat version: 0.1.0.8 @@ -28,13 +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 diff --git a/src/Skat.hs b/src/Skat.hs index 9441bef..9bc0ffc 100644 --- a/src/Skat.hs +++ b/src/Skat.hs @@ -1,6 +1,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} module Skat where @@ -49,14 +50,14 @@ instance P.MonadPlayer Skat where 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 } @@ -69,7 +70,7 @@ setCurrentHand hand sk = sk { currentHand = hand } 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 diff --git a/src/Skat/AI/Base.hs b/src/Skat/AI/Base.hs new file mode 100644 index 0000000..a33b476 --- /dev/null +++ b/src/Skat/AI/Base.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE TupleSections #-} + +module Skat.AI.Base 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 + +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 diff --git a/src/Skat/AI/Games/Skat/Guess.hs b/src/Skat/AI/Games/Skat/Guess.hs new file mode 100644 index 0000000..59fedab --- /dev/null +++ b/src/Skat/AI/Games/Skat/Guess.hs @@ -0,0 +1,177 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE BangPatterns #-} + +module Skat.AI.Games.Skat.Guess where + +import GHC.Generics (Generic, Generic1) +import Data.Ord +import Data.Monoid ((<>)) +import Data.List +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.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) + +type Guess = Map Card [Option] + +newGuess :: Guess +newGuess = newGuessWith allCards + +newGuessWith :: [Card] -> Guess +newGuessWith cards = M.fromList l + where l = map (\c -> (c, [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 = [H hand] + | otherwise = hands + +hasOnly :: Hand -> [Card] -> Guess -> Guess +hasOnly hand cs = M.mapWithKey f + where f card hands + | card `elem` cs = [H hand] + | otherwise = delete (H hand) hands + +hasOnly_ :: Option -> [Card] -> Guess -> Guess +hasOnly_ option cs = M.mapWithKey f + where f card hands + | card `elem` cs = [option] + | otherwise = h option hands + h a b = delete a b + +hasNoLonger :: Trump -> Hand -> TurnColour -> Guess -> Guess +hasNoLonger trump hand effCol = M.mapWithKey f + where f card hands + | effectiveColour trump card == effCol && (H hand) `elem` hands = filter (/=H hand) hands + | otherwise = hands + +isSkat :: [Card] -> Guess -> Guess +isSkat cs = M.mapWithKey f + where f card hands + | card `elem` cs = [Skt] + | otherwise = if length cs == 2 then 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 + +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 `elem`) 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 + +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 } diff --git a/src/Skat/AI/Markov.hs b/src/Skat/AI/Markov.hs index 05590b6..44b2dfa 100644 --- a/src/Skat/AI/Markov.hs +++ b/src/Skat/AI/Markov.hs @@ -17,13 +17,16 @@ import Control.Exception (assert) import Control.Monad.Fail import Data.Ord import Text.Read (readMaybe) -import Data.List (maximumBy, sortBy) +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 @@ -33,22 +36,21 @@ import qualified Skat.Player as S hiding (trumpColour, turnColour) import qualified Skat.Render as S --import TestEnvs (env3, shuffledEnv2) -data Probability d a = Or (Set a) d - | Probability { value :: a +data Possibility d a = Possibility { value :: a , probability :: d } -newtype Distribution d a = Distribution { runDistribution :: [Probability d a] } +newtype Distribution d a = Distribution { runDistribution :: [Possibility d a] } instance Num d => Monad (Distribution d) where return :: a -> Distribution d a - return x = Distribution [Probability x 1] + return x = Distribution [Possibility x 1] (>>=) :: Distribution d a -> (a -> Distribution d b) -> Distribution d b (Distribution ps) >>= f = Distribution $ do - (Probability x1 p1) <- ps + (Possibility x1 p1) <- ps let (Distribution ds) = f x1 - (Probability x2 p2) <- ds - return $ Probability x2 (p1*p2) + (Possibility x2 p2) <- ds + return $ Possibility x2 (p1*p2) instance Num d => Applicative (Distribution d) where pure = return @@ -60,23 +62,118 @@ instance Num d => Functor (Distribution d) where sumDist :: (Num d, Ord a) => Distribution d a -> Distribution d a sumDist = distFromMap . distToMap where distToMap (Distribution ps) = Map.fromListWith (+) $ do - (Probability x p) <- ps + (Possibility x p) <- ps return (x, p) distFromMap m = Distribution $ do (x, p) <- Map.toList m - return $ Probability x p + return $ Possibility x p -deriving instance (Show d, Show a) => Show (Probability d a) +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 (Probability 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 (Probability 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 Probability $ (1 % (fromIntegral $ length cards))) cards + card <- lift $ Distribution $ Set.toList $ Set.map (flip Possibility $ (1 % (fromIntegral $ length cards))) cards let cards' = Set.delete (card) cards put cards' return card @@ -86,29 +183,29 @@ draw2 :: StateT (Set S.Card) Identity (Distribution Rational S.Card) draw2 = do cards <- get cards <- get - card <- lift $ Distribution $ Set.toList $ Set.map (flip Probability $ (1 % (fromIntegral $ length cards))) cards + 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) => Probability d a -> Probability d a -> Probability d a -coprod (Probability x p) (Probability y q) = Or (Set.fromList [x, y]) $ p + q - -skat :: Distribution Rational (Set S.Card, Set S.Card, Set S.Card, Set S.Card) -skat = (flip evalStateT) (Set.fromList $ take 8 S.allCards) $ do - fstHand <- replicateM 2 draw - sndHand <- replicateM 2 draw - trdHand <- replicateM 2 draw - skt <- replicateM 2 draw - return ( Set.fromList fstHand - , Set.fromList sndHand - , Set.fromList trdHand - , Set.fromList skt +{- +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 [ Probability True (1%2), Probability False (1%2)] +coin = Distribution [ Possibility True (1%2), Possibility False (1%2)] tosstwice :: Distribution Rational (Bool, Bool) tosstwice = do @@ -281,7 +378,7 @@ 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 [Probability Head (1%2), Probability Tail (1%2)] +toss = Distribution [Possibility Head (1%2), Possibility Tail (1%2)] data Coin = Head | Tail diff --git a/src/Skat/AI/Minmax.hs b/src/Skat/AI/Minmax.hs index 279ef65..6c0159e 100644 --- a/src/Skat/AI/Minmax.hs +++ b/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 diff --git a/src/Skat/AI/MonteCarlo.hs b/src/Skat/AI/MonteCarlo.hs new file mode 100644 index 0000000..92498ad --- /dev/null +++ b/src/Skat/AI/MonteCarlo.hs @@ -0,0 +1,244 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE UndecidableInstances #-} + +module Skat.AI.MonteCarlo where + +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 Skat.AI.Base +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 + +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) + +class MonadRandom m where + random :: Random a => m a + chooser :: [a] -> m a + +instance MonadRandom IO where + random = Rand.randomIO + chooser os = (os!!) <$> Rand.randomRIO (0, length os -1) + +instance MonadRandom (State Rand.StdGen) where + random = do + gen <- get + let (a, gen') = Rand.random gen + put gen' + return a + chooser os = do + gen <- get + let (a, gen') = Rand.randomR (0, length os -1) gen + put gen' + return (os !! a) + +{- +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 + +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 1 (montesimulate state') + let tr = if maxing (current state') then id else invert + vs = fmap (tonum . tr) values + n = sum vs / 1 + --let v = if maxing (current state') then value else invert value + let val = (n, 1) + 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 = if isterminal c then -1 else selectcoeff 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 1 - diff + newWins = diff2 + 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, Show d) + => 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 :: Tree t s -> s +bestmove (Leaf s _ _) = s +bestmove (Node s _ _ cs) = treestate $ maximumBy (comparing $ rate . valuation) cs + where rate (w, s) = w / fromIntegral s + +selectcoeff :: SimCount -> (WinCount, SimCount) -> Float +selectcoeff _ (_, 0) = 10000000 +selectcoeff t (w, s) = w / fromIntegral s + explorationParam * sqrt (log (fromIntegral t) / fromIntegral s) + where explorationParam = sqrt 2 + +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 + newval = if childrenMaxing /= selfMaxing then 1 - maximum vals else maximum vals + in (newval, 1) + +--playCLI :: (MonadFail m, Read t, Choose t m, PlayableGame t l v p m) => m () diff --git a/src/Skat/AI/Online.hs b/src/Skat/AI/Online.hs index 3cc3c5b..c925cad 100644 --- a/src/Skat/AI/Online.hs +++ b/src/Skat/AI/Online.hs @@ -115,7 +115,7 @@ instance MonadPlayer m => MonadPlayer (Online a m) where singlePlayer = lift singlePlayer game = lift game -choose :: (HasCard b, HasCard a) => (Communicator c, MonadPlayer m) => [CardS Played] -> Maybe [b] -> [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 mayOuvert hand' = do gm <- game let hand = sortRender (getTrump gm) $ map toCard hand' @@ -128,7 +128,7 @@ choose table mayOuvert hand' = do if card `elem` hand && allowed then return card else choose table mayOuvert 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 diff --git a/src/Skat/AI/Rulebased.hs b/src/Skat/AI/Rulebased.hs index 18f1c1a..0e49281 100644 --- a/src/Skat/AI/Rulebased.hs +++ b/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 @@ -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 @@ -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 diff --git a/src/Skat/AI/Skat.hs b/src/Skat/AI/Skat.hs new file mode 100644 index 0000000..606d0e1 --- /dev/null +++ b/src/Skat/AI/Skat.hs @@ -0,0 +1,259 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Skat.AI.Skat where + +import Control.Monad.State +import Control.Exception (assert) +import Control.Monad.Fail +import Control.Monad.Writer +import Data.Ord +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 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 + +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 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 newEnv = ex (S.play_ card) env + in state { skatEnv = newEnv + , guess = card `hasBeenPlayed` (guess state) + } + 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 + +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) + t = runmonte n (foldM (\tree _ -> montecarlo tree) tree [1..20]) + newstate = bestmove t + --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 s' = s { skatEnv = env } + 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.cardDistr6 + 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 = Nothing + , 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 diff --git a/src/Skat/AI/Stupid.hs b/src/Skat/AI/Stupid.hs index 37cfbbe..4ae884d 100644 --- a/src/Skat/AI/Stupid.hs +++ b/src/Skat/AI/Stupid.hs @@ -19,7 +19,7 @@ instance Player Stupid where 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) diff --git a/src/Skat/AI/TicTacToe.hs b/src/Skat/AI/TicTacToe.hs new file mode 100644 index 0000000..f6be148 --- /dev/null +++ b/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..5000]) + 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!" diff --git a/src/Skat/Card.hs b/src/Skat/Card.hs index db9f458..af6e2bd 100644 --- a/src/Skat/Card.hs +++ b/src/Skat/Card.hs @@ -2,9 +2,12 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} module Skat.Card where +import GHC.Generics (Generic, Generic1) import Data.List import Data.Foldable (Foldable) import qualified Data.Foldable as F @@ -29,7 +32,7 @@ data Type = Seven | Ten | Ace | Jack - deriving (Eq, Ord, Show, Enum, Read, Bounded) + deriving (Eq, Ord, Show, Enum, Read, Bounded, Generic, NFData) data NullType = NSeven | NEight @@ -53,7 +56,7 @@ data Colour = Diamonds | Hearts | Spades | Clubs - deriving (Eq, Ord, Show, Enum, Read, Bounded) + deriving (Eq, Ord, Show, Enum, Read, Bounded, Generic, NFData) data Trump = TrumpColour Colour | Jacks @@ -65,7 +68,7 @@ data TurnColour = TurnColour Colour deriving (Show, Eq) data Card = Card Type Colour - deriving (Eq, Show, Ord, Read, Bounded) + deriving (Eq, Show, Ord, Read, Bounded, Generic) getType :: Card -> Type getType (Card t _) = t diff --git a/src/Skat/Operations.hs b/src/Skat/Operations.hs index c89ca59..9b277c0 100644 --- a/src/Skat/Operations.hs +++ b/src/Skat/Operations.hs @@ -1,12 +1,15 @@ +{-# LANGUAGE FlexibleContexts #-} + module Skat.Operations ( turn, turnGeneric, play, playOpen, - play_, sortRender, undo_, gameOver + play_, sortRender, undo_, gameOver, + countGame ) where import Control.Monad.State import Control.Monad.Catch import Control.Exception hiding (catch, bracketOnError) -import Control.Monad.Writer (tell) +import Control.Monad.Writer import System.Random (newStdGen, randoms) import Data.List import Data.Ord @@ -21,7 +24,7 @@ import Skat.Player (chooseCard, Players(..), Player(..), PL(..), 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 @@ -82,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 @@ -95,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 @@ -124,7 +127,7 @@ playOpen p = do modifyp $ playCard (hand p) card return card -gameOver :: Skat Bool +gameOver :: (MonadPlayer m, MonadState SkatEnv m) => m Bool gameOver = do tr <- trump case tr of diff --git a/src/Skat/Pile.hs b/src/Skat/Pile.hs index d874773..2c90657 100644 --- a/src/Skat/Pile.hs +++ b/src/Skat/Pile.hs @@ -3,12 +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 @@ -29,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 @@ -46,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, Enum, Bounded) + deriving (Show, Eq, Ord, Read, Enum, Bounded, Generic, NFData) toInt :: Hand -> Int toInt Hand1 = 1 @@ -102,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 } @@ -236,3 +246,60 @@ instance Serialize String [Trick] where 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 hand3 = [Card Ace Spades, Card Jack Diamonds, Card Jack Clubs, Card King Spades, + Card Nine Spades, Card Ace Diamonds, Card Queen Diamonds, Card Ten Clubs, + Card Eight Clubs, Card King Clubs] + hand1 = [Card Jack Spades, Card Jack Hearts, Card Ten Spades, Card Ace Hearts, Card Ten Hearts, + Card Nine Hearts, Card Seven Clubs, Card Ace Clubs, Card King Diamonds, + Card Ten Diamonds] + hand2 = [Card Eight Spades, Card Queen Spades, Card Seven Spades, Card Seven Diamonds, + Card Seven Hearts, Card Eight Hearts, Card Queen Hearts, Card King Hearts, + Card Nine Diamonds, Card Eight Diamonds] + 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 hand3 = [Card Ace Spades, Card Jack Diamonds, Card Jack Clubs, Card King Spades, + Card Nine Spades, Card Ace Diamonds, Card Queen Diamonds + ] + hand1 = [Card Jack Spades, Card Jack Hearts, Card Ten Spades, Card Ace Hearts, + Card Ten Hearts, Card Nine Hearts, Card Seven Clubs + ] + hand2 = [Card Eight Spades, 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] + diff --git a/src/Skat/Player.hs b/src/Skat/Player.hs index f6271b7..f0478fb 100644 --- a/src/Skat/Player.hs +++ b/src/Skat/Player.hs @@ -8,7 +8,7 @@ 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]) @@ -21,19 +21,19 @@ class (Monad m, MonadIO m, MonadPlayer m) => MonadPlayerOpen m where class Player p where team :: p -> Team hand :: p -> Hand - chooseCard :: (HasCard d, 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 diff --git a/src/Skat/Utils.hs b/src/Skat/Utils.hs index 03a1ee6..58c8514 100644 --- a/src/Skat/Utils.hs +++ b/src/Skat/Utils.hs @@ -95,3 +95,7 @@ safeToEnum n | 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