add ai system and a decent simulation based ai
This commit is contained in:
Christian Merten
+37
@@ -0,0 +1,37 @@
|
||||
module AI.Human where
|
||||
|
||||
import Control.Monad.Trans (liftIO)
|
||||
|
||||
import Player
|
||||
import Pile
|
||||
import Card
|
||||
import Utils
|
||||
import Render
|
||||
|
||||
data Human = Human { getTeam :: Team
|
||||
, getHand :: Hand }
|
||||
deriving Show
|
||||
|
||||
instance Player Human where
|
||||
team = getTeam
|
||||
hand = getHand
|
||||
chooseCard p table _ hand = do
|
||||
trumpCol <- trumpColour
|
||||
turnCol <- turnColour
|
||||
let possible = filter (isAllowed trumpCol turnCol hand) hand
|
||||
c <- liftIO $ askIO (map getCard table) possible hand
|
||||
return $ (c, p)
|
||||
|
||||
askIO :: [Card] -> [Card] -> [Card] -> IO Card
|
||||
askIO table possible hand = do
|
||||
putStrLn "Your hand"
|
||||
render hand
|
||||
putStrLn "These options are possible"
|
||||
render possible
|
||||
putStrLn "These cards are on the table"
|
||||
render table
|
||||
idx <- query
|
||||
"Which card do you want to play? Give the index of the card"
|
||||
if idx >= 0 && idx < length possible
|
||||
then return $ possible !! idx
|
||||
else askIO table possible hand
|
||||
+405
@@ -0,0 +1,405 @@
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
|
||||
module AI.Rulebased (
|
||||
mkAIEnv
|
||||
) where
|
||||
|
||||
import Data.Ord
|
||||
import Data.Monoid ((<>))
|
||||
import Data.List
|
||||
import Control.Monad.State
|
||||
import Control.Monad.Reader
|
||||
import qualified Data.Map.Strict as M
|
||||
|
||||
import Player
|
||||
import qualified Player.Utils as P
|
||||
import Pile
|
||||
import Card
|
||||
import Utils
|
||||
import Skat (Skat, modifyp, mkSkatEnv)
|
||||
import Operations
|
||||
|
||||
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 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 origin c2 `hasNoLonger` demanded
|
||||
else return ()
|
||||
if col3 /= demanded
|
||||
then origin c3 `hasNoLonger` demanded
|
||||
else return ()
|
||||
|
||||
type Distribution = ([Card], [Card], [Card], [Card])
|
||||
|
||||
toPiles :: [CardS Played] -> Distribution -> Piles
|
||||
toPiles table (h1, h2, h3, skt) = Piles (cs1 ++ cs2 ++ cs3) table ss
|
||||
where cs1 = map (putAt Hand1) h1
|
||||
cs2 = map (putAt Hand2) h2
|
||||
cs3 = map (putAt Hand3) h3
|
||||
ss = map (putAt SkatP) skt
|
||||
|
||||
distributions :: Guess -> (Int, Int, Int, Int) -> [Distribution]
|
||||
distributions guess nos =
|
||||
helper (sortBy (comparing $ length . snd) $ M.toList guess) nos
|
||||
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
|
||||
|
||||
simplify :: Int -> [Distribution] -> [Distribution]
|
||||
simplify 10 ds = nubBy is789Variation ds
|
||||
simplify _ ds = ds
|
||||
|
||||
is789Variation :: Distribution -> Distribution -> Bool
|
||||
is789Variation (ha1, ha2, ha3, sa) (hb1, hb2, hb3, sb) =
|
||||
f ha1 hb1 && f ha2 hb2 && f ha3 hb3 && f sa sb
|
||||
where f cs1 cs2
|
||||
| n789s cs1 /= n789s cs2 = False
|
||||
| otherwise = and (zipCs (c789s cs1) (c789s cs2))
|
||||
|
||||
zipCs :: [[Card]] -> [[Card]] -> [Bool]
|
||||
zipCs xs ys = zipWith g xs ys
|
||||
|
||||
c789s :: [Card] -> [[Card]]
|
||||
c789s cs = groupBy (grouping getColour) $
|
||||
sortBy (comparing getColour) $
|
||||
filter ((==(0 :: Int)) . count) cs
|
||||
|
||||
n789s :: [Card] -> [Card]
|
||||
n789s cs = filter ((/=(0 :: Int)) . count) cs
|
||||
|
||||
g :: [a] -> [b] -> Bool
|
||||
g xs ys = length xs == length ys
|
||||
|
||||
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 origin c `hasNoLonger` demanded else return ()
|
||||
Nothing -> return ()
|
||||
|
||||
choose :: MonadPlayer m => AI m Card
|
||||
choose = do
|
||||
handCards <- gets myHand
|
||||
table <- gets table
|
||||
case length table of
|
||||
0 -> if length handCards >= 7
|
||||
then chooseLead
|
||||
else chooseStatistic
|
||||
n -> chooseStatistic
|
||||
|
||||
chooseStatistic :: MonadPlayer m => AI m Card
|
||||
chooseStatistic = do
|
||||
h <- gets getHand
|
||||
handCards <- gets myHand
|
||||
let depth = case length handCards of
|
||||
0 -> 0
|
||||
1 -> 1
|
||||
-- simulate whole game
|
||||
2 -> 2
|
||||
3 -> 3
|
||||
-- simulate only partially
|
||||
4 -> 2
|
||||
5 -> 1
|
||||
6 -> 1
|
||||
7 -> 1
|
||||
8 -> 1
|
||||
9 -> 1
|
||||
10 -> 1
|
||||
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_
|
||||
table <- gets table
|
||||
let ns = case length table of
|
||||
0 -> (0, 0, 0, 0)
|
||||
1 -> (-1, 0, -1, 0)
|
||||
2 -> (0, 0, -1, 0)
|
||||
let dis = distributions guess ns
|
||||
disNo = length dis
|
||||
piless = map (toPiles table) dis
|
||||
limit = if depth == 1 && length table == 2
|
||||
then 1
|
||||
else min 10000 $ disNo `div` 2
|
||||
liftIO $ putStrLn $ "possible distrs " ++ show disNo
|
||||
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 -> AI m (M.Map Card Int)
|
||||
runOnPiles m ps = do
|
||||
c <- runWithPiles ps chooseOpen
|
||||
return $ M.insertWith (+) c 1 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 myCards of
|
||||
0 -> do
|
||||
liftIO $ print hand
|
||||
liftIO $ print piles
|
||||
error "no cards left to choose from"
|
||||
1 -> return $ head myCards
|
||||
_ -> chooseSimulating
|
||||
|
||||
chooseSimulating :: (MonadState AIEnv m, MonadPlayerOpen m)
|
||||
=> m Card
|
||||
chooseSimulating = do
|
||||
piles <- showPiles
|
||||
hand <- gets getHand
|
||||
let myCards = handCards hand piles
|
||||
possible <- filterM (P.isAllowed myCards) myCards
|
||||
case possible of
|
||||
[card] -> return card
|
||||
cs -> do
|
||||
results <- mapM simulate cs
|
||||
let both = zip results cs
|
||||
best = maximumBy (comparing fst) both
|
||||
return $ snd best
|
||||
|
||||
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
|
||||
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
|
||||
-- simulate the game after playing the given card
|
||||
(sgl, tm) <- liftIO $ evalStateT (do
|
||||
modifyp $ playCard card
|
||||
turnGeneric playOpen depth (next myHand)) 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
|
||||
|
||||
potential :: (MonadState AIEnv m, MonadPlayerOpen m)
|
||||
=> [Card] -> m Int
|
||||
potential cs = do
|
||||
tr <- trumpColour
|
||||
let trs = filter (isTrump tr) cs
|
||||
value = count cs
|
||||
positions <- filter (==0) <$> mapM position 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..] 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
|
||||
pots <- mapM leadPotential possible
|
||||
return $ snd $ maximumBy (comparing fst) (zip pots possible)
|
||||
|
||||
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 allCards)
|
||||
$ Hand3 `has` (take 10 allCards) $ m
|
||||
where l = map (\c -> (c, [H Hand1, H Hand2, H Hand3, Skt])) (take 32 allCards)
|
||||
m = M.fromList l
|
||||
|
||||
testds :: [Distribution]
|
||||
testds = distributions testguess (0, 0, 0, 0)
|
||||
@@ -0,0 +1,18 @@
|
||||
module AI.Stupid where
|
||||
|
||||
import Player
|
||||
import Pile
|
||||
import Card
|
||||
|
||||
data Stupid = Stupid { getTeam :: Team
|
||||
, getHand :: Hand }
|
||||
deriving Show
|
||||
|
||||
instance Player Stupid where
|
||||
team = getTeam
|
||||
hand = getHand
|
||||
chooseCard p _ _ hand = do
|
||||
trumpCol <- trumpColour
|
||||
turnCol <- turnColour
|
||||
let possible = filter (isAllowed trumpCol turnCol hand) hand
|
||||
return (head possible, p)
|
||||
+39
@@ -0,0 +1,39 @@
|
||||
import Card
|
||||
import Pile
|
||||
import Utils
|
||||
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Monoid ((<>))
|
||||
|
||||
type Guess = M.Map Card [Hand]
|
||||
type Distribution = ([Card], [Card], [Card])
|
||||
|
||||
distributions :: Guess -> [Distribution]
|
||||
distributions guess = --filter equilibrated
|
||||
(helper (M.toList guess) (0, 0, 0))
|
||||
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) =
|
||||
let f card Hand1 = (([card], [], []), (n1+1, n2, n3))
|
||||
f card Hand2 = (([], [card], []), (n1, n2+1, n3))
|
||||
f card Hand3 = (([], [], [card]), (n1, n2, n3+1))
|
||||
isOk Hand1 = n1 < cardsPerHand
|
||||
isOk Hand2 = n2 < cardsPerHand
|
||||
isOk Hand3 = n3 < cardsPerHand
|
||||
in filterMap isOk (f card) hands
|
||||
equilibrated (cs1, cs2, cs3) =
|
||||
let ls = [length cs1, length cs2, length cs3]
|
||||
in (maximum ls - minimum ls) <= 1
|
||||
cardsPerHand = (length guess `div` 3)
|
||||
|
||||
testguess :: Guess
|
||||
testguess = foldr (Hand3 `has`) m (take 10 allCards)
|
||||
where l = map (\c -> (c, [Hand1, Hand2, Hand3])) (take 30 allCards)
|
||||
m = M.fromList l
|
||||
|
||||
main :: IO ()
|
||||
main = print $ length $ distributions testguess
|
||||
Reference in New Issue
Block a user