trigger effects on taking damage

7 files changed, 62 insertions, 8 deletions

diff --git a/src/Main.hs b/src/Main.hs
index e239bec..de97603 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -252,7 +252,54 @@ addNote :: String -> Sh GameState ()
 addNote note = withFocus $ \focusId -> gEntities . ix focusId . eNotes %= (note :)
 
 takeHit :: Int -> Completable (Set Hitzone) -> Sh GameState ()
-takeHit dmg = withArg $ \zones -> withFocus $ \focusId -> forM_ zones $ \zone -> gEntities . ix focusId . eStats . sDamage . ix zone += dmg
-
+takeHit dmg = withArg $ \zones -> withFocus $ \focusId -> forM_ zones $ \zone -> do
+  let
+    lStats :: Traversal' GameState Stats
+    lStats = gEntities . ix focusId . eStats
+  lStats . sDamage . ix zone += dmg
+  name <- toName focusId
+  void . runMaybeT $ do
+    cripple <- MaybeT . preuse $ lStats . sCripple . ix zone
+    let evalF formula = do
+          stats <- MaybeT $ preuse lStats
+          (nStats, x) <- (evalFormula name :: Stats -> FormulaM Stats a -> MaybeT (Sh GameState) (Stats, a)) stats formula
+          lStats .= nStats
+          return x
+        cVar cLens = evalF =<< MaybeT (preuse $ lStats . (cripple ^. cLens))
+    bar <- cVar seBar
+    val <- cVar seVal
+    reBar <- cVar seReBar
+    if cripple ^. seApplied
+      then guard $ dmg >= reBar
+      else guard $ val >= bar
+    (CI.original -> effectName, effect) <- view _Effect <$> (evalF . table $ cripple ^. seEffect)
+    lStats <~ (MaybeT . fmap join . runMaybeT $ evalF effect)
+    lift $ shellPutStrLn effectName
+    lift . addNote $ "Effect: " ++ effectName
+    
 takeFatigue :: Int -> Sh GameState ()
