introducing prob monad
This commit is contained in:
+3
-2
@@ -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
|
||||
|
||||
@@ -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
|
||||
-}
|
||||
Reference in New Issue
Block a user