diff --git a/MTGBuilder.cabal b/MTGBuilder.cabal --- a/MTGBuilder.cabal +++ b/MTGBuilder.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: MTGBuilder -version: 0.1.0.0 +version: 0.1.0.1 synopsis: Builds decks out of a meta -- description: license: MIT @@ -17,7 +17,10 @@ executable mtg-builder main-is: Main.hs - -- other-modules: + other-modules: + MTGBuilder.Deck + MTGBuilder.Combination + MTGBuilder.Parser -- other-extensions: build-depends: base >=4.8 && <4.9 diff --git a/src/MTGBuilder/Combination.hs b/src/MTGBuilder/Combination.hs new file mode 100644 --- /dev/null +++ b/src/MTGBuilder/Combination.hs @@ -0,0 +1,14 @@ +module MTGBuilder.Combination where + +import Data.Set (Set) +import qualified Data.Set as Set + +combinations :: Ord a => Int -> Set a -> Set (Set a) +combinations k xs = combinations' (Set.size xs) k xs + where combinations' n k' s + | k' == 0 = Set.singleton (Set.empty) + | k' >= n = Set.singleton (s) + | null s = Set.empty + | otherwise = case Set.minView s of + Just (y, ys) -> Set.map (Set.insert y) (combinations' (n-1) (k'-1) ys) `Set.union` combinations' (n-1) k' ys + Nothing -> error "Invalid empty set" diff --git a/src/MTGBuilder/Deck.hs b/src/MTGBuilder/Deck.hs new file mode 100644 --- /dev/null +++ b/src/MTGBuilder/Deck.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE BangPatterns #-} + +module MTGBuilder.Deck ( + makeRanking, + composeDecks, + dumpDeck, + dumpRanking, + Ranking, + Card(..), + Deck +) where + +import MTGBuilder.Combination +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 Control.Monad.Reader +import System.IO + +data Card = MkCard { + name :: String, + copy :: Int +} deriving (Show, Eq, Ord) + +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 +} + +-- 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 Bool IO Ranking +makeRanking size inputDecks = do + verbose <- ask + rankDecks MkRanking { interaction=Map.empty, interactionSize=size } inputDecks + where + rankDecks :: Ranking -> [(String, Deck)] -> ReaderT Bool IO Ranking + rankDecks ranking [] = return ranking + rankDecks ranking ((name, deck):decks) = do + 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 (\(cardName, count) -> (show count) ++ " " ++ cardName) (Map.assocs getMap) + where + getMap :: Map String Int + getMap = foldl f Map.empty deck + where + f = (\map card -> Map.insertWith (+) (name card) 1 map) + +dumpRanking :: Ranking -> String +dumpRanking ranking = intercalate "\n" lines + where + lines :: [String] + lines = fmap (\(combo, count) -> (show count) ++ " : " ++ (show combo)) $ Map.assocs $ 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 -> [Deck] -> ReaderT Bool IO Deck +composeDecks ranking deckSize decks = compose $ Set.unions decks + where + compose :: Deck -> ReaderT Bool IO Deck + compose cards + | Set.size sorted <= deckSize = return $ Set.map snd sorted + | otherwise = do + verbose <- ask + when verbose $ liftIO $ hPutStrLn stderr (show $ Set.size sorted) + compose $ Set.map snd $ fromMaybe Set.empty $ fmap snd $ Set.minView sorted + where sorted = sortWithRanking ranking cards + +-- 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) diff --git a/src/MTGBuilder/Parser.hs b/src/MTGBuilder/Parser.hs new file mode 100644 --- /dev/null +++ b/src/MTGBuilder/Parser.hs @@ -0,0 +1,66 @@ +module MTGBuilder.Parser ( + deckParser, + parseDeckString, + parseDeckFile +) where + +import MTGBuilder.Deck +import Control.Monad +import Data.Set +import Text.ParserCombinators.Parsec +import Text.ParserCombinators.Parsec.Language +import qualified Text.ParserCombinators.Parsec.Token as Token +import Text.Parsec.Char +import Text.ParserCombinators.Parsec.Combinator + +deckTokens = Token.makeTokenParser $ emptyDef { + identStart = alphaNum <|> char '_', + commentLine = "//", + caseSensitive = False +} + +identifier = Token.identifier deckTokens +lexeme = Token.lexeme deckTokens +reserved = Token.reserved deckTokens +symbol = Token.symbol deckTokens +natural = Token.natural deckTokens +brackets = Token.brackets deckTokens +whiteSpace = Token.whiteSpace deckTokens + +deckParser :: Parser Deck +deckParser = do + whiteSpace + d <- deck + optionMaybe sideboard + return d + +deck :: Parser Deck +deck = do + cards <- many cardParser + return $ unions cards + +cardParser :: Parser (Set Card) +cardParser = lexeme (mainboardCard <|> (sideboardCard >> return empty)) + +mainboardCard :: Parser (Set Card) +mainboardCard = do + numCopies <- natural + set <- optionMaybe $ brackets $ optionMaybe identifier + name <- manyTill anyChar endOfCard + return $ fromList [MkCard {name=name,copy=fromIntegral n} | n <- [1..numCopies]] + where endOfCard = (endOfLine >> return ()) <|> eof + +sideboardCard :: Parser () +sideboardCard = do + symbol "SB:" + mainboardCard + return () + +sideboard :: Parser () +sideboard = do + reserved "sideboard" + deck + return () + +parseDeckString = parse deckParser +parseDeckFile = parseFromFile deckParser