7 files changed, 160 insertions, 68 deletions

diff --git a/default.nix b/default.nix
index c96e43f..4b974c3 100644
--- a/default.nix
+++ b/default.nix
@@ -1,8 +1,9 @@
 { pkgs ? (import <nixpkgs> {})
-, compilerName ? "ghc7103"
+, compilerName ? "ghc801"
 }:
 
 rec {
+  # haskellPackages = pkgs.haskell.packages."${compilerName}";
   haskellPackages = pkgs.haskell.packages."${compilerName}".override {
     overrides = self: super: {
       Shellac = pkgs.haskell.lib.appendPatch super.Shellac (pkgs.writeText "build.patch" ''
diff --git a/sequence.cabal b/sequence.cabal
index 2def576..931cba6 100644
--- a/sequence.cabal
+++ b/sequence.cabal
@@ -19,7 +19,7 @@ executable sequence
   main-is:             Main.hs
   other-modules:       Sequence.Types
   -- other-extensions:    
-  build-depends:       base >=4.8 && <5
+  build-depends:       base >=4.9 && <5
                      , Shellac
                      , Shellac-haskeline
                      , data-default
diff --git a/src/Main.hs b/src/Main.hs
index b7c6a6e..f46fd3e 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -32,6 +32,7 @@ import Data.Bool
 import Data.Function
 
 import Control.Monad.State.Strict
+import Control.Monad.Trans.Maybe
 
 import Sequence.Types
 import Sequence.Contact.Types
@@ -92,11 +93,11 @@ stateOutline st
     faction id = fromJust $ view eFaction <$> Map.lookup id (st ^. gEntities)
     factionIndex id = fromJust $ elemIndex (view faction' $ faction id) factions
     rowGs = do
-      rowGroup'@((review seqVal' -> seqVal, _):_) <- protoRows
+      rowGroup'@((seq, _):_) <- protoRows
       let
         rowGroup = map snd rowGroup'
         factionColumn i = [evalState ?? st $ toName x | x <- rowGroup, factionIndex x == i ]
-      return . colsAllG top $ [seqVal] : map factionColumn [0..(length factions - 1)]
+      return . colsAllG top $ [show $ view seqVal seq] : map factionColumn [0..(length factions - 1)]
 
 -- Query state
 listFactions, listEntities :: Sh GameState ()
@@ -195,12 +196,13 @@ factionSeqVal :: Completable Faction -> Sh GameState ()
 factionSeqVal = withArg $ \qFaction -> use gEntities >>= mapM_ (entitySeqVal') . Map.keys . Map.filter ((==) qFaction . view eFaction)
 
 entitySeqVal' :: EntityIdentifier -> Sh GameState ()
-entitySeqVal' ident = do
-  entity <- preuse (gEntities . ix ident)
-  let sVal = preview (eStats . sSeqVal) =<< entity
-  case (,) <$> entity <*> sVal of
-    Nothing -> return ()
-    Just (entity, sVal) -> do
-      name <- toName ident
-      (newEntity, view (seqVal . re _Just) -> val) <- evalFormula name entity sVal
-      gEntities . at ident .= Just (newEntity & set eSeqVal val)
+entitySeqVal' ident = void . runMaybeT $ do
+  entity <- MaybeT $ preuse (gEntities . ix ident)
+  sVal <- MaybeT . return $ preview (eStats . sSeqVal) entity
+  name <- toName ident
+  round <- use gRound
+  (newEntity, sNum) <- evalFormula name entity sVal
+  let val = Just $ def
+            & set seqRound round
+            & set seqVal (Just sNum)
+  gEntities . at ident .= Just (newEntity & set eSeqVal val)
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
 
diff --git a/src/Sequence/Types.hs b/src/Sequence/Types.hs
index 02389a1..33bbc2a 100644
--- a/src/Sequence/Types.hs
+++ b/src/Sequence/Types.hs
@@ -3,11 +3,10 @@
 module Sequence.Types
   ( GameState, gEntities, gEntityNames, gFocus, gNextId'
   , Faction, faction, faction'
-  , SeqVal(..), seqVal, seqVal'
   , Entity(..), eFaction, eSeqVal, eStats
   , EntityName(..), entityName
   , EntityIdentifier(..), entityId, entityId'
-  , inhabitedFactions, priorityQueue, tip, insertEntity, gFocus'
+  , inhabitedFactions, priorityQueue, tip, insertEntity, gFocus', gRound
   ) where
 
 import Control.Lens
@@ -26,11 +25,14 @@ import qualified Data.Bimap as Bimap
 
 import Control.Monad.Reader
 import Control.Monad.State
+import Control.Monad.Trans.Maybe
 
 import Data.List
 import Data.Maybe
 import Data.Tuple
 import Data.Ord
+import Data.Semigroup (Min(..))
+import Data.Monoid
 
 import Sequence.Contact.Types
 import Sequence.Formula ((:<:)(..))
@@ -59,30 +61,23 @@ faction' = lens (CI.original . fromMaybe unaligned . view faction) (\s a -> s {
       | otherwise         = Just str'
 
 
-newtype SeqVal = SeqVal { _seqVal :: Int }
-  deriving (Show, Ord, Eq, Num, Integral, Enum, Real)
-
-seqVal :: Integral a => Iso' a SeqVal
-seqVal = iso (SeqVal . fromIntegral) (fromIntegral . _seqVal)
-
-seqVal' :: Prism' String SeqVal
-seqVal' = _Show . seqVal
-
-
 data Entity = Entity
-              { _eSeqVal :: Maybe SeqVal
-              , _eFaction :: Faction
+              { _eFaction :: Faction
               , _eStats :: Stats
+              , _eNotes :: [String]
               }
 makeLenses ''Entity
 
 instance Default Entity where
   def = Entity
-        { _eSeqVal = def
-        , _eFaction = def
+        { _eFaction = def
         , _eStats = def
+        , _eNotes = []
         }
 
+eSeqVal :: Lens' Entity (Maybe SeqVal)
+eSeqVal = eStats . sSequence
+
 instance (Entity :<: a) => Stats :<: a where
   ctx' = ctx' . eStats
 
@@ -132,17 +127,11 @@ tip :: Fold GameState EntityIdentifier
 tip = priorityQueue . folding (fmap snd . listToMaybe)
 
 gFocus' :: Traversal' GameState Entity
-gFocus' modifyFocus = do
-  focusIdent <- view gFocus
-  case focusIdent of
-    Nothing -> pure <$> ask
-    Just focusIdent -> do
-      focus <- view (gEntities . at focusIdent)
-      case focus of
-        Nothing -> pure <$> ask
-        Just focus -> do
-          st <- ask
-          return $ flip (set $ gEntities . at focusIdent) st . Just <$> modifyFocus focus
+gFocus' modifyFocus st = (flip runReader st) . (maybe (asks pure) return =<<) . runMaybeT $ do
+  focusIdent <- MaybeT $ view gFocus
+  focus <- MaybeT $ view (gEntities . at focusIdent)
+  st <- ask
+  return $ flip (set $ gEntities . at focusIdent) st . Just <$> modifyFocus focus
       
 -- gFocus' = prism' getFocus setFocus
 --   where
@@ -163,3 +152,12 @@ insertEntity entity = execState $ do
   gEntities . at identifier ?= entity
   gNextId %= succ
   
+gRound :: Lens' GameState Int
+gRound = lens lowestRound $ flip trimBelow
+  where
+    lowestRound = getMin . (<> Min 0) . view (gEntities . each . eStats . sSequence . _Just . seqRound . _Unwrapped)
+    trimBelow = over (gEntities . each . eStats . sSequence) . trimBelow'
+    trimBelow' cutoff = runReader . runMaybeT $ do
+      round <- MaybeT . preview $ _Just . seqRound
+      guard $ round >= cutoff
+      MaybeT ask