-takeFatigue dmg = withFocus $ \focusId -> gEntities . ix focusId . eStats . sFatigue += dmg
+takeFatigue dmg = withFocus $ \focusId -> do
+  let
+    lStats :: Traversal' GameState Stats
+    lStats = gEntities . ix focusId . eStats
+  gEntities . ix focusId . eStats . sFatigue += dmg
+  name <- toName focusId
+  void . runMaybeT $ do
+    fShock <- MaybeT . preuse $ lStats . sFatigueShock
+    let evalF formula = do
+          stats <- MaybeT $ preuse lStats
+          (nStats, x) <- (evalFormula name :: Stats -> FormulaM Stats a -> MaybeT (Sh GameState) (Stats, a)) stats formula
+          lStats .= nStats
+          return x
+        fVar cLens = evalF =<< MaybeT (preuse $ lStats . (fShock ^. cLens))
+    bar <- fVar seBar
+    val <- fVar seVal
+    reBar <- fVar seReBar
+    if fShock ^. seApplied
+      then guard $ dmg >= reBar
+      else guard $ val >= bar
+    (CI.original -> effectName, effect) <- view _Effect <$> (evalF . table $ fShock ^. seEffect)
+    lStats <~ (MaybeT . fmap join . runMaybeT $ evalF effect)
+    lift $ shellPutStrLn effectName
+    lift . addNote $ "Effect: " ++ effectName
+    
diff --git a/src/Sequence/Contact/Archetypes.hs b/src/Sequence/Contact/Archetypes.hs
index 30aa2b6..1ad26bb 100644
--- a/src/Sequence/Contact/Archetypes.hs
+++ b/src/Sequence/Contact/Archetypes.hs
@@ -110,6 +110,7 @@ human = Humanoid
         , _sCripple = fromJust . flip Map.lookup [ ("Kopf", def
                                                             & set seVal (sDamage' "Kopf" . to return)
                                                             & set seBar (sMaxVitality . mapping (scaled 0.5))
+                                                            & set seReBar (sMaxVitality . mapping (scaled 0.2))
                                                             & set seEffect (cTable [ (1, 10, Effect "Tod" headshot)
                                                                                    , (11, 25, effect "Blind")
                                                                                    , (26, 35, effect "Blind, Rechts")
diff --git a/src/Sequence/Contact/Types.hs b/src/Sequence/Contact/Types.hs
index 47687b7..9854d92 100644
--- a/src/Sequence/Contact/Types.hs
+++ b/src/Sequence/Contact/Types.hs
@@ -107,6 +107,7 @@ instance Default ShockEffect where
   def = ShockEffect { _seApplied = False
                     , _seVal = ignored
                     , _seBar = ignored
+                    , _seReBar = ignored
                     , _seEffect = def
                     }
 
diff --git a/src/Sequence/Contact/Types/Internal.hs b/src/Sequence/Contact/Types/Internal.hs
index e4a2eef..0fe6266 100644
--- a/src/Sequence/Contact/Types/Internal.hs
+++ b/src/Sequence/Contact/Types/Internal.hs
@@ -55,8 +55,9 @@ data SeqVal = SeqVal
 
 data ShockEffect = ShockEffect
                    { _seApplied :: Bool
-                   , _seVal :: Getting (First (Formula Stats)) Stats (Formula Stats)
-                   , _seBar :: Getting (First (Formula Stats)) Stats (Formula Stats)
+                   , _seVal
+                   , _seBar
+                   , _seReBar :: Getting (First (Formula Stats)) Stats (Formula Stats)
                    , _seEffect :: Table Effect
                    }
 
diff --git a/src/Sequence/Formula.hs b/src/Sequence/Formula.hs
index ca945f8..4f2e61b 100644
--- a/src/Sequence/Formula.hs
+++ b/src/Sequence/Formula.hs
@@ -28,6 +28,7 @@ import Data.Bool
 import Data.List
 import Data.Maybe
 import Data.Either
+import Data.Tuple
 
 import Data.Set (Set)
 import qualified Data.Set as Set
@@ -109,6 +110,9 @@ evalFormula = evalFormula' []
         Left q@(Question{..}) -> askQuestion promptPref input q >>= flip (flip evalFormula' promptPref $ bool (pure . set (ctx' . answer) $ throwError q) mempty keepResult ++ finalChanges) formula
         Right result -> return (foldr ($) input finalChanges, result)
 
+evalFormula' :: (MonadIO m, sInput :<: lInput, MonadState lInput m) => String -> FormulaM sInput a -> m a
+evalFormula' promptPref formula = uncurry (<$) . over _2 put . swap =<< flip (evalFormula promptPref) formula =<< get
+
 val :: Integral a => Traversal' input (Formula input) -> String -> Bool -> Formula input
 val answer prompt keepResult = do
   gets (Set.member prompt) >>= bool (modify $ Set.insert prompt) (modify (Set.delete prompt) >> throwError Question{..})
diff --git a/src/Sequence/Types.hs b/src/Sequence/Types.hs
index 6594f78..59397d5 100644
--- a/src/Sequence/Types.hs
+++ b/src/Sequence/Types.hs
@@ -78,8 +78,8 @@ instance Default Entity where
 eSeqVal :: Lens' Entity (Maybe SeqVal)
 eSeqVal = eStats . sSequence
 
-instance (Entity :<: a) => Stats :<: a where
-  ctx' = ctx' . eStats
+instance Stats :<: Entity where
+  ctx' = eStats
 
 newtype EntityName = EntityName { _entityName :: CI String }
   deriving (Show, Eq, Ord)
diff --git a/src/Sequence/Utils.hs b/src/Sequence/Utils.hs
index bbd1477..8b205ea 100644
--- a/src/Sequence/Utils.hs
+++ b/src/Sequence/Utils.hs
@@ -112,5 +112,5 @@ instance Argument (Set Hitzone) GameState where
       ws = Set.fromList . map CI.mk . filter (not . null) . map trim . split $ protoWs
       hasGlob = Set.member "*" ws
     hitzones <- Set.map (view _Hitzone) . Map.keysSet <$> MaybeT (preuse $ gFocus' . eStats . sHitzones)
-    guard (hasGlob || hitzones `Set.isSubsetOf` ws)
+    guard (hasGlob || ws `Set.isSubsetOf` hitzones)
     return . Set.map (review _Hitzone) $ if hasGlob then hitzones else ws