packages feed

MTGBuilder 0.1.0.2 → 0.2.0.0

raw patch · 5 files changed

+178/−88 lines, 5 files

Files

MTGBuilder.cabal view
@@ -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
src/MTGBuilder/Deck.hs view
@@ -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)
+ src/MTGBuilder/Options.hs view
@@ -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+}
src/MTGBuilder/Parser.hs view
@@ -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)
src/Main.hs view
@@ -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 ()