Deck.hs

{-# LANGUAGE BangPatterns #-}

module MTGBuilder.Deck (
    makeRanking,
    composeAdditive,
    composeDecks,
    dumpDeck,
    dumpRanking,
    Ranking,
    Card(..),
    Deck
) where

import MTGBuilder.Combination
import MTGBuilder.Options
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe
import Data.List
import Data.Tuple
import Control.Monad.Reader
import Control.Monad.State
import System.IO

data Card = MkCard {
    name        :: String,
    copy        :: Int,
    isSideboard :: Bool
} deriving (Eq, Ord)

instance Show Card where
    show c
        | isSideboard c = "SB: " ++ (name c) ++ " #" ++ (show $ copy c)
        | otherwise =               (name c) ++ " #" ++ (show $ copy c)

type Deck = Set Card

{-
The ranking is the most important data structure

http://www.channelfireball.com/articles/magic-math-a-new-way-to-determine-an-aggregate-deck-list-rg-dragons/

Frank Karsten's algorithm is an example of building a deck based soley on first order rankings.

An Nth order ranking is the popularty of a particular combination of N cards.
If six of the input decks run Bolt1+Snapcaster1, that combination gets a score of 6.

The interaction field is the map of all combinations found in any input deck,
and the number of decks that have that combination.

The interactionSize field is the maximum order of rank.
This is used to throttle the computational expense, at the cost of precision.
Precision beyond 3rd order likely isn't necessary.
2nd order is enough for most cases.
1st order is exactly Karsten's algorithm, and is only good enough for single-archetype aggregations.
-}

data Ranking = MkRanking {
    interaction :: Map (Set Card) Int,
    interactionSize :: Int,
    inputDecks :: [Deck],
    inputCards :: Deck
}

-- The return type of this function is a reader over IO so that verbosity can be read, and verbose messages can be printed
makeRanking :: Int -> [(String, Deck)] -> ReaderT Options IO Ranking
makeRanking size inputDecks = do
    Options {optVerbose=verbose} <- ask
    let inputs = fmap snd inputDecks
    rankDecks MkRanking { interaction=Map.empty, interactionSize=size, inputDecks=inputs, inputCards=Set.unions inputs } inputDecks
    where
        rankDecks :: Ranking -> [(String, Deck)] -> ReaderT Options IO Ranking
        rankDecks ranking [] = return ranking
        rankDecks ranking ((name, deck):decks) = do
            Options {optVerbose=verbose} <- ask
            when verbose (liftIO $ hPutStrLn stderr $ "Ranking " ++ name)
            rankDecks (ranking { interaction=int }) decks
            where
                !int = -- Strict, because it will be fully evaluated anyway, and this provides more realistic verbose messages.
                    let f map x = Map.insertWith (+) x 1 map
                    in  foldl f (interaction ranking) $ Set.unions [combinations n deck | n <- [1..(interactionSize ranking)]]

dumpDeck :: Deck -> String
dumpDeck deck = intercalate "\n" lines
    where
        lines :: [String]
        lines = fmap (line) (Map.toList getMap)
            where
                line :: ((Bool, String), Int) -> String
                line ((isSide, cardName), count)
                    | isSide = "SB: " ++ (show count) ++ " " ++ cardName
                    | otherwise =        (show count) ++ " " ++ cardName
                getMap :: Map (Bool, String) Int
                getMap = foldl f Map.empty deck
                    where
                        f = (\map card -> Map.insertWith (+) (isSideboard card, name card) 1 map)

dumpRanking :: Ranking -> String
dumpRanking ranking = intercalate "\n" lines
    where
        lines :: [String]
        lines = fmap (\(combo, count) -> (show count) ++ " : " ++ (show combo)) $ Map.toList $ interaction ranking

{-
Composition combines all the input decks.
Note: Although different copies of the same card are treated as different cards in this algorithm,
the same copies of the same card from different decks are treated as the same.
So when we union the decks, we are merely merging all the cards in all decks.
So if two decks each have 4 Bolts, we still only see 4 Bolts in the union.

Composing decks simply sorts the cards in the union by sortWithRanking,
then removes the lowest ranked card, then repeats until the deck is down to the provided size.
-}
composeDecks :: Ranking -> (Int, Int) -> ReaderT Options IO Deck
composeDecks ranking (mainSize, sideSize) =
    let startSize = foldl (\(m, s) c -> if isSideboard c then (m, s + 1) else (m + 1, s)) (0, 0) $ inputCards ranking
    in  compose startSize $ Set.unions $ inputDecks ranking
    where
        compose :: (Int, Int) -> Deck -> ReaderT Options IO Deck
        compose (main, side) cards
            | main <= mainSize && side <= sideSize = return cards
            | otherwise = do
                Options {optVerbose=verbose} <- ask
                when verbose $ liftIO $ hPutStrLn stderr $ show $ Set.size cards
                when verbose $ liftIO $ hPutStrLn stderr $ show (worstRank, worstCard)
                compose newSize (worstCard `Set.delete` cards)
            where
                newSize
                    | isSideboard worstCard = (main, side - 1) 
                    | otherwise = (main - 1, side)
                (worstRank, worstCard) = head $ Set.toList sorted
                sorted = Set.filter filt $ sortWithRanking ranking cards
                filt (_, card)
                    | (side <= sideSize && isSideboard card) || (main <= mainSize && not (isSideboard card)) = False
                    | otherwise = True

-- Each card in the set is ranked.
sortWithRanking :: Ranking -> Set Card -> Set (Double, Card)
sortWithRanking ranking deck = Map.foldlWithKey (\set card rank -> Set.insert (rank, card) set) Set.empty rankMap
    where
        rankMap = Map.foldlWithKey rankCombo Map.empty $ interaction ranking
        rankCombo map combo count
            | combo `Set.isSubsetOf` deck = foldl (\m card -> Map.insertWith (+) card rank m) map combo
            | otherwise = map
            where
                {-
                To rank a card, look at each combination in the ranking.
                For each combination that contains the card, and is a subset of the deck,
                add to the card's ranking the following:

                    (popularity of combo) * 1 / (2 ^ order of combo)

                This way, lower orders are considered more important,
                thus the popularity of the card on its own (first order combination) is most important
                -}
                rank = (fromIntegral count) * 1.0 / (2.0 ^ Set.size combo)

{-
Addititive composition is similar to subtractive composition.
This new algorithm will be the new default, due to it's performance gains and added capabilities.

Rather than starting with the collective and working down,
start with nothing (or something) and work up.
That is, find the card that adds the most to the deck, and add that to it.

An advantage of this algorithm is that you can provide a starting state,
which allows you to specify cards you want the deck to be built around.
-}
composeAdditive :: Ranking -> (Int, Int) -> Deck -> ReaderT Options IO Deck
composeAdditive ranking (mainSize, sideSize) startDeck =
    let startState = foldl (\(m, s) c -> if isSideboard c then (m, s + 1) else (m + 1, s)) (0, 0) startDeck
    in  composeAdditive' startState startDeck
    where
        composeAdditive' :: (Int, Int) -> Deck -> ReaderT Options IO Deck
        composeAdditive' (main, side) deck
            | main >= mainSize && side >= sideSize = return deck
            | otherwise = do
                Options {optVerbose=verbose} <- ask
                when verbose $ liftIO $ hPutStrLn stderr $ show $ Set.size deck
                when verbose $ liftIO $ hPutStrLn stderr $ show (bestRank, bestCard)
                composeAdditive' newSize (bestCard `Set.insert` deck)
            where
                newSize
                    | isSideboard bestCard = (main, side + 1) 
                    | otherwise = (main + 1, side)
                (bestRank, bestCard) = head $ sortBy (flip compare) $ fmap swap $ Map.toList rankMap
                rankMap = Map.filterWithKey filt $ Map.foldlWithKey rankCombo Map.empty $ interaction ranking
                filt card r
                    | (side >= sideSize && isSideboard card) || (main >= mainSize && not (isSideboard card)) = False
                    | otherwise = True
                rankCombo map combo count
                    | Set.size dif == 1 = Map.insertWith (+) (Set.elemAt 0 dif) rank map
                    | otherwise = map
                    where
                        dif = combo `Set.difference` deck
                        rank = (fromIntegral count) * 1.0 / (2.0 ^ Set.size combo)