From e65e3f11fe911a6ca1009cf35f4b3e7ca907c459 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <pngwjpgh@users.noreply.github.com>
Date: Fri, 12 Aug 2016 16:35:55 +0200
Subject: support for tests applying effects

---
 src/Sequence/Contact/Tests.hs          |  3 +-
 src/Sequence/Contact/Types.hs          | 54 +++++++++++++++++++++++++---------
 src/Sequence/Contact/Types/Internal.hs |  9 ++++--
 3 files changed, 49 insertions(+), 17 deletions(-)

(limited to 'src/Sequence')

diff --git a/src/Sequence/Contact/Tests.hs b/src/Sequence/Contact/Tests.hs
index 2c21834..81b8d3c 100644
--- a/src/Sequence/Contact/Tests.hs
+++ b/src/Sequence/Contact/Tests.hs
@@ -117,7 +117,8 @@ enactTest rawTest = do
       | pw <= bar            = Success
       | pw >= critFailureBar = CritFailure
       | otherwise            = Failure
-  toResult <$> d 100
+  dResult <- toResult <$> d 100
+  TestResult <$> pure dResult <*> (test ^. tEffect) dResult
 
 -- hasTest :: Stats -> String -> Bool
 -- hasTest stats str = has (getTest str) stats
diff --git a/src/Sequence/Contact/Types.hs b/src/Sequence/Contact/Types.hs
index ca7da1f..12283b9 100644
--- a/src/Sequence/Contact/Types.hs
+++ b/src/Sequence/Contact/Types.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE TemplateHaskell, RecordWildCards, OverloadedStrings, OverloadedLists, ViewPatterns, RankNTypes, ImpredicativeTypes, FlexibleContexts, TypeSynonymInstances, FlexibleInstances #-}
+{-# LANGUAGE TemplateHaskell, RecordWildCards, OverloadedStrings, OverloadedLists, ViewPatterns, RankNTypes, ImpredicativeTypes, FlexibleContexts, TypeSynonymInstances, FlexibleInstances, StandaloneDeriving #-}
 
 module Sequence.Contact.Types
   ( module Sequence.Contact.Types
@@ -8,7 +8,7 @@ module Sequence.Contact.Types
 import Sequence.Formula
 
 import Control.Monad
-import Control.Lens
+import Control.Lens hiding (Context)
 
 import Data.Default
 
@@ -25,8 +25,9 @@ import Data.Ratio
 import Data.List
 import Data.Ord
 import Data.ExtendedReal
+import Data.Monoid (Monoid(..), (<>))
 
-import Control.Monad.Reader (ask)
+import Control.Monad.Reader (ask, local)
 import Control.Monad.State
 
 import Sequence.Contact.Types.Internal
@@ -44,18 +45,9 @@ makePrisms ''DamageType
 instance {-# OVERLAPS #-} Default Armor where
   def = const $ return 0
 
-makeLenses ''TestResult
-
-makeLenses ''Test
+makeLenses ''DiceResult
 
-instance Default Test where
-  def = Test
-        { _tName = ""
-        , _tCritSuccessMod = 0
-        , _tCritFailureMod = 0
-        , _tBaseDifficulty = 50
-        , _tMod = 0
-        }
+makeLenses ''TestResult
 
 makePrisms ''Modifier
 
@@ -79,12 +71,46 @@ instance Eq Effect where
 instance Ord Effect where
   compare = compare `on` (view effectName)
 
+instance Show Effect where
+  show = show . view effectName
+
 instance Default Effect where
   def = Effect "" $ preview ctx
 
+instance Monoid Effect where
+  mempty = def
+  (Effect aName aEff) `mappend` (Effect bName bEff) = Effect name $ do
+    new <- aEff
+    maybe
+      (id :: FormulaM Stats (Maybe Stats) -> FormulaM Stats (Maybe Stats))
+      (local :: (Context Stats -> Context Stats) -> FormulaM Stats (Maybe Stats) -> FormulaM Stats (Maybe Stats))
+      (set ctx <$> new :: Maybe (Context Stats -> Context Stats))
+      $ bEff
+    where
+      name
+        | aName /= ""
+        , bName /= "" = aName <> ", " <> bName
+        | otherwise = aName <> bName
+
 effect :: String -> Effect
 effect str = def & set effectName str
 
+makeLenses ''Test
+
+instance Default Test where
+  def = Test
+        { _tName = ""
+        , _tCritSuccessMod = 0
+        , _tCritFailureMod = 0
+        , _tBaseDifficulty = 50
+        , _tMod = 0
+        , _tEffect = const $ pure (def :: Effect)
+        }
+
+deriving instance Eq TestResult
+deriving instance Ord TestResult
+deriving instance Show TestResult
+
 makePrisms ''SeqVal
 makeLenses ''SeqVal
 
diff --git a/src/Sequence/Contact/Types/Internal.hs b/src/Sequence/Contact/Types/Internal.hs
index e9bb268..ca4d022 100644
--- a/src/Sequence/Contact/Types/Internal.hs
+++ b/src/Sequence/Contact/Types/Internal.hs
@@ -50,20 +50,25 @@ data DamageType = Ballistic
                 | Passthrough
   deriving (Eq, Ord, Enum, Bounded, Show)
 
-data TestResult = CritSuccess { _rWith, _rBy :: Int }
+data DiceResult = CritSuccess { _rWith, _rBy :: Int }
                 | Success { _rWith, _rBy :: Int }
                 | Failure { _rWith, _rBy :: Int }
                 | CritFailure { _rWith, _rBy :: Int }
   deriving (Eq, Ord, Show)
 
+data TestResult = TestResult
+                  { _rRoll   :: DiceResult
+                  , _rResult :: Effect
+                  }
+
 data Test = Test
             { _tName :: CI String
             , _tCritSuccessMod
             , _tCritFailureMod
             , _tBaseDifficulty
             , _tMod :: Int
+            , _tEffect :: DiceResult -> FormulaM Stats Effect
             }
-  deriving (Eq, Ord)
 
 data Modifier = Modifier (CI String) (Test -> FormulaM Stats Test)
 
-- 
cgit v1.2.3