skat/AI/Rulebased.hs

{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}

module AI.Rulebased (
    mkAIEnv, testds, simplify
) 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

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] -> M.Map Distribution Int
simplify hand ds = M.foldl' f M.empty cleaned
    where cleaned = remove789s hand ds
          f m (d, n) = M.insert d n m

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 realDis = distributions guess ns
        realDisNo = length realDis
        reducedDis = simplify Hand3 realDis
        reducedDisNo = length reducedDis
        piless = M.mapKeys (toPiles table) reducedDis
        limit = if depth == 1 && length table == 2
            then 1
            else min 10000 $ realDisNo `div` 2
    liftIO $ putStrLn $ "possible distrs without simp " ++ show realDisNo
    liftIO $ putStrLn $ "possible distrs " ++ show reducedDisNo
    vals <- M.toList <$> foldWithLimit limit runOnPiles M.empty (M.toList 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 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)