From 40908ddcf34044d9a0ff665122bb455397f1f33d Mon Sep 17 00:00:00 2001 From: Christian Merten Date: Sun, 9 Oct 2022 15:44:27 +0200 Subject: [PATCH] introducing prob monad --- skat.cabal | 5 +- src/Skat/AI/Markov.hs | 413 ++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 416 insertions(+), 2 deletions(-) create mode 100644 src/Skat/AI/Markov.hs diff --git a/skat.cabal b/skat.cabal index ef0225f..10be9ef 100644 --- a/skat.cabal +++ b/skat.cabal @@ -1,10 +1,10 @@ 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: a2e08e04140990ba90e6d7b70c6bc70b99d073ba723efa9d5e35708995da45e1 +-- hash: ad886ff4da12419d3067287c82ddcc50c9a54d9d56bd4d4d640929eac6c0bbc5 name: skat version: 0.1.0.8 @@ -29,6 +29,7 @@ library exposed-modules: Skat Skat.AI.Human + Skat.AI.Markov Skat.AI.Minmax Skat.AI.Online Skat.AI.Rulebased diff --git a/src/Skat/AI/Markov.hs b/src/Skat/AI/Markov.hs new file mode 100644 index 0000000..05590b6 --- /dev/null +++ b/src/Skat/AI/Markov.hs @@ -0,0 +1,413 @@ +{-# 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) +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 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 Probability d a = Or (Set a) d + | Probability { value :: a + , probability :: d + } + +newtype Distribution d a = Distribution { runDistribution :: [Probability d a] } + +instance Num d => Monad (Distribution d) where + return :: a -> Distribution d a + return x = Distribution [Probability x 1] + (>>=) :: Distribution d a -> (a -> Distribution d b) -> Distribution d b + (Distribution ps) >>= f = Distribution $ do + (Probability x1 p1) <- ps + let (Distribution ds) = f x1 + (Probability x2 p2) <- ds + return $ Probability 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 + (Probability x p) <- ps + return (x, p) + distFromMap m = Distribution $ do + (x, p) <- Map.toList m + return $ Probability x p + +deriving instance (Show d, Show a) => Show (Probability 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 (Distribution d a) +deriving instance (Ord d, Ord a) => Ord (Probability d a) +deriving instance (Ord d, Ord a) => Ord (Distribution d a) + +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 + 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 Probability $ (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 + ) + +coin :: Distribution Rational Bool +coin = Distribution [ Probability True (1%2), Probability 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 [Probability Head (1%2), Probability 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 +-}