diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -115,9 +115,10 @@ ## Development - bin/dev # Launch an interactive REPL - bin/test # Runs all tests and lints - bin/run # Runs all solutions + bin/dev # Launch an interactive REPL + bin/test # Runs all tests and lints + bin/test-repl # Run tests from interactive REPL (use `main`) + bin/run # Runs all solutions New actions go into `Dovin.Actions`. They must: diff --git a/dovin.cabal b/dovin.cabal --- a/dovin.cabal +++ b/dovin.cabal @@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: bc9b329ab69abe923a9afbf06794f3c6f3f53fd4d11f18c48959438b03454875 +-- hash: acba878b2c13fd7c8d9c8f8ab68ce8cf48bd82c440fd2a421f23ead4fc7827ad name: dovin -version: 3.0 +version: 3.0.1 synopsis: A proof assistant for Magic: The Gathering puzzles. description: Please see the README on GitHub at category: Games diff --git a/src/Dovin/Effects.hs b/src/Dovin/Effects.hs --- a/src/Dovin/Effects.hs +++ b/src/Dovin/Effects.hs @@ -1,7 +1,9 @@ {-# LANGUAGE TemplateHaskell #-} {-| -Effects are continuous effects, such as "other creatures get +1/+1". +Effects are continuous effects, such as "other creatures get +1/+1". Note that +dependencies (613.8) are not implemented, and must be emulated with correct +timestamps if needed. They are typically added to a card using 'Dovin.Builder.withEffect' or 'Dovin.Actions.addEffect'. -} @@ -32,16 +34,17 @@ import qualified Data.HashMap.Strict as M import qualified Data.Set as S import Control.Monad.Reader (ask, runReader) -import Control.Monad.State (modify') +import Control.Monad.State (modify', runState, State, get) import Data.Maybe (mapMaybe, catMaybes) -import Data.List (sortOn) +import Data.List (sortOn, partition) +import Data.Tuple (swap) type Pile = [PileEntry] data PileEntry = PileEntry { _peSource :: Card , _peTimestamp :: Timestamp , _peEffect :: [LayeredEffectPart] - , _peAppliesTo :: [CardName] + , _peAppliesTo :: Either (EffectMonad CardMatcher) [CardName] } makeLenses ''PileEntry @@ -139,7 +142,10 @@ -- 3. After the final layer, the pile should be empty. applyEffects :: Board -> Board applyEffects board = - let (newBoard, pile) = foldl resolveLayer (board, mempty) allLayers in + let + f accum v = applyEffectsAtLayer v . collectNewEffectsAtLayer v $ accum + (newBoard, pile) = foldl f (board, mempty) allLayers + in if null pile then newBoard @@ -190,59 +196,24 @@ dup x = (x, x) -resolveLayer :: (Board, Pile) -> Layer -> (Board, Pile) -resolveLayer (board, pile) layer = - let - cs = view resolvedCards board - newEffects = concatMap (extractEffects layer) cs :: Pile - newPile = pile <> newEffects :: Pile - (pile', peel) = peelLayer layer newPile - newBoard = foldl applyEffects board . sortOn (view peTimestamp) $ peel - in - (newBoard, pile') +collectNewEffectsAtLayer :: Layer -> (Board, Pile) -> (Board, Pile) +collectNewEffectsAtLayer layer (board, pile) = + ( + board, + sortOn (view peTimestamp) . (pile <>) . concatMap (extractCardEffects layer) . view resolvedCards $ board + ) where - -- Take a PileEntry and apply it to the board state. It is assumed that it - -- has already been filtered to a single layer. - applyEffects :: Board -> PileEntry -> Board - applyEffects board pe = - let - cs = mapMaybe (\cn -> M.lookup cn (view resolvedCards board)) - . view peAppliesTo - $ pe :: [Card] - newCards = map - (applyEffectParts (view peSource pe) (view peEffect pe)) - cs - in - - over - resolvedCards - (M.union . M.fromList . map (\c -> (view cardName c, c)) $ newCards) - board - - applyEffectParts source es target = - foldl - (\t (LayeredEffectPart _ effect) -> - runReader (effect t) (board, source)) - target - es - -- Find all effects on a card that begin applying at the given layer. - extractEffects :: Layer -> Card -> Pile - extractEffects layer c = + extractCardEffects :: Layer -> Card -> Pile + extractCardEffects layer c = let passiveEffects = - map toPileEntry + map ldToPileEntry . view cardPassiveEffects $ c abilityEffects = - map (\(AbilityEffect t _ es) -> - PileEntry { - _peSource = c, - _peTimestamp = t, - _peEffect = es, - _peAppliesTo = [view cardName c] - }) + map aeToPileEntry . view cardAbilityEffects $ c in @@ -252,35 +223,104 @@ (passiveEffects <> abilityEffects) where - extractLayer (LayeredEffectPart l _) = l - - toPileEntry :: LayeredEffectDefinition -> PileEntry - toPileEntry ld = - let - matcher = runReader (view leAppliesTo ld) (board, c) - cs' = - filter - (applyMatcher matcher) - (M.elems . view resolvedCards $ board) - in + aeToPileEntry :: AbilityEffect -> PileEntry + aeToPileEntry (AbilityEffect t _ es) = + PileEntry { + _peSource = c, + _peTimestamp = t, + _peEffect = es, + _peAppliesTo = Right [view cardName c] + } + ldToPileEntry :: LayeredEffectDefinition -> PileEntry + ldToPileEntry ld = PileEntry { _peSource = c, _peTimestamp = view cardTimestamp c, _peEffect = view leEffect ld, - _peAppliesTo = map (view cardName) cs' + _peAppliesTo = Left (view leAppliesTo ld) } --- Return two piles, the second including every effect part that applies at --- this layer, the first with all the remaining. Removes any entries that no --- longer have any effect parts remaining to apply. -peelLayer :: Layer -> Pile -> (Pile, Pile) -peelLayer layer pile = - (f not pile, f id pile) +-- Apply all effects in the pile to the board for the given layer. +applyEffectsAtLayer :: Layer -> (Board, Pile) -> (Board, Pile) +applyEffectsAtLayer layer (board, pile) = + -- Iterate over all pile entries and attempt to apply/reduce them + swap . runState (catMaybes <$> mapM (applyEntry layer) pile) $ board + where - f g = - filter (not . null . view peEffect) - . map (over peEffect (filter $ g . isLayer layer)) + -- Apply (and remove) any effect parts (may be none) in the entry for the + -- current layer. If this is the first time a part would apply for this + -- effect, also resolve the CardMatcher to determine the set of cards to + -- apply to. + -- + -- The use of State monad here is perhaps a little weird, but was the best + -- I could come with to structure the code. + applyEntry :: Layer -> PileEntry -> State Board (Maybe PileEntry) + applyEntry layer pe = do + -- Split the remaining entry effects into those that apply in the current + -- layer, and those that don't. + let (parts, remainder) = partition (isLayer layer) (view peEffect pe) - isLayer :: Layer -> LayeredEffectPart -> Bool - isLayer l1 (LayeredEffectPart l2 _) = l1 == l2 + if null parts then + -- If no parts apply at current layer, there is nothing to be done. + return (Just pe) + else do + board <- get + + let effectEnv = (board, view peSource pe) + + -- If the entire effect hasn't previously decided which set of cards to + -- apply to, it does so here. + let cns = either (resolveAppliesTo effectEnv) id (view peAppliesTo pe) + + -- Look up the affected cards in the current board state. + let cs = mapMaybe (\cn -> M.lookup cn (view resolvedCards board)) cns + + when (length cs /= length cns) + -- Since SBEs don't apply while we are applying effects, there should + -- be no opportunity for a card to be removed. + (error "assertion failed: effected card did not exist on board") + + -- Apply the effect part to the matched cards + let newCs = map (applyEffectParts effectEnv parts) cs + + -- Update the board state with the newly updated cards. + modifying + resolvedCards + (M.union . M.fromList . indexBy (view cardName) $ newCs) + + return $ + if null remainder then + Nothing + else + Just + -- The set of cards needs to be cached here for use by future + -- parts. It should not be recalculated per 613.6. + . set peAppliesTo (Right cns) + -- We also remove the applied parts (the current layer) from the + -- effect. + . set peEffect remainder + $ pe + + resolveAppliesTo :: EffectMonadEnv -> EffectMonad CardMatcher -> [CardName] + resolveAppliesTo (board, source) m = + map (view cardName) + . filter (applyMatcher $ runReader m (board, source)) + . M.elems + . view resolvedCards + $ board + + applyEffectParts :: EffectMonadEnv -> [LayeredEffectPart] -> Card -> Card + applyEffectParts env es target = + foldl + (\t (LayeredEffectPart _ eff) -> runReader (eff t) env) + target + es + +indexBy :: (a -> b) -> [a] -> [(b, a)] +indexBy f = map ((,) <$> f <*> id) + +extractLayer (LayeredEffectPart l _) = l + +isLayer :: Layer -> LayeredEffectPart -> Bool +isLayer l p = l == extractLayer p diff --git a/src/Dovin/Types.hs b/src/Dovin/Types.hs --- a/src/Dovin/Types.hs +++ b/src/Dovin/Types.hs @@ -36,7 +36,8 @@ } -- A monad for writing effect definitions. -type EffectMonad a = Reader (Board, Card) a +type EffectMonadEnv = (Board, Card) +type EffectMonad a = Reader EffectMonadEnv a -- These layers line up to those specified in the official rules (613). data Layer = diff --git a/test/Effects.hs b/test/Effects.hs --- a/test/Effects.hs +++ b/test/Effects.hs @@ -75,6 +75,21 @@ validate (matchStrength (3, 3)) "Drover of the Mighty" ] + , testGroup "Comprehensive rules, 613.6" + [ prove "Non-creature artifacts" $ do + withLocation Play $ do + addArtifact "Artifact" + + withEffect + (pure $ matchAttribute artifact <> invert (matchAttribute creature)) + [ effectAddType creature + , effectPTSet (2, 2) + ] + "All non-creature artifacts become 2/2 artifact creatures" $ + addEnchantment "Enchantment" + + validate (matchStrength (2, 2)) "Artifact" + ] -- https://blogs.magicjudges.org/ftw/l2-prep/rules-and-policy/continuous-effects/ , testGroup "effects (magic judges examples)" [ prove "Humble & Godhead of Awe" $ do @@ -132,5 +147,27 @@ addEnchantment "Humility" validate (matchStrength (0, 1)) "Humility" + , prove "Conspiracy & Life and Limb" $ do + withLocation Play $ do + let saproling = "saproling" + + withEffect + (pure $ matchAttribute creature) + [ effectAddType saproling + ] + "Creatures are saprolings" $ + addEnchantment "Life and Limb" + + withEffect + (pure $ matchAttribute saproling) + [ effectAddType land + , effectPTSet (1, 1) + ] + "Forests and saprolings are 1/1 saprolings and lands" $ + addEnchantment "Conspiracy" + + addCreature (2, 2) "Gutter Skulk" + + validate (matchAttribute land) "Gutter Skulk" ] ]