framework for damage tracking

5 files changed, 372 insertions, 132 deletions

diff --git a/src/Sequence/Contact/Archetypes.hs b/src/Sequence/Contact/Archetypes.hs
index 193892a..3e9b416 100644
--- a/src/Sequence/Contact/Archetypes.hs
+++ b/src/Sequence/Contact/Archetypes.hs
@@ -85,6 +85,17 @@ human = Humanoid
         , _sSeqVal = vReflexes * 2 + vMobility + vPerception + d 10
         , _sPainTolerance = vMass `quot'` 2 + vWillpower
         , _sFatigueTolerance = vWillpower `quot'` 2 + vEndurance
+
+        , _sHitzones = [ ("Kopf", 0.05)
+                       , ("Torso", 0.49)
+                       , ("Rechter Arm", 0.08)
+                       , ("Linker Arm", 0.08)
+                       , ("Unterleib", 0.10)
+                       , ("Rechtes Bein", 0.10)
+                       , ("Linkes Bein", 0.10)
+                       ]
+        , _sDamage = const 0
+        , _sArmor = const def
         }
 
 dog = Quadruped
@@ -109,6 +120,17 @@ dog = Quadruped
       , _sSeqVal = vReflexes * 2 + vMobility + vPerception + 2 * d 10
       , _sPainTolerance = vMass `quot'` 2 + vWillpower
       , _sFatigueTolerance = vWillpower `quot'` 2 + vEndurance
+
+      , _sHitzones = [ ("Kopf", 0.05)
+                     , ("Torso", 0.49)
+                     , ("Rechter Vorderlauf", 0.08)
+                     , ("Linker Vorderlauf", 0.08)
+                     , ("Hinterteil", 0.10)
+                     , ("Rechter Hinterlauf", 0.10)
+                     , ("Linker Hinterlauf", 0.10)
+                     ]
+      , _sDamage = const 0
+      , _sArmor = const def
       }
 
 dolphin = Dolphin
@@ -133,6 +155,13 @@ dolphin = Dolphin
           , _sSeqVal = vReflexes * 2 + vMobility + vPerception + 2 * d 10
           , _sPainTolerance = vMass `quot'` 2 + vWillpower
           , _sFatigueTolerance = vWillpower `quot'` 2 + vEndurance
+
+          , _sHitzones = [ ("Kopf", 0.10)
+                         , ("Rumpf", 0.65)
+                         , ("Schwanz", 0.25)
+                         ]
+          , _sDamage = const 0
+          , _sArmor = const def
           }
 
 childOfMu = human
