dovin 3.0 → 3.0.1

raw patch · 5 files changed

+158/−79 lines, 5 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• README.md +4/−3
• dovin.cabal +2/−2
• src/Dovin/Effects.hs +113/−73
• src/Dovin/Types.hs +2/−1
• test/Effects.hs +37/−0

@@ -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: 

@@ -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 <https://github.com/xaviershay/dovin#dovin> category:       Games

@@ -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

@@ -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 =

@@ -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"     ]   ]