skat/Operations.hs

module Operations where

import Control.Monad.State
import System.Random (newStdGen, randoms)
import Data.List
import Data.Ord

import Card
import Skat
import Utils (shuffle)

compareCards :: Colour
             -> Maybe Colour
             -> Card
             -> Card
             -> Ordering
compareCards _ _ (Card Jack col1) (Card Jack col2) = compare col1 col2
compareCards trumpCol turnCol c1@(Card tp1 col1) c2@(Card tp2 col2) =
    case compare trp1 trp2 of
        EQ ->
            case compare (col1 `equals` turnCol)
                         (col2 `equals` turnCol) of
                EQ -> compare tp1 tp2
                v -> v
        v  -> v
  where trp1 = isTrump trumpCol c1
        trp2 = isTrump trumpCol c2

sortCards :: Colour -> Maybe Colour -> [Card] -> [Card]
sortCards trumpCol turnCol cs = sortBy (compareCards trumpCol turnCol) cs

compareRender :: Card -> Card -> Ordering
compareRender (Card t1 c1) (Card t2 c2) = case compare c1 c2 of
    EQ -> compare t1 t2
    v  -> v

sortRender :: [Card] -> [Card]
sortRender = sortBy compareRender

-- | finishes the calculation of a match
turning :: Index -> Skat (Int, Int)
turning n = undefined

turn2 :: Index -> Skat (Int, Int)
turn2 n = do
    t <- table
    ps <- gets players
    let p = player ps n
    hand <- cardsAt (playerHand $ index p)
    if length hand == 0
        then countGame
        else case length t of
            0 -> play p >> turn2 (next n)
            1 -> do
                modify (setTurnColour . f . head $ t)
                play p
                turn2 (next n)
            2 -> play p >> evaluateTable >>= turn2
            3 -> evaluateTable >>= turn2
   where f (Card _ col) = Just col

simulate :: Team -> Index -> Skat (Int, Int)
simulate team n = do
    t <- table
    ps <- gets players
    let p = player ps n
    hand <- cardsAt (playerHand $ index p)
    if length hand == 0
        then countGame
        else case length t of
            0 -> playOpen team p >> simulate team (next n)
            1 -> do
                modify (setTurnColour . f . head $ t)
                playOpen team p
                simulate team (next n)
            2 -> playOpen team p >> evaluateTable >>= simulate team
            3 -> evaluateTable >>= simulate team
   where f (Card _ col) = Just col

evaluateTable :: Skat Index
evaluateTable = do
    trumpCol <- gets trumpColour
    turnCol <- gets turnColour
    t <- table
    ts <- tableS
    ps <- gets players
    let psOrdered = playersFromTable ps ts
        l = zip psOrdered t
        g a b = compareCards trumpCol turnCol (snd a) (snd b)
        (winner, _) = last (sortBy g l)
        pile = teamPile $ team winner
    forM t (\c -> move c pile)
    modify $ setTurnColour Nothing
    return $ index winner

countGame :: Skat (Int, Int)
countGame = do
    sgl <- count <$> cardsAt WonSingle
    tm <- count <$> cardsAt WonTeam
    return (sgl, tm)

turn :: Index -> Skat Index
turn n = do
    ps <- gets players
    let p1 = player ps n
        p2 = player ps (next n)
        p3 = player ps (next $ next n)
    c1@(Card _ col) <- play p1
    modify $ setTurnColour (Just col)
    c2 <- play p2
    c3 <- play p3
    trumpCol <- gets trumpColour
    turnCol <- gets turnColour
    let l = zip3 [p1, p2, p3] [c1, c2, c3] [n, next n, next $ next n]
        g a b = compareCards trumpCol turnCol (f a) (f b)
        (winner, _, idx) = last (sortBy g l)
        pile = teamPile $ team winner
    move c1 pile
    move c2 pile
    move c3 pile
    modify $ setTurnColour Nothing
    return idx
 where f (_, x, _) = x

play :: Player -> Skat Card
play p = do
    table <- table
    turnCol <- gets turnColour
    trump <- gets trumpColour
    hand <- cardsAt (playerHand $ index p)
    let card = playCard p table hand trump turnCol
    move card Table
    return card

playOpen :: Team -> Player -> Skat Card
playOpen team p = do
    card <- playCardOpenAI team p
    move card Table
    return card

-- | cheating AI that knows all cards (open play)
playCardOpenAI :: Team -> Player -> Skat Card
playCardOpenAI team p = do
    table <- table
    turnCol <- gets turnColour
    trump <- gets trumpColour
    hand <- cardsAt (playerHand $ index p)
    let possible = filter (isAllowed trump turnCol hand) hand
        ownResult = if team == Single then fst else snd
        ownIdx = index p
    results <- forM possible (\card -> do
        move card Table
        val <- ownResult <$> simulate team ownIdx
        move card (playerHand $ index p)
        return (val, card))
    return $ snd $ maximumBy (comparing fst) results

playCard :: Player
         -> [Card]
         -> [Card]
         -> Colour
         -> Maybe Colour
         -> Card
playCard p table hand trump turnCol = head possible
    where possible = filter (isAllowed trump turnCol hand) hand

runGame :: Skat (Int, Int)
runGame = do
    foldM_ (\i _ -> turn i) One [1..10]
    sgl <- fmap count $ cardsAt WonSingle
    tm <- fmap count $ cardsAt WonTeam
    return (sgl, tm)

shuffleCards :: IO [Card]
shuffleCards = do
    gen <- newStdGen
    return $ shuffle gen allCards

-- TESTING VARS

env :: SkatEnv
env = SkatEnv cards Nothing Spades playersExamp
    where hand1 = take 10 allCards
          hand2 = take 10 $ drop 10 allCards
          hand3 = take 10 $ drop 20 allCards
          skt = drop 30 allCards
          cards = map (putAt Hand1) hand1
               ++ map (putAt Hand2) hand2
               ++ map (putAt Hand3) hand3
               ++ map (putAt WonSingle) skt

playersExamp :: Players
playersExamp = Players (Player Team One) (Player Team Two) (Player Single Three)

shuffledEnv :: IO SkatEnv
shuffledEnv = do
    cards <- shuffleCards
    return $ SkatEnv (distribute cards) Nothing Spades playersExamp

shuffledEnv2 :: IO SkatEnv
shuffledEnv2 = do
    cards <- shuffleCards
    return $ SkatEnv (distributePutSkat cards) Nothing Spades playersExamp