diff --git a/src/Sequence/Contact/Tests.hs b/src/Sequence/Contact/Tests.hs
index 8aa072a..82b1cf3 100644
--- a/src/Sequence/Contact/Tests.hs
+++ b/src/Sequence/Contact/Tests.hs
@@ -1,9 +1,7 @@
-{-# LANGUAGE TemplateHaskell, OverloadedStrings, OverloadedLists, ViewPatterns, MultiParamTypeClasses, FlexibleContexts, RankNTypes, TypeSynonymInstances, FlexibleInstances, ImpredicativeTypes #-}
+{-# LANGUAGE TemplateHaskell, OverloadedStrings, OverloadedLists, ViewPatterns, MultiParamTypeClasses, FlexibleContexts, RankNTypes, TypeSynonymInstances, FlexibleInstances #-}
 
 module Sequence.Contact.Tests
-  ( TestResult(..), rWith, rBy
-  , Test, tCritSuccessMod, tCritFailureMod, tBaseDifficulty, tMod
-  , enactTest 
+  ( enactTest 
   ) where
 
 import Sequence.Formula
@@ -13,6 +11,7 @@ import Sequence.Contact.Types
 
 import Control.Monad
 import Control.Monad.Reader
+import Control.Monad.Base
 import Control.Lens
 
 import Data.Default
@@ -29,31 +28,6 @@ import Data.Traversable (mapM)
 
 import Prelude hiding (mapM)
 
-
-data TestResult = CritSuccess { _rWith, _rBy :: Int }
-                | Success { _rWith, _rBy :: Int }
-                | Failure { _rWith, _rBy :: Int }
-                | CritFailure { _rWith, _rBy :: Int }
-  deriving (Eq, Ord, Show)
-makeLenses ''TestResult
-
-data Test = Test
-            { _tCritSuccessMod
-            , _tCritFailureMod
-            , _tBaseDifficulty
-            , _tMod :: Int
-            }
-  deriving (Eq, Ord)
-makeLenses ''Test
-
-instance Default Test where
-  def = Test
-        { _tCritSuccessMod = 0
-        , _tCritFailureMod = 0
-        , _tBaseDifficulty = 50
-        , _tMod = 0
-        }
-
 tests :: MonadReader Stats m => m (Map (CI String) (FormulaM Stats Test))
 tests = mconcat <$> sequence [ test "Stärke" $ sAStrength . attributeTest
 
diff --git a/src/Sequence/Contact/Types.hs b/src/Sequence/Contact/Types.hs
index c00a60d..cd1bc02 100644
--- a/src/Sequence/Contact/Types.hs
+++ b/src/Sequence/Contact/Types.hs
@@ -1,6 +1,9 @@
-{-# LANGUAGE TemplateHaskell, RecordWildCards, OverloadedStrings, OverloadedLists, ViewPatterns, RankNTypes #-}
+{-# LANGUAGE TemplateHaskell, RecordWildCards, OverloadedStrings, OverloadedLists, ViewPatterns, RankNTypes, ImpredicativeTypes #-}
 
-module Sequence.Contact.Types where
+module Sequence.Contact.Types
+  ( module Sequence.Contact.Types
+  , module Sequence.Contact.Types.Internal
+  ) where
 
 import Sequence.Formula
 
@@ -9,105 +12,103 @@ import Control.Lens
 
 import Data.Default
 
-data Stats = Prop
-           | Humanoid
-             { _sAStrength
-             , _sAEndurance
-             , _sAMass
-             , _sAReflexes
-             , _sAMobility
-             , _sADexterity
-             , _sAIntelligence
-             , _sACharisma
-             , _sAPerception
-             , _sAWillpower
-             
-             , _sSArchaicRanged
-             , _sSFirearms
-             , _sSHeavyWeapons
-             , _sSEnergyWeapons
-             , _sSUnarmedMelee
-             , _sSArmedMelee
-             , _sSThrownWeapons
-             , _sSStealth
-             , _sSThievery
-             , _sSLockpicking
-             , _sSTrapping
-             , _sSSciences
-             , _sSFirstAid
-             , _sSMedicine
-             , _sSHumanities
-             , _sSEngineering
-             , _sSCraft
-             , _sSInterface
-             , _sSSpeech
-             , _sSLeadership
-             , _sSHomeEconomics
-             , _sSSurvival
-             , _sSMotorcycle
-             , _sSWheeled
-             , _sSHovercraft
-             , _sSAircraft
-             , _sSSpacecraft
-             , _sSWatercraft
-             , _sSTracked
-             , _sSExoskeleton
-
-             , _sMaxVitality
-             , _sSeqVal
-             , _sPainTolerance
-             , _sFatigueTolerance :: Formula Stats
-             }
-           | Quadruped
-             { _sAStrength
-             , _sAEndurance
-             , _sAMass
-             , _sAReflexes
-             , _sAMobility
-             , _sADexterity
-             , _sAIntelligence
-             , _sACharisma
-             , _sAPerception
-             , _sAWillpower
-
-             , _sSBiting
-             , _sSSearching
-             , _sSStealth
-             , _sSLeadership
-             , _sSDemeanour
-
-             , _sMaxVitality
-             , _sSeqVal
-             , _sPainTolerance
-             , _sFatigueTolerance :: Formula Stats
-             }
-           | Dolphin
-             { _sAStrength
-             , _sAEndurance
-             , _sAMass
-             , _sAReflexes
-             , _sAMobility
-             , _sADexterity
-             , _sAIntelligence
-             , _sACharisma
-             , _sAPerception
-             , _sAWillpower
-
-             , _sSRamming
-             , _sSTargeting
-             , _sSSearching
-             , _sSStealth
-             , _sSComprehension
-
-             , _sMaxVitality
-             , _sSeqVal
-             , _sPainTolerance
-             , _sFatigueTolerance :: Formula Stats
-             }
+import Data.Map (Map)
+import qualified Data.Map as Map
+
+import Data.CaseInsensitive (CI)
+import qualified Data.CaseInsensitive as CI
+
+import Data.String (IsString(..))
+import Data.Function (on)
+import Data.Maybe
+import Data.Ratio
+
+import Control.Monad.Reader (ask)
+import Control.Monad.State
+
+import Sequence.Contact.Types.Internal
+
+hitzone :: Iso' String Hitzone
+hitzone = iso (Hitzone . CI.mk) (CI.original . _hitzone)
+
+instance IsString Hitzone where
+  fromString = view hitzone
+
+makeLenses ''Armor
+
+instance Default Armor where
+  def = Armor
+        { _aBallistic = 0
+        , _aPiercing = 0
+        , _aBlunt = 0
+        , _aHeat = 0
+        , _aCold = 0
+        , _aToxic = 0
+        , _aExplosive = 0
+        }
+
+makeLenses ''TestResult
+
+makeLenses ''Test
+
+instance Default Test where
+  def = Test
+        { _tName = ""
+        , _tCritSuccessMod = 0
+        , _tCritFailureMod = 0
+        , _tBaseDifficulty = 50
+        , _tMod = 0
+        }
+
+makePrisms ''Modifier
+
+instance Eq Modifier where
+  (==) = (==) `on` (view $ _Modifier . _1)
+
+instance Ord Modifier where
+  compare = compare `on` (view $ _Modifier . _1)
+
+instance Default Modifier where
+  def = Modifier "" pure
+
+makePrisms ''Effect
+
+instance Eq Effect where
+  (==) = (==) `on` (view $ _Effect . _1)
+
+instance Ord Effect where
+  compare = compare `on` (view $ _Effect . _1)
+
+instance Default Effect where
+  def = Effect "" pure
+
+makeLenses ''ShockEffect
+  
+instance Default ShockEffect where
+  def = ShockEffect { _seApplied = False
+                    , _seVal = pure Nothing
+                    , _seBar = pure Nothing
+                    , _seEffect = def
+                    }
+
 makeLenses ''Stats
 
 instance Default Stats where
   def = Prop
+        { _sHitzones = [("Volumen", 1)]
+        , _sDamage = const 0
+        , _sFatigue = 0
+        , _sCripple = const def
+        , _sArmor = const def
+
+        , _sExtraSkills = []
+        , _sModifiers = []
+        }
+
+applyModifier :: String -> (Test -> FormulaM Stats Test) -> Effect
+applyModifier effectName modifier = Effect (CI.mk effectName) $ return . apply
+  where
+    apply = sModifiers <>~ [Modifier (CI.mk $ effectName ++ " (modifier)") modifier]
 
 vStrength = val sAStrength "Stärke?" True
 vEndurance = val sAEndurance "Ausdauer?" True
@@ -119,3 +120,26 @@ vIntelligence = val sAIntelligence "Intelligenz?" True
 vCharisma = val sACharisma "Charisma?" True
 vPerception = val sAPerception "Wahrnehmung?" True
 vWillpower = val sAWillpower "Entschlossenheit?" True
+
+scaled :: (Real a, Fractional a, Integral b) => Ratio b -> Iso' a a
+scaled (realToFrac -> ratio) = iso (* ratio) (/ ratio)
+
+sDamage' :: String -> Traversal' Stats Int
+sDamage' (view hitzone -> zone) = sDamage . ix zone
+
+sCripple' :: String -> Traversal' Stats ShockEffect
+sCripple' (view hitzone -> zone) = sCripple . ix zone
+
+sTotalDamage :: Lens' Stats Int
+sTotalDamage = lens retrieve undefined
+  where
+    retrieve = do
+      hitzones <- Map.keys <$> view sHitzones
+      damageMap <- view sDamage
+      return . sum $ pure damageMap <*> hitzones
+
+sDead :: Fold Stats (FormulaM Stats Bool)
+sDead = folding $ do
+  maxVitality <- preview sMaxVitality
+  damage <- view sTotalDamage
+  return $ liftM2 (>) <$> Just (return damage) <*> maxVitality
diff --git a/src/Sequence/Contact/Types/Internal.hs b/src/Sequence/Contact/Types/Internal.hs
new file mode 100644
index 0000000..9929801
--- /dev/null
+++ b/src/Sequence/Contact/Types/Internal.hs
@@ -0,0 +1,200 @@
+{-# LANGUAGE RankNTypes #-}
+
+module Sequence.Contact.Types.Internal where
+
+import Sequence.Formula (Formula, FormulaM, Table)
+
+import Data.Map (Map)
+import Data.Set (Set)
+import Data.Ratio
+
+import Control.Lens
+
+import Data.CaseInsensitive (CI)
+
+newtype Hitzone = Hitzone { _hitzone :: CI String }
+  deriving (Eq, Ord)
+
+data Armor = Armor
+             { _aBallistic
+             , _aPiercing
+             , _aBlunt
+             , _aHeat
+             , _aCold
+             , _aToxic
+             , _aExplosive :: Int
+             }
+
+data TestResult = CritSuccess { _rWith, _rBy :: Int }
+                | Success { _rWith, _rBy :: Int }
+                | Failure { _rWith, _rBy :: Int }
+                | CritFailure { _rWith, _rBy :: Int }
+  deriving (Eq, Ord, Show)
+
+data Test = Test
+            { _tName :: CI String
+            , _tCritSuccessMod
+            , _tCritFailureMod
+            , _tBaseDifficulty
+            , _tMod :: Int
+            }
+  deriving (Eq, Ord)
+
+data Modifier = Modifier (CI String) (Test -> FormulaM Stats Test)
+
+data Effect = Effect (CI String) (Stats -> FormulaM Stats Stats)
+
+data ShockEffect = ShockEffect
+                   { _seApplied :: Bool
+                   , _seVal :: FormulaM Stats (Maybe Int)
+                   , _seBar :: FormulaM Stats (Maybe Int)
+                   , _seEffect :: Table Effect
+                   }
+
+data Stats = Prop
+             { _sHitzones :: Table Hitzone
+             , _sArmor :: Hitzone -> Armor 
+             , _sCripple :: Hitzone -> ShockEffect
+
+             , _sDamage :: Hitzone -> Int
+             , _sFatigue :: Int
+
+             , _sPainShock :: ShockEffect
+             , _sFatigueShock :: ShockEffect
+
+             , _sExtraSkills :: Map (CI String) (FormulaM Stats Test)
+             , _sModifiers :: Set Modifier
+             }
+           | Humanoid
+             { _sAStrength
+             , _sAEndurance
+             , _sAMass
+             , _sAReflexes
+             , _sAMobility
+             , _sADexterity
+             , _sAIntelligence
+             , _sACharisma
+             , _sAPerception
+             , _sAWillpower
+             
+             , _sSArchaicRanged
+             , _sSFirearms
+             , _sSHeavyWeapons
+             , _sSEnergyWeapons
+             , _sSUnarmedMelee
+             , _sSArmedMelee
+             , _sSThrownWeapons
+             , _sSStealth
+             , _sSThievery
+             , _sSLockpicking
+             , _sSTrapping
+             , _sSSciences
+             , _sSFirstAid
+             , _sSMedicine
+             , _sSHumanities
+             , _sSEngineering
+             , _sSCraft
+             , _sSInterface
+             , _sSSpeech
+             , _sSLeadership
+             , _sSHomeEconomics
+             , _sSSurvival
+             , _sSMotorcycle
+             , _sSWheeled
+             , _sSHovercraft
+             , _sSAircraft
+             , _sSSpacecraft
+             , _sSWatercraft
+             , _sSTracked
+             , _sSExoskeleton
+
+             , _sMaxVitality
+             , _sSeqVal
+             , _sPainTolerance
+             , _sFatigueTolerance :: Formula Stats
+
+             , _sHitzones :: Table Hitzone
+             , _sArmor :: Hitzone -> Armor 
+             , _sCripple :: Hitzone -> ShockEffect
+
+             , _sDamage :: Hitzone -> Int
+             , _sFatigue :: Int
+
+             , _sPainShock :: ShockEffect
+             , _sFatigueShock :: ShockEffect
+
+             , _sExtraSkills :: Map (CI String) (FormulaM Stats Test)
+             , _sModifiers :: Set Modifier
+             }
+           | Quadruped
+             { _sAStrength
+             , _sAEndurance
+             , _sAMass
+             , _sAReflexes
+             , _sAMobility
+             , _sADexterity
+             , _sAIntelligence
+             , _sACharisma
+             , _sAPerception
+             , _sAWillpower
+
+             , _sSBiting
+             , _sSSearching
+             , _sSStealth
+             , _sSLeadership
+             , _sSDemeanour
+
+             , _sMaxVitality
+             , _sSeqVal
+             , _sPainTolerance
+             , _sFatigueTolerance :: Formula Stats
+
+             , _sHitzones :: Table Hitzone
+             , _sArmor :: Hitzone -> Armor 
+             , _sCripple :: Hitzone -> ShockEffect
+
+             , _sDamage :: Hitzone -> Int
+             , _sFatigue :: Int
+
+             , _sPainShock :: ShockEffect
+             , _sFatigueShock :: ShockEffect
+
+             , _sExtraSkills :: Map (CI String) (FormulaM Stats Test)
+             , _sModifiers :: Set Modifier
+             }
+           | Dolphin
+             { _sAStrength
+             , _sAEndurance
+             , _sAMass
+             , _sAReflexes
+             , _sAMobility
+             , _sADexterity
+             , _sAIntelligence
+             , _sACharisma
+             , _sAPerception
+             , _sAWillpower
+
+             , _sSRamming
+             , _sSTargeting
+             , _sSSearching
+             , _sSStealth
+             , _sSComprehension
+
+             , _sMaxVitality
+             , _sSeqVal
+             , _sPainTolerance
+             , _sFatigueTolerance :: Formula Stats
+
+             , _sHitzones :: Table Hitzone
+             , _sArmor :: Hitzone -> Armor 
+             , _sCripple :: Hitzone -> ShockEffect
+
+             , _sDamage :: Hitzone -> Int
+             , _sFatigue :: Int
+
+             , _sPainShock :: ShockEffect
+             , _sFatigueShock :: ShockEffect
+
+             , _sExtraSkills :: Map (CI String) (FormulaM Stats Test)
+             , _sModifiers :: Set Modifier
+             }
diff --git a/src/Sequence/Formula.hs b/src/Sequence/Formula.hs
index d486bab..ca945f8 100644
--- a/src/Sequence/Formula.hs
+++ b/src/Sequence/Formula.hs
@@ -2,10 +2,11 @@
 
 module Sequence.Formula
   ( FormulaM, Formula, quot'
-  , (:<:)(..), Context(..)
+  , (:<:)(..), Context(..), ctx
   , evalFormula
   , val
   , d, z
+  , Table, table
   ) where
 
 import Control.Lens hiding (Context(..))
@@ -31,6 +32,9 @@ import Data.Either
 import Data.Set (Set)
 import qualified Data.Set as Set
 
+import Data.Map (Map)
+import qualified Data.Map as Map
+
 class (:<:) small large where
   ctx' :: Traversal' large small
 
@@ -89,16 +93,20 @@ instance Integral a => Num (FormulaM input a) where
 quot' :: Integral a => FormulaM input a -> FormulaM input a -> FormulaM input a
 quot' = liftM2 quot
 
-askQuestion :: (MonadIO m, sInput :<: lInput) => lInput -> Question sInput -> m lInput
-askQuestion input q@(Question{..}) = flip (set $ ctx' . answer) input . maybe (throwError q) return <$> askQ prompt (join . fmap readMaybe)
+askQuestion :: (MonadIO m, sInput :<: lInput) => String -> lInput -> Question sInput -> m lInput
+askQuestion promptPref input q@(Question{..}) = flip (set $ ctx' . answer) input . maybe (throwError q) return <$> askQ (promptPref' ++ prompt) (join . fmap readMaybe)
+  where
+    promptPref'
+      | null promptPref = ""
+      | otherwise = promptPref ++ " » "
 
-evalFormula :: (MonadIO m, sInput :<: lInput) => lInput -> FormulaM sInput a -> m (lInput, a)
+evalFormula :: (MonadIO m, sInput :<: lInput) => String -> lInput -> FormulaM sInput a -> m (lInput, a)
 evalFormula = evalFormula' []
   where
-    evalFormula' finalChanges input formula = do
+    evalFormula' finalChanges promptPref input formula = do
       result <- liftIO . enact . runExceptT . (runReaderT ?? (Context input)) . (evalStateT ?? Set.empty) $ formula
       case result of
-        Left q@(Question{..}) -> askQuestion input q >>= flip (evalFormula' $ bool (pure . set (ctx' . answer) $ throwError q) mempty keepResult ++ finalChanges) formula
+        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)
 
 val :: Integral a => Traversal' input (Formula input) -> String -> Bool -> Formula input
@@ -109,3 +117,8 @@ val answer prompt keepResult = do
 d, z :: Integral a => Int -> FormulaM input a
 d n = liftBase . fmap fromIntegral $ D.d n
 z n = liftBase . fmap fromIntegral $ D.z n
+
+type Table a = Map a Rational
+
+table :: Ord a => Table a -> FormulaM input a
+table = liftBase . makeEventProb . Map.assocs