{-# 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, evalSkat) import Skat.Operations import qualified Skat.AI.Minmax as Minmax import qualified Skat.AI.Stupid as Stupid (Stupid(..)) import Skat.Bidding 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 trump = lift trump 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 trump = lift trump turnColour = lift $ turnColour showSkat = lift . showSkat instance (MonadIO m, 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 -> TurnColour -> AI m () hasNoLonger hand colour = do trCol <- trump modifyg $ hasNoLonger_ trCol hand colour hasNoLonger_ :: Trump -> Hand -> TurnColour -> Guess -> Guess hasNoLonger_ trump hand effCol = M.mapWithKey f where f card hands | effectiveColour trump 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 <- trump 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 :: (MonadIO m, MonadPlayer m) => CardS Played -> AI m () onPlayed c = do liftIO $ print c modifyg (getCard c `hasBeenPlayed`) trCol <- trump 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 :: (MonadIO m, MonadPlayer m) => AI m Card choose = chooseStatistic chooseStatistic :: (MonadIO m, 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 :: (MonadIO m, 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 :: (MonadIO m, 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 <- trump myHand <- gets getHand depth <- gets simulationDepth let ps = Players (PL $ Stupid.Stupid Team Hand1) (PL $ Stupid.Stupid Team Hand2) (PL $ Stupid.Stupid Single Hand3) -- TODO: fix env = mkSkatEnv piles turnCol undefined ps myHand undefined liftIO $ evalSkat (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 <- trump 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) -- TODO: fix env = mkSkatEnv piles turnCol undefined ps (next myHand) undefined -- simulate the game after playing the given card (sgl, tm) <- liftIO $ evalSkat (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 <- trump 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 <- trump 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 :: (MonadIO m, 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)