Burstfirerewrite

4 files changed, 96 insertions, 47 deletions

diff --git a/src/Sequence/Contact/Archetypes.hs b/src/Sequence/Contact/Archetypes.hs
index b8bc1b0..566d72d 100644
--- a/src/Sequence/Contact/Archetypes.hs
+++ b/src/Sequence/Contact/Archetypes.hs
@@ -75,11 +75,8 @@ archetypes = [ ("Requisite", prop)
              , ("AUV", auv)
              ]
 
-cTable :: Ord v => [(Integer, Integer, v)] -> Table v
-cTable = Map.fromList . map (\(from, to, value) -> (value, (abs (to - from) + 1) % 100))
-
 death :: Hitzone -> Effect
-death zone = Effect "Tod" . runMaybeT $ do
+death zone = Effect "Tod" $ do
   maxVitality <- (MaybeT . preview $ ctx . sMaxVitality) >>= lift
   currentDmg <- MaybeT . preview $ ctx . sDamage' zone
   allDmg <- MaybeT . preview $ ctx . sTotalDamage
@@ -87,16 +84,16 @@ death zone = Effect "Tod" . runMaybeT $ do
       dmg' = if dmg >= 0 then dmg else 0
   MaybeT . previews ctx $ set (sDamage' zone) dmg'
 
-unconsciousR :: Formula Stats -> FormulaM Stats (Maybe Stats)
+unconsciousR :: Formula Stats -> FormulaMT MaybeT Stats Stats
 unconsciousR roundsF = do
-  rounds <- roundsF
-  previews ctx $ over (sSequence . _Just . seqRound . _Wrapped) (+ rounds)
+  rounds <- lift roundsF
+  MaybeT . previews ctx $ over (sSequence . _Just . seqRound . _Wrapped) (+ rounds)
 
-unconscious :: FormulaM Stats (Maybe Stats)
-unconscious = previews ctx $ set sSequence Nothing
+unconscious :: FormulaMT MaybeT Stats Stats
+unconscious = MaybeT . previews ctx $ set sSequence Nothing
 
 amputate :: Hitzone -> Effect
-amputate zone = Effect (CI.mk $ review hitzone zone ++ " ist verloren") . runMaybeT $ do
+amputate zone = Effect (CI.mk $ review hitzone zone ++ " ist verloren") $ do
   hitzones <- MaybeT . preview $ ctx . sHitzones
   (fromRational -> zoneProp) <- MaybeT . return $ Map.lookup zone hitzones
   MaybeT . previews ctx . execState $ do
@@ -221,7 +218,7 @@ human = Humanoid
                                       & set seBar (vitBar 0.75)
                                       & set seReBar (vitBar 0.2)
                                       & set seEffect (cTable [ (1, 5, death "Torso")
-                                                             , (6, 25, Effect "Organschäden" . previews ctx $ over sFatigue (+ 25) . over (sDamage' "Torso") (+ 10))
+                                                             , (6, 25, Effect "Organschäden" . MaybeT . previews ctx $ over sFatigue (+ 25) . over (sDamage' "Torso") (+ 10))
                                                              , (26, 45, effect "Innere Blutung (3 Schaden (Au) Minuten)")
                                                              , (46, 75, Effect "Bewusstlos" unconscious)
                                                              , (76, 100, Effect "Bewusstlos" . unconsciousR $ d 10)
@@ -234,7 +231,7 @@ human = Humanoid
                                           & set seBar (vitBar 0.2)
                                           & set seReBar (vitBar 0.2)
                                           & set seEffect ( cTable [ (1, 5, effect "Querschnittsgelähmt")
-                                                                  , (6, 25, Effect "Kastration" . previews ctx $ over sFatigue (+ 15))
+                                                                  , (6, 25, Effect "Kastration" . MaybeT . previews ctx $ over sFatigue (+ 15))
                                                                   , (26, 50, effect "Innere Blutung (2 Schaden (Au) Minuten)")
                                                                   , (51, 100, Effect "Bewusstlos" unconscious)
                                                                   ])
@@ -255,14 +252,14 @@ human = Humanoid
                                                 , (6, 25, Effect "Koma" unconscious)
                                                 , (26, 45, Effect "Bewusstlos" . unconsciousR $ d 10)
                                                 , (46, 75, Effect "Bewusstlos" unconscious)
-                                                , (76, 100, Effect "Verlangsamt" $ d 10 >>= (\loss -> previews ctx $ over (sSequence . _Just . seqVal . _Just) (+ (-loss))))
+                                                , (76, 100, Effect "Verlangsamt" $ lift (d 10) >>= (\loss -> MaybeT . previews ctx $ over (sSequence . _Just . seqVal . _Just) (+ (-loss))))
                                                 ])
         , _sFatigueShock = def
                            & set seReBar (vitBar 0.75)
                            & set seEffect ( cTable [ (1, 25, Effect "Bewusstlos" . unconsciousR $ 2 * d 10)
                                                    , (26, 50, Effect "Bewusstlos" . unconsciousR $ d 10)
                                                    , (51, 75, Effect "Bewusstlos" unconscious)
-                                                   , (76, 100, Effect "Verlangsamt" $ 2 * d 10 >>= (\loss -> previews ctx $ over (sSequence . _Just . seqVal . _Just) (+ (-loss))))
+                                                   , (76, 100, Effect "Verlangsamt" $ lift (2 * d 10) >>= (\loss -> MaybeT . previews ctx $ over (sSequence . _Just . seqVal . _Just) (+ (-loss))))
                                                    ])
 
         , _sExtraSkills = []
@@ -278,7 +275,7 @@ human = Humanoid
                & set seEffect (cTable [ (1, 10, amputate zone)
                                       , (11, 25, effect $ review hitzone zone ++ " ist gelähmt und unbrauchbar")
                                       , (26, 45, effect $ review hitzone zone ++ " hat eingeschränkte Funktion (-50%)")
-                                      , (46, 75, Effect "Schwerste Schmerzen" . previews ctx $ over sFatigue (+ 10))
+                                      , (46, 75, Effect "Schwerste Schmerzen" . MaybeT . previews ctx $ over sFatigue (+ 10))
                                       , (76, 100, effect "Fleischwunde")
                                       ])
     bein zone = def
@@ -287,7 +284,7 @@ human = Humanoid
                & set seReBar (vitBar 0.2)
                & set seEffect (cTable [ (1, 10, amputate zone)
                                       , (11, 45, effect $ review hitzone zone ++ " ist gelähmt und unbrauchbar (halbierte Bewegung)")
-                                      , (46, 75, Effect "Schwerste Schmerzen" . previews ctx $ over sFatigue (+ 10))
+                                      , (46, 75, Effect "Schwerste Schmerzen" . MaybeT . previews ctx $ over sFatigue (+ 10))
                                       , (76, 100, effect "Fleischwunde")
                                       ])
 
@@ -343,7 +340,7 @@ dog = Quadruped
                                     & set seBar (vitBar 0.75)
                                     & set seReBar (vitBar 0.2)
                                     & set seEffect ( cTable [ (1, 5, death "Torso")
-                                                            , (6, 25, Effect "Organschäden" . previews ctx $ over sFatigue (+ 25) . over (sDamage' "Torso") (+ 10))
+                                                            , (6, 25, Effect "Organschäden" . MaybeT . previews ctx $ over sFatigue (+ 25) . over (sDamage' "Torso") (+ 10))
                                                             , (26, 45, effect "Innere Blutung (3 Schaden (Au) Minuten)")
                                                             , (46, 75, Effect "Bewusstlos" unconscious)
                                                             , (76, 100, Effect "Bewusstlos" . unconsciousR $ d 10)
@@ -354,7 +351,7 @@ dog = Quadruped
                                          & set seBar (vitBar 0.2)
                                          & set seReBar (vitBar 0.2)
                                          & set seEffect ( cTable [ (1, 5, effect "Querschnittsgelähmt")
-                                                                 , (6, 25, Effect "Kastration" . previews ctx $ over sFatigue (+ 10))
+                                                                 , (6, 25, Effect "Kastration" . MaybeT . previews ctx $ over sFatigue (+ 10))
                                                                  , (26, 50, effect "Innere Blutung (2 Schaden (Au) Minuten)")
                                                                  , (51, 100, Effect "Bewusstlos" . unconsciousR $ 2 * d 10)
                                                                  ])
@@ -386,8 +383,8 @@ dog = Quadruped
            & set seReBar (vitBar 0.2)
            & set seEffect ( cTable [ (1, 10, amputate zone)
                                    , (11, 25, effect $ review hitzone zone ++ " ist gelähmt und unbrauchbar (halbierte Bewegung)")
-                                   , (26, 45, Effect "Schmerzen" . previews ctx $ over sFatigue (+ 15))
-                                   , (46, 100, Effect "Fleischwunde" . previews ctx $ over sFatigue (+ 5))
+                                   , (26, 45, Effect "Schmerzen" . MaybeT . previews ctx $ over sFatigue (+ 15))
+                                   , (46, 100, Effect "Fleischwunde" . MaybeT . previews ctx $ over sFatigue (+ 5))
                                    ])
 
 dolphin = Dolphin
@@ -437,7 +434,7 @@ dolphin = Dolphin
                                         & set seBar (vitBar 0.8)
                                         & set seReBar (vitBar 0.2)
                                         & set seEffect ( cTable [ (1, 5, death "Rumpf")
-                                                                , (6, 25, Effect "Organschäden" . previews ctx $ over sFatigue (+ 7) . over (sDamage' "Rumpf") (+ 20))
+                                                                , (6, 25, Effect "Organschäden" . MaybeT . previews ctx $ over sFatigue (+ 7) . over (sDamage' "Rumpf") (+ 20))
                                                                 , (26, 45, effect "Blutung (2 Schaden (Au) Minuten)")
                                                                 , (46, 75, Effect "Bewusstlos" unconscious)
                                                                 , (76, 100, Effect "Bewusstlos" . unconsciousR $ d 10)
@@ -449,7 +446,7 @@ dolphin = Dolphin
                                           & set seReBar (vitBar 0.2)
                                           & set seEffect ( cTable [ (1, 10, amputate "Schwanz")
                                                                   , (11, 25, effect "Halbierte Bewegung")
-                                                                  , (26, 45, Effect "Schmerz" . previews ctx $ over sFatigue (+ 15))
+                                                                  , (26, 45, Effect "Schmerz" . MaybeT . previews ctx $ over sFatigue (+ 15))
                                                                   , (46, 100, effect "Fleischwunde")
                                                                   ])
                               )
@@ -508,28 +505,28 @@ silicoid = Silicoid
                                          & set seVal (sDamage' "Auge" . to return)
                                          & set seBar (vitBar 0.2)
                                          & set seReBar (vitBar 0.2)
-                                         & set seEffect ( cTable [ (1, 25, effect "Explosion")
-                                                                 , (26, 75, effect "Permanent desorientiert (nur rammen in zufällige Richtungen)")
-                                                                 , (76, 100, effect "Detonation in 3w10 AP")
+                                         & set seEffect ( cTable [ (1, 25, "Explosion")
+                                                                 , (26, 75, "Permanent desorientiert (nur rammen in zufällige Richtungen)")
+                                                                 , (76, 100, "Detonation in 3w10 AP")
                                                                  ])
                                 )
                               , ("Thorax", def
                                            & set seVal (sDamage' "Thorax" . to return)
                                            & set seBar (vitBar 0.65)
                                            & set seReBar (vitBar 0.2)
-                                           & set seEffect ( cTable [ (1, 10, effect "Explosion")
-                                                                   , (11, 25, effect "Halbe Bewegung")
-                                                                   , (26, 65, effect "10 Schaden, Sprühattacke auf nächsten Charakter (Blut)")
-                                                                   , (66, 100, effect "3w10 Erschöpfung")
+                                           & set seEffect ( cTable [ (1, 10, "Explosion")
+                                                                   , (11, 25, "Halbe Bewegung")
+                                                                   , (26, 65, "10 Schaden, Sprühattacke auf nächsten Charakter (Blut)")
+                                                                   , (66, 100, "3w10 Erschöpfung")
                                                                    ])
                                 )
                               , ("Schwanz", def
                                             & set seVal (sDamage' "Schwanz" . to return)
                                             & set seBar (vitBar 0.2)
                                             & set seReBar (vitBar 0.2)
-                                            & set seEffect ( cTable [ (1, 25, effect "10 Schaden, Schwanzdrüse unbrauchbar")
-                                                                    , (26, 60, effect "3 Schaden, Sprühattacke auf nächsten Charakter (Blut)")
-                                                                    , (61, 100, effect "Amok und Detonation nach 1w10+6 AP")
+                                            & set seEffect ( cTable [ (1, 25, "10 Schaden, Schwanzdrüse unbrauchbar")
+                                                                    , (26, 60, "3 Schaden, Sprühattacke auf nächsten Charakter (Blut)")
+                                                                    , (61, 100, "Amok und Detonation nach 1w10+6 AP")
                                                                     ])
                                 )
                               ] <> Map.fromList [(name, bein name) | side <- ["Rechtes", "Linkes"], length <- ["Vorderes", "Mittleres", "Hinteres"], let name = Hitzone . CI.mk $ side ++ " " ++ length ++ " Bein"]
diff --git a/src/Sequence/Contact/Tests.hs b/src/Sequence/Contact/Tests.hs
index d10819e..be61ed3 100644
--- a/src/Sequence/Contact/Tests.hs
+++ b/src/Sequence/Contact/Tests.hs
@@ -1,7 +1,8 @@
-{-# LANGUAGE TemplateHaskell, OverloadedStrings, OverloadedLists, ViewPatterns, MultiParamTypeClasses, FlexibleContexts, RankNTypes, TypeSynonymInstances, FlexibleInstances #-}
+{-# LANGUAGE TemplateHaskell, OverloadedStrings, OverloadedLists, ViewPatterns, MultiParamTypeClasses, FlexibleContexts, RankNTypes, TypeSynonymInstances, FlexibleInstances, RecordWildCards #-}
 
 module Sequence.Contact.Tests
-  ( enactTest 
+  ( enactTest, enactTestMod
+  , critTables
   ) where
 
 import Sequence.Formula
@@ -12,6 +13,7 @@ import Sequence.Contact.Types
 import Control.Monad
 import Control.Monad.Reader
 import Control.Monad.Base
+import Control.Monad.Trans.Maybe
 import Control.Lens
 
 import Data.Default
@@ -29,6 +31,8 @@ import Data.Traversable (mapM)
 
 import Prelude hiding (mapM)
 
+import Debug.Trace
+
 tests :: MonadReader Stats m => m (Map (CI String) (FormulaM Stats Test))
 tests = do
   baseTests <- mconcat <$> sequence [ test "Stärke" $ sAStrength . attributeTest
@@ -94,6 +98,45 @@ tests = do
     skillTest = to (\x -> flip (set tBaseDifficulty) def <$> x)
     attributeTest = to (\x -> flip (set tBaseDifficulty) def . (* 10) <$> x) 
 
+critTables :: CI String -> (DiceResult -> Table (Maybe Effect))
+critTables skill CritSuccess{..}
+  | skill `elem` ([ "Handfeuerwaffen"
+                  , "Schwere Waffen"
+                  , "Energiewaffen"
+                  , "Archaische Distanzwaffen"
+                  ] :: [CI String])
+    || skill == "Fernkampfangriffe"
+  = cTable [ (1,  5,   Just "Ziel wird zu Boden geschleudert und verliert 10-(En) AP")
+           , (6,  15,  Just "Glückstreffer an einer ungepanzerten Stelle (Schutzwert 0)")
+           , (16, 25,  Just "Schwachstelle in der Panzerung getroffen (Halber Schutzwert)")
+           , (26, 35,  Just "Lähmender Schmerz (Ziel verliert 12-(En) AP)")
+           , (36, 55,  Just "Ziel wird zu Boden geworfen")
+           , (56, 75,  Just "Kopfschuss")
+           , (76, 95,  Just "1w10 Bonusschaden")
+           , (96, 100, Nothing)
+           ]
+  | otherwise = [(Nothing, 1)]
+critTables skill CritFailure{..}
+  | skill `elem` ([ "Handfeuerwaffen"
+                  , "Schwere Waffen"
+                  , "Energiewaffen"
+                  , "Archaische Distanzwaffen"
+                  ] :: [CI String])
+    || skill == "Fernkampfangriffe"
+  = cTable [ (1,  5,   Nothing)
+           , (6,  25,  Just "Ladehemmung oder andere Fehlfunktion der Waffe. Erfordert zum Beheben die gleiche Anzahl AP wie das vollständige Nachladen der Waffe.")
+           , (26, 45,  Just "Waffe wird fallengelassen")
+           , (46, 65,  Just "Ein anderer Charakter in der Nähe wird getroffen")
+           , (66, 75,  Just "Angreifer schießt sich selbst in den Fuß (voller Schaden, Trefferzone: ein Bein)")
+           , (76, 85,  Just "Waffe wird beschädigt und praktisch nutzlos (Qualität -100%)")
+           , (86, 95,  Just "Charakter verliert geladene Munition (fällt heraus oder zündet im Magazin)")
+           , (96, 100, Just $ "Unkoordinierter Schuss in eine zufällige Richtung"
+                            <> "Waffe wird fallengelassen"
+             )
+           ]
+  | otherwise = [(Nothing, 1)]
+critTables _ _ = [(Nothing, 1)]
+
 
 getTest :: String -> Fold Stats (FormulaM Stats Test)
 getTest (CI.mk -> str) = folding tests'
@@ -108,9 +151,12 @@ instance Argument (FormulaM Stats Test) GameState where
   arg str = join <$> preuses (gFocus' . eStats) (preview (getTest str))
 
 enactTest :: Test -> FormulaM Stats TestResult
-enactTest rawTest = do
+enactTest rawTest = enactTestMod rawTest $ val ignored [CI.original (rawTest ^. tName), "Modifier"] False
+
+enactTestMod :: Test -> Formula Stats -> FormulaM Stats TestResult
+enactTestMod rawTest modFormula = do
   test <- foldM (&) rawTest =<< toListOf (ctx . sModifiers . folded . _Modifier . _2) <$> ask
-  manualMod <- val ignored [CI.original (rawTest ^. tName), "Modifier"] False
+  manualMod <- modFormula
   let
     critFailureBar = 95 - test^.tCritFailureMod
     critSuccessBar = 5 + test^.tCritSuccessMod
@@ -123,7 +169,7 @@ enactTest rawTest = do
       | pw >= critFailureBar = CritFailure
       | otherwise            = Failure
   dResult <- toResult <$> d 100
-  TestResult <$> pure dResult <*> (test ^. tEffect) dResult
+  TestResult <$> pure dResult <*> runMaybeT ((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 c69a698..80d35d2 100644
--- a/src/Sequence/Contact/Types.hs
+++ b/src/Sequence/Contact/Types.hs
@@ -31,6 +31,7 @@ import Data.Dynamic.Lens
 
 import Control.Monad.Reader (ask, local)
 import Control.Monad.State
+import Control.Monad.Trans.Maybe
 
 import Sequence.Contact.Types.Internal
 
@@ -77,17 +78,17 @@ instance Show Effect where
   show = show . view effectName
 
 instance Default Effect where
-  def = Effect "" $ preview ctx
+  def = Effect "" mzero
 
 instance Monoid Effect where
   mempty = def
-  (Effect aName aEff) `mappend` (Effect bName bEff) = Effect name $ do
-    new <- aEff
+  (Effect aName aEff) `mappend` (Effect bName bEff) = Effect name . MaybeT $ do
+    new <- runMaybeT 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
+      $ runMaybeT bEff
     where
       name
         | aName /= ""
@@ -97,6 +98,9 @@ instance Monoid Effect where
 effect :: String -> Effect
 effect str = def & set effectName str
 
+instance IsString Effect where
+  fromString = effect
+
 makeLenses ''Test
 
 instance Default Test where
@@ -106,7 +110,7 @@ instance Default Test where
         , _tCritFailureMod = 0
         , _tBaseDifficulty = 50
         , _tMod = 0
-        , _tEffect = const $ pure (def :: Effect)
+        , _tEffect = const mzero
         }
 
 deriving instance Eq TestResult
@@ -174,7 +178,7 @@ instance Default Stats where
         }
 
 applyModifier :: String -> (Test -> FormulaM Stats Test) -> Effect
-applyModifier effectName modifier = Effect (CI.mk effectName) $ previews ctx apply
+applyModifier effectName modifier = Effect (CI.mk effectName) . MaybeT $ previews ctx apply
   where
     apply = sModifiers <>~ [Modifier (CI.mk $ effectName ++ " (modifier)") modifier]
 
diff --git a/src/Sequence/Contact/Types/Internal.hs b/src/Sequence/Contact/Types/Internal.hs
index eaa1e19..f2052ee 100644
--- a/src/Sequence/Contact/Types/Internal.hs
+++ b/src/Sequence/Contact/Types/Internal.hs
@@ -2,7 +2,7 @@
 
 module Sequence.Contact.Types.Internal where
 
-import Sequence.Formula (Formula, FormulaM, Table)
+import Sequence.Formula (Formula, FormulaM, FormulaMT, Table)
 
 import Data.Map (Map)
 import Data.Set (Set)
@@ -18,6 +18,8 @@ import Data.CaseInsensitive (CI)
 
 import Data.ExtendedReal
 
+import Control.Monad.Trans.Maybe (MaybeT)
+
 newtype Hitzone = Hitzone { _hitzone :: CI String }
   deriving (Eq, Ord)
 
@@ -60,7 +62,7 @@ data DiceResult = CritSuccess { _rWith, _rBy :: Int }
 
 data TestResult = TestResult
                   { _rRoll   :: DiceResult
-                  , _rResult :: Effect
+                  , _rResult :: Maybe Effect
                   }
 
 data Test = Test
@@ -69,12 +71,12 @@ data Test = Test
             , _tCritFailureMod
             , _tBaseDifficulty
             , _tMod :: Int
-            , _tEffect :: DiceResult -> FormulaM Stats Effect
+            , _tEffect :: DiceResult -> FormulaMT MaybeT Stats Effect
             }
 
 data Modifier = Modifier (CI String) (Test -> FormulaM Stats Test)
 
-data Effect = Effect (CI String) (FormulaM Stats (Maybe Stats))
+data Effect = Effect (CI String) (FormulaMT MaybeT Stats Stats)
 
 data SeqVal = SeqVal
               { _seqRound :: Down Int