support for tests applying effects

4 files changed, 64 insertions, 19 deletions

diff --git a/src/Main.hs b/src/Main.hs
index 2d9f876..3b7b3f5 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -274,10 +274,10 @@ spawnFaction cFaction num cEntity nameTemplate
 
 -- Dice rolls
 rollTest :: Completable (FormulaM Stats Test) -> Sh GameState ()
-rollTest = withArg $ maybe (return ()) outputResult <=< enactTest'
+rollTest = withArg $ maybe (return ()) ((>>) <$> outputResult <*> applyEffect) <=< enactTest'
   where
     outputResult :: (String, TestResult) -> Sh GameState ()
-    outputResult (test, ppResult -> result) = do
+    outputResult (test, view (rRoll . to ppResult) -> result) = do
       focusId <- use gFocus
       case focusId of
         Nothing -> shellPutStrLn result
@@ -295,6 +295,19 @@ rollTest = withArg $ maybe (return ()) outputResult <=< enactTest'
       | length str >= n = str
       | otherwise = ' ' : pad (n - 1) str
 
+
+    applyEffect :: (String, TestResult) -> Sh GameState ()
+    applyEffect (test, view rResult -> (Effect (CI.original -> effectDesc) effect)) = void . runMaybeT $ do
+      focusId <- MaybeT $ use gFocus
+      name <- toName focusId
+      let
+        lStats :: Traversal' GameState Stats
+        lStats = gEntities . ix focusId . eStats
+        evalF = MaybeT . focusState lStats . evalFormula' [name]
+      guard =<< askBool ("Apply effects (" ++ effectDesc ++ ")?") True
+      lStats <~ (MaybeT . fmap join . runMaybeT $ evalF effect)
+      lift . outputLogged focusId $ test ++ " effects: " ++ effectDesc
+
 enactTest' :: FormulaM Stats Test -> Sh GameState (Maybe (String, TestResult))
 enactTest' test = runMaybeT $ do
   focusName <- MaybeT (use gFocus) >>= lift . toName
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)