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.2 +version: 0.2.0.0 synopsis: Builds decks out of a meta -- description: license: MIT @@ -21,6 +21,7 @@ MTGBuilder.Deck MTGBuilder.Combination MTGBuilder.Parser + MTGBuilder.Options -- other-extensions: build-depends: base >=4.8 && <4.9 diff --git a/src/MTGBuilder/Deck.hs b/src/MTGBuilder/Deck.hs --- a/src/MTGBuilder/Deck.hs +++ b/src/MTGBuilder/Deck.hs @@ -2,6 +2,7 @@ module MTGBuilder.Deck ( makeRanking, + composeAdditive, composeDecks, dumpDeck, dumpRanking, @@ -11,20 +12,29 @@ ) 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 -} deriving (Show, Eq, Ord) + 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 {- @@ -49,19 +59,22 @@ data Ranking = MkRanking { interaction :: Map (Set Card) Int, - interactionSize :: 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 Bool IO Ranking +makeRanking :: Int -> [(String, Deck)] -> ReaderT Options IO Ranking makeRanking size inputDecks = do - verbose <- ask - rankDecks MkRanking { interaction=Map.empty, interactionSize=size } inputDecks + 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 Bool IO Ranking + rankDecks :: Ranking -> [(String, Deck)] -> ReaderT Options IO Ranking rankDecks ranking [] = return ranking rankDecks ranking ((name, deck):decks) = do - verbose <- ask + Options {optVerbose=verbose} <- ask when verbose (liftIO $ hPutStrLn stderr $ "Ranking " ++ name) rankDecks (ranking { interaction=int }) decks where @@ -73,18 +86,23 @@ dumpDeck deck = intercalate "\n" lines where lines :: [String] - lines = fmap (\(cardName, count) -> (show count) ++ " " ++ cardName) (Map.assocs getMap) + lines = fmap (line) (Map.toList getMap) where - getMap :: Map String Int + 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 (+) (name card) 1 map) + 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.assocs $ interaction ranking + 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, @@ -95,17 +113,28 @@ 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 +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 :: Deck -> ReaderT Bool IO Deck - compose cards - | Set.size sorted <= deckSize = return $ Set.map snd sorted + compose :: (Int, Int) -> Deck -> ReaderT Options IO Deck + compose (main, side) cards + | main <= mainSize && side <= sideSize = return cards | 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 + 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) @@ -127,3 +156,43 @@ 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) diff --git a/src/MTGBuilder/Options.hs b/src/MTGBuilder/Options.hs new file mode 100644 --- /dev/null +++ b/src/MTGBuilder/Options.hs @@ -0,0 +1,12 @@ +module MTGBuilder.Options where + +import System.IO + +data Options = Options { + optVerbose :: Bool, + optWriteRanking :: String -> IO (), + optOutput :: Handle, + optInputSeed :: Maybe String, + optSubtractive :: Bool, + optPrecision :: Int +} diff --git a/src/MTGBuilder/Parser.hs b/src/MTGBuilder/Parser.hs --- a/src/MTGBuilder/Parser.hs +++ b/src/MTGBuilder/Parser.hs @@ -1,12 +1,17 @@ module MTGBuilder.Parser ( deckParser, parseDeckString, - parseDeckFile + parseDeckFile, + parseDeckFileOrFail ) where import MTGBuilder.Deck +import MTGBuilder.Options +import System.IO import Control.Monad -import Data.Set +import Control.Monad.Reader +import Data.Set (Set) +import qualified Data.Set as Set import Text.ParserCombinators.Parsec import Text.ParserCombinators.Parsec.Language import qualified Text.ParserCombinators.Parsec.Token as Token @@ -30,37 +35,44 @@ deckParser :: Parser Deck deckParser = do whiteSpace - d <- deck - optionMaybe sideboard - return d + Set.union <$> deck <*> option Set.empty sideboard deck :: Parser Deck -deck = do - cards <- many cardParser - return $ unions cards +deck = Set.unions <$> (many $ try cardParser) cardParser :: Parser (Set Card) -cardParser = lexeme (mainboardCard <|> (sideboardCard >> return empty)) +cardParser = lexeme (mainboardCard <|> sideboardCard) 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]] + return $ Set.fromList [MkCard {name=name,copy=fromIntegral n,isSideboard=False} | n <- [1..numCopies]] where endOfCard = (endOfLine >> return ()) <|> eof -sideboardCard :: Parser () +setSideboard :: Card -> Card +setSideboard card = card {isSideboard = True} + +sideboardCard :: Parser (Set Card) sideboardCard = do symbol "SB:" - mainboardCard - return () + Set.map setSideboard <$> mainboardCard -sideboard :: Parser () +sideboard :: Parser Deck sideboard = do reserved "sideboard" - deck - return () + Set.map setSideboard <$> deck parseDeckString = parse deckParser parseDeckFile = parseFromFile deckParser + +parseDeckFileOrFail :: String -> ReaderT Options IO (String, Deck) +parseDeckFileOrFail file = do + Options {optVerbose=verbose} <- ask + when verbose $ liftIO $ hPutStrLn stderr ("Parsing deck: " ++ file) + result <- liftIO $ parseDeckFile file + case result of + Left err -> fail $ show err + Right deck -> do + return (file, deck) diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -10,16 +10,11 @@ import Control.Monad.Reader import MTGBuilder.Deck import MTGBuilder.Parser +import MTGBuilder.Options +import Data.Maybe import Data.Set (Set) import qualified Data.Set as Set -data Options = Options { - optVerbose :: Bool, - optWriteRanking :: String -> IO (), - optOutput :: Handle, - optPrecision :: Int -} - options :: [OptDescr (Options -> IO Options)] options = [ Option "o" ["output"] @@ -29,31 +24,42 @@ return opt { optOutput = handle }) "FILE") "Output file" - + + , Option "i" ["input-seed"] + (ReqArg + (\arg opt -> return opt { optInputSeed = Just arg }) + "FILE") + "Input seed file. Only applicable for the additive algorithm" + , Option "r" ["ranking"] (ReqArg (\arg opt -> return opt { optPrecision = read arg }) "NUMBER") "Order of rankings to compose the input decks with" - - , Option "f" ["rankingFile"] + + , Option "f" ["ranking-file"] (ReqArg (\arg opt -> return opt { optWriteRanking = writeFile arg }) "FILE") "File to save ranking information to (mostly for debug info)" - + , Option "v" ["verbose"] (NoArg (\opt -> return opt { optVerbose = True })) "Enable verbose messages" - + + , Option "s" ["subtractive"] + (NoArg + (\opt -> return opt { optSubtractive = True })) + "Use the subtractive algorithm" + , Option "V" ["version"] (NoArg (\_ -> do hPutStrLn stderr "Version 0.1.0.0" exitWith ExitSuccess)) "Print version" - + , Option "h" ["help"] (NoArg (\_ -> do @@ -65,54 +71,44 @@ startOptions :: Options startOptions = Options { optVerbose = False, - optWriteRanking = (\s -> return ()), + optWriteRanking = (\s -> return ()), optOutput = stdout, - optPrecision = 2 -- Default to only second order rankings + optInputSeed = Nothing, + optSubtractive = False, + optPrecision = 3 -- Default to only third order rankings } main = do - args <- getArgs - -- Parse options, getting a list of option actions and input deck files - let (actions, nonOptions, errors) = getOpt RequireOrder options args + (actions, nonOptions, errors) <- getArgs >>= return . getOpt RequireOrder options -- Thread startOptions through all supplied option actions opts <- foldl (>>=) (return startOptions) actions - - let Options { + runReaderT (run nonOptions) opts + +run :: [String] -> ReaderT Options IO () +run files = do + Options { optVerbose = verbose, optWriteRanking = writeRanking, optOutput = output, + optInputSeed = inputSeed, + optSubtractive = subtractive, optPrecision = precision - } = opts - - -- Produce a list of IO (name, contents) - let input = sequence $ case nonOptions of - [] -> [getContents >>= \s -> return ("stdin", s)] - inputs -> fmap (\i -> readFile i >>= \s -> return (i, s)) inputs - + } <- ask -- =) - when verbose (hPutStrLn stderr "Hello!") - - - deckNamesAndContents <- input - namedDecks <- forM deckNamesAndContents (\(name, source) -> case parseDeckString name source of - Left err -> fail $ show err - Right deck -> do - when verbose (hPutStrLn stderr ("Parsing deck: " ++ name)) - return (name, deck)) - - let decks = fmap snd namedDecks - - -- Produce the rank mappings - ranking <- runReaderT (makeRanking precision namedDecks) verbose - writeRanking $ dumpRanking ranking - - -- Compose the decks into the aggregate deck - deck <- runReaderT (composeDecks ranking 60 decks) verbose - when verbose $ hPutStrLn stderr ("Final size: " ++ (show $ Set.size deck)) + when verbose $ liftIO $ hPutStrLn stderr "Hello!" + namedDecks <- sequence $ fmap parseDeckFileOrFail files + ranking <- makeRanking precision namedDecks + liftIO $ writeRanking $ dumpRanking ranking + deck <- if subtractive + then composeDecks ranking (60, 15) + else + let seedM = fromMaybe (return Set.empty) $ fmap ((fmap snd) . parseDeckFileOrFail) inputSeed + in seedM >>= composeAdditive ranking (60, 15) + when verbose $ liftIO $ hPutStrLn stderr ("Final size: " ++ (show $ Set.size deck)) let dump = dumpDeck deck - hPutStrLn output dump - when verbose $ hPutStrLn stderr $ dump - hClose output + liftIO $ hPutStrLn output dump + when verbose $ liftIO $ hPutStrLn stderr dump + liftIO $ hClose output return ()