425 lines
14 KiB
Haskell
425 lines
14 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE TypeSynonymInstances #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
|
|
module Skat.AI.Rulebased (
|
|
mkAIEnv, testds, simplify
|
|
) where
|
|
|
|
import Control.Parallel.Strategies
|
|
|
|
import Data.Ord
|
|
import Data.Monoid ((<>))
|
|
import Data.List
|
|
import qualified Data.Set as S
|
|
import Control.Monad.State
|
|
import Control.Monad.Reader
|
|
import qualified Data.Map.Strict as M
|
|
|
|
import Skat.Player
|
|
import qualified Skat.Player.Utils as P
|
|
import Skat.Pile hiding (isSkat)
|
|
import Skat.Card
|
|
import Skat.Utils
|
|
import Skat (Skat, modifyp, mkSkatEnv)
|
|
import Skat.Operations
|
|
import qualified Skat.AI.Minmax as Minmax
|
|
import qualified Skat.AI.Stupid as Stupid (Stupid(..))
|
|
|
|
data AIEnv = AIEnv { getTeam :: Team
|
|
, getHand :: Hand
|
|
, table :: [CardS Played]
|
|
, fallen :: [CardS Played]
|
|
, myHand :: [Card]
|
|
, guess :: Guess
|
|
, simulationDepth :: Int }
|
|
deriving Show
|
|
|
|
setTable :: [CardS Played] -> AIEnv -> AIEnv
|
|
setTable tab env = env { table = tab }
|
|
|
|
setHand :: [Card] -> AIEnv -> AIEnv
|
|
setHand hand env = env { myHand = hand }
|
|
|
|
setFallen :: [CardS Played] -> AIEnv -> AIEnv
|
|
setFallen fallen env = env { fallen = fallen }
|
|
|
|
setDepth :: Int -> AIEnv -> AIEnv
|
|
setDepth depth env = env { simulationDepth = depth }
|
|
|
|
modifyg :: MonadPlayer m => (Guess -> Guess) -> AI m ()
|
|
modifyg f = modify g
|
|
where g env@(AIEnv {guess}) = env { guess = f guess }
|
|
|
|
type AI m = StateT AIEnv m
|
|
|
|
instance MonadPlayer m => MonadPlayer (AI m) where
|
|
trumpColour = lift $ trumpColour
|
|
turnColour = lift $ turnColour
|
|
showSkat = lift . showSkat
|
|
|
|
instance MonadPlayerOpen m => MonadPlayerOpen (AI m) where
|
|
showPiles = lift $ showPiles
|
|
|
|
type Simulator m = ReaderT Piles (AI m)
|
|
|
|
instance MonadPlayer m => MonadPlayer (Simulator m) where
|
|
trumpColour = lift $ trumpColour
|
|
turnColour = lift $ turnColour
|
|
showSkat = lift . showSkat
|
|
|
|
instance MonadPlayer m => MonadPlayerOpen (Simulator m) where
|
|
showPiles = ask
|
|
|
|
runWithPiles :: MonadPlayer m
|
|
=> Piles -> Simulator m a -> AI m a
|
|
runWithPiles ps sim = runReaderT sim ps
|
|
|
|
instance Player AIEnv where
|
|
team = getTeam
|
|
hand = getHand
|
|
chooseCard p table fallen hand = runStateT (do
|
|
modify $ setTable table
|
|
modify $ setHand (map toCard hand)
|
|
modify $ setFallen fallen
|
|
choose) p
|
|
onCardPlayed p card = execStateT (do
|
|
onPlayed card) p
|
|
chooseCardOpen p = evalStateT chooseOpen p
|
|
|
|
value :: Card -> Int
|
|
value (Card Ace _) = 100
|
|
value _ = 0
|
|
|
|
data Option = H Hand
|
|
| Skt
|
|
deriving (Show, Eq, Ord)
|
|
|
|
-- | possible card distributions
|
|
type Guess = M.Map Card [Option]
|
|
|
|
newGuess :: Guess
|
|
newGuess = M.fromList l
|
|
where l = map (\c -> (c, [H Hand1, H Hand2, H Hand3, Skt])) allCards
|
|
|
|
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
|
|
|
|
hasNoLonger :: MonadPlayer m => Hand -> Colour -> AI m ()
|
|
hasNoLonger hand colour = do
|
|
trCol <- trumpColour
|
|
modifyg $ hasNoLonger_ trCol hand colour
|
|
|
|
hasNoLonger_ :: Colour -> Hand -> Colour -> Guess -> Guess
|
|
hasNoLonger_ trColour hand effCol = M.mapWithKey f
|
|
where f card hands
|
|
| effectiveColour trColour 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 = hands
|
|
|
|
type Turn = (CardS Played, CardS Played, CardS Played)
|
|
|
|
analyzeTurn :: MonadPlayer m => Turn -> AI m ()
|
|
analyzeTurn (c1, c2, c3) = do
|
|
modifyg (getCard c1 `hasBeenPlayed`)
|
|
modifyg (getCard c2 `hasBeenPlayed`)
|
|
modifyg (getCard c3 `hasBeenPlayed`)
|
|
trCol <- trumpColour
|
|
let turnCol = getColour $ getCard c1
|
|
demanded = effectiveColour trCol (getCard c1)
|
|
col2 = effectiveColour trCol (getCard c2)
|
|
col3 = effectiveColour trCol (getCard c3)
|
|
if col2 /= demanded
|
|
then uorigin (getPile c2) `hasNoLonger` demanded
|
|
else return ()
|
|
if col3 /= demanded
|
|
then uorigin (getPile c3) `hasNoLonger` demanded
|
|
else return ()
|
|
|
|
type Distribution = ([Card], [Card], [Card], [Card])
|
|
|
|
toPiles :: [CardS Played] -> Distribution -> Piles
|
|
toPiles table (h1, h2, h3, skt) = makePiles h1 h2 h3 table skt
|
|
|
|
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
|
|
|
|
distributions :: Guess -> (Int, Int, Int, Int) -> [Distribution]
|
|
distributions 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
|
|
|
|
type Abstract = (Int, Int, Int, Int)
|
|
|
|
abstract :: [Card] -> Abstract
|
|
abstract cs = foldr f (0, 0, 0, 0) cs
|
|
where f c (clubs, spades, hearts, diamonds) =
|
|
let v = getID c in
|
|
case getColour c of
|
|
Diamonds -> (clubs, spades, hearts, diamonds + 1 + v*100)
|
|
Hearts -> (clubs, spades, hearts + 1 + v*100, diamonds)
|
|
Spades -> (clubs, spades + 1 + v*100, hearts, diamonds)
|
|
Clubs -> (clubs + 1 + v*100, spades, hearts, diamonds)
|
|
|
|
remove789s :: Hand
|
|
-> [Distribution]
|
|
-> M.Map (Abstract, Abstract) (Distribution, Int)
|
|
remove789s hand ds = foldl' f M.empty ds
|
|
where f cleaned d =
|
|
let (c1, c2) = reduce hand d
|
|
a = (abstract c1, abstract c2) in
|
|
M.insertWith (\(oldD, n) _ -> (oldD, n+1)) a (d, 1) cleaned
|
|
reduce Hand1 (_, h2, h3, _) = (h2, h3)
|
|
reduce Hand2 (h1, _, h3, _) = (h1, h3)
|
|
reduce Hand3 (h1, h2, _, _) = (h1, h2)
|
|
|
|
simplify :: Hand -> [Distribution] -> [(Distribution, Int)]
|
|
simplify hand ds = M.elems cleaned
|
|
where cleaned = remove789s hand ds
|
|
|
|
onPlayed :: MonadPlayer m => CardS Played -> AI m ()
|
|
onPlayed c = do
|
|
liftIO $ print c
|
|
modifyg (getCard c `hasBeenPlayed`)
|
|
trCol <- trumpColour
|
|
turnCol <- turnColour
|
|
let col = effectiveColour trCol (getCard c)
|
|
case turnCol of
|
|
Just demanded -> if col /= demanded
|
|
then uorigin (getPile c) `hasNoLonger` demanded else return ()
|
|
Nothing -> return ()
|
|
|
|
choose :: MonadPlayer m => AI m Card
|
|
choose = chooseStatistic
|
|
|
|
chooseStatistic :: MonadPlayer m => AI m Card
|
|
chooseStatistic = do
|
|
h <- gets getHand
|
|
handCards <- gets myHand
|
|
table <- gets table
|
|
let tableNo = length table
|
|
left = 3 - tableNo
|
|
depth = case length handCards of
|
|
10 -> 3 + tableNo
|
|
9 -> 3 + tableNo
|
|
8 -> 3 + tableNo
|
|
7 -> 6 + tableNo
|
|
6 -> 9 + tableNo
|
|
5 -> 12 + tableNo
|
|
4 -> 15 + tableNo
|
|
_ -> 100
|
|
modify $ setDepth depth
|
|
guess__ <- gets guess
|
|
self <- get
|
|
maySkat <- showSkat self
|
|
let guess_ = (hand self `has` handCards) guess__
|
|
guess = case maySkat of
|
|
Just cs -> (cs `isSkat`) guess_
|
|
Nothing -> guess_
|
|
let ns = case tableNo of
|
|
0 -> (0, 0, 0, 0)
|
|
1 -> (-1, 0, -1, 0)
|
|
2 -> (0, 0, -1, 0)
|
|
let realDis = distributions guess ns
|
|
realDisNo = length realDis
|
|
reducedDis = simplify Hand3 realDis
|
|
reducedDisNo = length reducedDis
|
|
piless = map (\(d, n) -> (toPiles table d, n)) reducedDis
|
|
limit = min 10000 $ realDisNo `div` 2
|
|
liftIO $ putStrLn $ "players hand" ++ show handCards
|
|
liftIO $ putStrLn $ "possible distrs without simp " ++ show realDisNo
|
|
liftIO $ putStrLn $ "possible distrs " ++ show reducedDisNo
|
|
vals <- M.toList <$> foldWithLimit limit runOnPiles M.empty piless
|
|
liftIO $ print vals
|
|
return $ fst $ maximumBy (comparing snd) vals
|
|
|
|
foldWithLimit :: Monad m
|
|
=> Int
|
|
-> (M.Map k Int -> a -> m (M.Map k Int))
|
|
-> M.Map k Int
|
|
-> [a]
|
|
-> m (M.Map k Int)
|
|
foldWithLimit _ _ start [] = return start
|
|
foldWithLimit limit f start (x:xs) = do
|
|
case M.size (M.filter (>=limit) start) of
|
|
0 -> do m <- f start x
|
|
foldWithLimit limit f m xs
|
|
_ -> return start
|
|
|
|
runOnPiles :: 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 = do
|
|
piles <- showPiles
|
|
hand <- gets getHand
|
|
let myCards = handCards hand piles
|
|
possible <- filterM (P.isAllowed myCards) myCards
|
|
case length possible of
|
|
0 -> do
|
|
liftIO $ print hand
|
|
liftIO $ print piles
|
|
error "no cards left to choose from"
|
|
1 -> return $ toCard $ head possible
|
|
_ -> chooseSimulating
|
|
|
|
chooseSimulating :: (MonadState AIEnv m, MonadPlayerOpen m)
|
|
=> m Card
|
|
chooseSimulating = do
|
|
piles <- showPiles
|
|
turnCol <- turnColour
|
|
trumpCol <- trumpColour
|
|
myHand <- gets getHand
|
|
depth <- gets simulationDepth
|
|
let ps = Players (PL $ Stupid.Stupid Team Hand1)
|
|
(PL $ Stupid.Stupid Team Hand2)
|
|
(PL $ Stupid.Stupid Single Hand3)
|
|
env = mkSkatEnv piles turnCol trumpCol ps myHand
|
|
liftIO $ evalStateT (toCard <$> (Minmax.choose depth :: Skat (CardS Owner))) env
|
|
|
|
simulate :: (MonadState AIEnv m, MonadPlayerOpen m)
|
|
=> Card -> m Int
|
|
simulate card = do
|
|
-- retrieve all relevant info
|
|
piles <- showPiles
|
|
turnCol <- turnColour
|
|
trumpCol <- trumpColour
|
|
myTeam <- gets getTeam
|
|
myHand <- gets getHand
|
|
depth <- gets simulationDepth
|
|
liftIO $ putStrLn $ "simulate: " ++ show myHand ++ " plays " ++ show card
|
|
let newDepth = depth - 1
|
|
-- create a virtual env with 3 ai players
|
|
ps = Players
|
|
(PL $ mkAIEnv Team Hand1 newDepth)
|
|
(PL $ mkAIEnv Team Hand2 newDepth)
|
|
(PL $ mkAIEnv Single Hand3 newDepth)
|
|
env = mkSkatEnv piles turnCol trumpCol ps (next myHand)
|
|
-- simulate the game after playing the given card
|
|
(sgl, tm) <- liftIO $ evalStateT (do
|
|
modifyp $ playCard myHand card
|
|
turnGeneric playOpen depth) env
|
|
let v = if myTeam == Single then (sgl, tm) else (tm, sgl)
|
|
-- put the value into context for when not the whole game is
|
|
-- simulated
|
|
predictValue v
|
|
|
|
predictValue :: (MonadState AIEnv m, MonadPlayerOpen m)
|
|
=> (Int, Int) -> m Int
|
|
predictValue (own, others) = do
|
|
hand <- gets getHand
|
|
piles <- showPiles
|
|
let cs = handCards hand piles
|
|
pot <- potential cs
|
|
--return $ own + pot
|
|
return (own-others)
|
|
|
|
potential :: (MonadState AIEnv m, MonadPlayerOpen m, HasCard c)
|
|
=> [c] -> m Int
|
|
potential cs = do
|
|
tr <- trumpColour
|
|
let trs = filter (isTrump tr) cs
|
|
value = count . map toCard $ cs
|
|
positions <- filter (==0) <$> mapM (position . toCard) cs
|
|
return $ length trs * 10 + value + length positions * 5
|
|
|
|
position :: (MonadState AIEnv m, MonadPlayer m)
|
|
=> Card -> m Int
|
|
position card = do
|
|
tr <- trumpColour
|
|
guess <- gets guess
|
|
let effCol = effectiveColour tr card
|
|
l = M.toList guess
|
|
cs = filterMap ((==effCol) . effectiveColour tr . fst) fst l
|
|
csInd = zip [0..] (reverse cs)
|
|
Just (pos, _) = find ((== card) . snd) csInd
|
|
return pos
|
|
|
|
leadPotential :: (MonadState AIEnv m, MonadPlayer m)
|
|
=> Card -> m Int
|
|
leadPotential card = do
|
|
pos <- position card
|
|
isTr <- P.isTrump card
|
|
let value = count card
|
|
case pos of
|
|
0 -> return value
|
|
_ -> return $ -value
|
|
|
|
chooseLead :: (MonadState AIEnv m, MonadPlayer m) => m Card
|
|
chooseLead = do
|
|
cards <- gets myHand
|
|
possible <- filterM (P.isAllowed cards) cards
|
|
liftIO $ putStrLn $ "choosing lead from " ++ show possible
|
|
pots <- mapM leadPotential possible
|
|
let ps = zip pots possible
|
|
liftIO $ putStrLn $ "lead potential of cards " ++ show ps
|
|
return $ snd $ maximumBy (comparing fst) ps
|
|
|
|
mkAIEnv :: Team -> Hand -> Int -> AIEnv
|
|
mkAIEnv tm h depth = AIEnv tm h [] [] [] newGuess depth
|
|
|
|
-- | TESTING VARS
|
|
|
|
aienv :: AIEnv
|
|
aienv = AIEnv Single Hand3 [] [] [] newGuess 10
|
|
|
|
testguess :: Guess
|
|
testguess = isSkat (take 2 $ drop 10 cs)
|
|
$ Hand3 `has` (take 10 cs) $ m
|
|
where l = map (\c -> (c, [H Hand1, H Hand2, H Hand3, Skt])) (take 32 cs)
|
|
m = M.fromList l
|
|
cs = allCards
|
|
|
|
testguess2 :: Guess
|
|
testguess2 = isSkat (take 2 $ drop 6 cs)
|
|
$ Hand3 `has` [head cs, head $ drop 5 cs] $ m
|
|
where l = map (\c -> (c, [H Hand1, H Hand2, H Hand3, Skt])) cs
|
|
m = M.fromList l
|
|
cs = take 8 $ drop 8 allCards
|
|
|
|
testds :: [Distribution]
|
|
testds = distributions testguess (0, 0, 0, 0)
|
|
|
|
testds2 :: [Distribution]
|
|
testds2 = distributions testguess2 (0, 0, 0, 0)
|