refactoring & combat rounds

3 files changed, 119 insertions, 28 deletions

diff --git a/src/Sequence/Contact/Archetypes.hs b/src/Sequence/Contact/Archetypes.hs
index 3e9b416..ff37fdb 100644
--- a/src/Sequence/Contact/Archetypes.hs
+++ b/src/Sequence/Contact/Archetypes.hs
@@ -4,6 +4,11 @@ module Sequence.Contact.Archetypes where
 
 import Control.Lens
 
+import Control.Monad.Except
+import Control.Monad.State
+import Control.Monad.Trans
+import Control.Monad.Trans.Maybe
+
 import Sequence.Contact.Types
 import Sequence.Formula
 
@@ -14,6 +19,8 @@ import Data.Map (Map)
 import qualified Data.Map as Map
 
 import Data.Default
+import Data.Maybe
+import Data.Ratio
 
 import Data.List
 
@@ -37,6 +44,9 @@ archetypes = [ ("Mensch", human)
              , ("Milizenschläger", milizenschlaeger)
              ]
 
+cTable :: Ord v => [(Integer, Integer, v)] -> Table v
+cTable = Map.fromList . map (\(from, to, value) -> (value, (abs (to - from) + 1) % 100))
+
 
 human = Humanoid
         { _sAStrength = vStrength
@@ -86,17 +96,48 @@ human = Humanoid
         , _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
+        , _sHitzones = cTable [ (1, 5, "Kopf")
+                              , (6, 54, "Torso")
+                              , (55, 62, "Rechter Arm")
+                              , (63, 70, "Linker Arm")
+                              , (71, 80, "Unterleib")
+                              , (81, 90, "Rechtes Bein")
+                              , (91, 100, "Linkes Bein")
+                              ]
         , _sArmor = const def
+        , _sCripple = fromJust . flip Map.lookup [ ("Kopf", def
+                                                            & set seVal (sDamage' "Kopf" . to return)
+                                                            & set seBar (sMaxVitality . mapping (scaled 0.5))
+                                                            & set seEffect (cTable [ (1, 10, Effect "Tod" headshot)
+                                                                                   , (11, 25, effect "Blind")
+                                                                                   , (26, 35, effect "Blind, Rechts")
+                                                                                   , (36, 45, effect "Blind, Links")
+                                                                                   , (46, 75, effect "Taub")
+                                                                                   , (76, 100, effect "Bewusstlos – 1w10 Runden")
+                                                                                   ])
+                                                   )
+                                                 , ("Torso", def)
+                                                 , ("Rechter Arm", def)
+                                                 , ("Linker Arm", def)
+                                                 , ("Unterleib", def)
+                                                 , ("Rechtes Bein", def)
+                                                 , ("Linkes Bein", def)
+                                                 ]
+
+        , _sDamage = const 0
+        , _sFatigue = 0
+
+        , _sPainShock = def
+        , _sFatigueShock = def
         }
+  where
+    headshot = runMaybeT $ do
+      maxVitality <- (MaybeT . preview $ ctx . sMaxVitality) >>= lift
+      currentDmg <- MaybeT . preview $ ctx . sDamage' "Kopf"
+      allDmg <- MaybeT . preview $ ctx . sTotalDamage
+      let dmg = currentDmg + (maxVitality - allDmg)
+          dmg' = if dmg >= 0 then dmg else 0
+      MaybeT . previews ctx $ set (sDamage' "Kopf") dmg'
 
 dog = Quadruped
       { _sAStrength = vStrength
diff --git a/src/Sequence/Contact/Types.hs b/src/Sequence/Contact/Types.hs
index cd1bc02..a0add1a 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 #-}
+{-# LANGUAGE TemplateHaskell, RecordWildCards, OverloadedStrings, OverloadedLists, ViewPatterns, RankNTypes, ImpredicativeTypes, FlexibleContexts #-}
 
 module Sequence.Contact.Types
   ( module Sequence.Contact.Types
@@ -22,6 +22,8 @@ import Data.String (IsString(..))
 import Data.Function (on)
 import Data.Maybe
 import Data.Ratio
+import Data.List
+import Data.Ord
 
 import Control.Monad.Reader (ask)
 import Control.Monad.State
@@ -73,21 +75,36 @@ instance Default Modifier where
 
 makePrisms ''Effect
 
+effectName :: Lens' Effect String
+effectName = _Effect . _1 . iso CI.original CI.mk
+
 instance Eq Effect where
-  (==) = (==) `on` (view $ _Effect . _1)
+  (==) = (==) `on` (view effectName)
 
 instance Ord Effect where
-  compare = compare `on` (view $ _Effect . _1)
+  compare = compare `on` (view effectName)
 
 instance Default Effect where
-  def = Effect "" pure
+  def = Effect "" $ preview ctx
+
+effect :: String -> Effect
+effect str = def & set effectName str
+
+makePrisms ''SeqVal
+makeLenses ''SeqVal
+
+instance Default SeqVal where
+  def = SeqVal { _seqRound = 0
+               , _seqVal = Nothing
+               , _seqEpsilon = False
+               }
 
 makeLenses ''ShockEffect
   
 instance Default ShockEffect where
   def = ShockEffect { _seApplied = False
-                    , _seVal = pure Nothing
-                    , _seBar = pure Nothing
+                    , _seVal = ignored
+                    , _seBar = ignored
                     , _seEffect = def
                     }
 
@@ -96,17 +113,23 @@ makeLenses ''Stats
 instance Default Stats where
   def = Prop
         { _sHitzones = [("Volumen", 1)]
+        , _sArmor = const def
+        , _sCripple = const def
+
         , _sDamage = const 0
         , _sFatigue = 0
-        , _sCripple = const def
-        , _sArmor = const def
+
+        , _sSequence = Nothing
+        
+        , _sPainShock = def
+        , _sFatigueShock = def
 
         , _sExtraSkills = []
         , _sModifiers = []
         }
 
 applyModifier :: String -> (Test -> FormulaM Stats Test) -> Effect
-applyModifier effectName modifier = Effect (CI.mk effectName) $ return . apply
+applyModifier effectName modifier = Effect (CI.mk effectName) $ previews ctx apply
   where
     apply = sModifiers <>~ [Modifier (CI.mk $ effectName ++ " (modifier)") modifier]
 
@@ -121,22 +144,33 @@ 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)
+scaled :: Ratio Int -> Iso' Int Int
+scaled r = iso (\x -> floor $ x % 1 * r) (\x -> round $ x % 1 / r)
 
-sDamage' :: String -> Traversal' Stats Int
-sDamage' (view hitzone -> zone) = sDamage . ix zone
+sDamage' :: Hitzone -> Traversal' Stats Int
+sDamage' zone = sDamage . ix zone
 
-sCripple' :: String -> Traversal' Stats ShockEffect
-sCripple' (view hitzone -> zone) = sCripple . ix zone
+sCripple' :: Hitzone -> Traversal' Stats ShockEffect
+sCripple' zone = sCripple . ix zone
 
 sTotalDamage :: Lens' Stats Int
-sTotalDamage = lens retrieve undefined
+sTotalDamage = lens retrieve $ flip spread
   where
     retrieve = do
       hitzones <- Map.keys <$> view sHitzones
       damageMap <- view sDamage
       return . sum $ pure damageMap <*> hitzones
+    spread dmg = execState $ do
+      hitzones <- Map.keys <$> use sHitzones
+      damageMap <- use sDamage
+      totalDamage <- use sTotalDamage
+      let dmg' = dmg - totalDamage
+          (d, r) = dmg' `divMod` length hitzones
+          min = snd $ (if dmg' < 0 then maximumBy else minimumBy) (compare `on` fst) [(damageMap zone, zone) | zone <- hitzones]
+          damageMap' z
+            | z == min  = damageMap z + d + r
+            | otherwise = damageMap z + d
+      sDamage .= damageMap'
 
 sDead :: Fold Stats (FormulaM Stats Bool)
 sDead = folding $ do
diff --git a/src/Sequence/Contact/Types/Internal.hs b/src/Sequence/Contact/Types/Internal.hs
index 9929801..7e9be2b 100644
--- a/src/Sequence/Contact/Types/Internal.hs
+++ b/src/Sequence/Contact/Types/Internal.hs
@@ -7,6 +7,7 @@ import Sequence.Formula (Formula, FormulaM, Table)
 import Data.Map (Map)
 import Data.Set (Set)
 import Data.Ratio
+import Data.Monoid
 
 import Control.Lens
 
@@ -42,12 +43,19 @@ data Test = Test
 
 data Modifier = Modifier (CI String) (Test -> FormulaM Stats Test)
 
-data Effect = Effect (CI String) (Stats -> FormulaM Stats Stats)
+data Effect = Effect (CI String) (FormulaM Stats (Maybe Stats))
+
+data SeqVal = SeqVal
+              { _seqRound :: Int
+              , _seqVal :: Maybe Int
+              , _seqEpsilon :: Bool
+              }
+  deriving (Show, Ord, Eq)
 
 data ShockEffect = ShockEffect
                    { _seApplied :: Bool
-                   , _seVal :: FormulaM Stats (Maybe Int)
-                   , _seBar :: FormulaM Stats (Maybe Int)
+                   , _seVal :: Getting (First (Formula Stats)) Stats (Formula Stats)
+                   , _seBar :: Getting (First (Formula Stats)) Stats (Formula Stats)
                    , _seEffect :: Table Effect
                    }
 
@@ -62,6 +70,8 @@ data Stats = Prop
              , _sPainShock :: ShockEffect
              , _sFatigueShock :: ShockEffect
 
+             , _sSequence :: Maybe SeqVal
+
              , _sExtraSkills :: Map (CI String) (FormulaM Stats Test)
              , _sModifiers :: Set Modifier
              }
@@ -120,6 +130,8 @@ data Stats = Prop
              , _sDamage :: Hitzone -> Int
              , _sFatigue :: Int
 
+             , _sSequence :: Maybe SeqVal
+
              , _sPainShock :: ShockEffect
              , _sFatigueShock :: ShockEffect
 
@@ -156,6 +168,8 @@ data Stats = Prop
              , _sDamage :: Hitzone -> Int
              , _sFatigue :: Int
 
+             , _sSequence :: Maybe SeqVal
+
              , _sPainShock :: ShockEffect
              , _sFatigueShock :: ShockEffect
 
@@ -192,6 +206,8 @@ data Stats = Prop
              , _sDamage :: Hitzone -> Int
              , _sFatigue :: Int
 
+             , _sSequence :: Maybe SeqVal
+
              , _sPainShock :: ShockEffect
              , _sFatigueShock :: ShockEffect