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