skat/src/Skat/AI/Rulebased.hs

{-# 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)