{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} module AI.Rulebased ( mkAIEnv, testds, remove789s, reduce ) where 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 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 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 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 abstract :: [Card] -> (Int, Int, Int, Int) 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] -> [Distribution] remove789s hand ds = fst $ foldl' f ([], S.empty) ds where f (cleaned, abstracts) d = let (c1, c2) = reduce hand d a = (abstract c1, abstract c2) in if a `S.member` abstracts then (cleaned, abstracts) else (d : cleaned, S.insert a abstracts) reduce :: Hand -> Distribution -> ([Card], [Card]) reduce Hand1 (_, h2, h3, _) = (h2, h3) reduce Hand2 (h1, _, h3, _) = (h1, h3) reduce Hand3 (h1, h2, _, _) = (h1, h2) simplify :: Hand -> [Distribution] -> [Distribution] simplify = remove789s 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' dis = simplify Hand3 dis' 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 without simp " ++ show disNo' 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 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)