path: root/src/Sequence/Contact/Types.hs

{-# LANGUAGE TemplateHaskell, RecordWildCards, OverloadedStrings, OverloadedLists, ViewPatterns, RankNTypes, ImpredicativeTypes, FlexibleContexts, TypeSynonymInstances, FlexibleInstances, StandaloneDeriving #-}

module Sequence.Contact.Types
  ( module Sequence.Contact.Types
  , module Sequence.Contact.Types.Internal
  ) where

import Sequence.Formula

import Control.Monad
import Control.Lens hiding (Context)

import Data.Default

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 Data.List
import Data.Ord
import Data.ExtendedReal
import Data.Monoid (Monoid(..), (<>))
import Data.Dynamic
import Data.Dynamic.Lens

import Control.Monad.Reader (ask, local)
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

makePrisms ''Hitzone

makePrisms ''DamageType

instance {-# OVERLAPS #-} Default Armor where
  def = const $ return 0

makeLenses ''DiceResult

makeLenses ''TestResult

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

effectName :: Lens' Effect String
effectName = _Effect . _1 . iso CI.original CI.mk

instance Eq Effect where
  (==) = (==) `on` (view effectName)

instance Ord Effect where
  compare = compare `on` (view effectName)

instance Show Effect where
  show = show . view effectName

instance Default Effect where
  def = Effect "" $ preview ctx

instance Monoid Effect where
  mempty = def
  (Effect aName aEff) `mappend` (Effect bName bEff) = Effect name $ do
    new <- 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
    where
      name
        | aName /= ""
        , bName /= "" = aName <> ", " <> bName
        | otherwise = aName <> bName

effect :: String -> Effect
effect str = def & set effectName str

makeLenses ''Test

instance Default Test where
  def = Test
        { _tName = ""
        , _tCritSuccessMod = 0
        , _tCritFailureMod = 0
        , _tBaseDifficulty = 50
        , _tMod = 0
        , _tEffect = const $ pure (def :: Effect)
        }

deriving instance Eq TestResult
deriving instance Ord TestResult
deriving instance Show TestResult

makePrisms ''SeqVal
makeLenses ''SeqVal

instance Default SeqVal where
  def = SeqVal { _seqRound = Down 0
               , _seqVal = Nothing
               , _seqEpsilon = False
               }

makeLenses ''ShockEffect

absTime :: Lens' Timer Rational
absTime = lens get set
  where
    get (Constant n) = n
    get (Scaled n) = n
    set (Constant _) n = Constant n
    set (Scaled _) n = Scaled n

instance Eq Timer where
  (==) = (==) `on` view absTime

instance Ord Timer where
  compare = comparing $ view absTime
  
instance Default ShockEffect where
  def = ShockEffect { _seApplied = False
                    , _seVal = ignored
                    , _seBar = ignored
                    , _seReBar = ignored
                    , _seEffect = def
                    }

makeLenses ''Stats

instance Default Stats where
  def = Prop
        { _sRobustness = Nothing

        , _sSeqEpsilon = False
        
        , _sHitzones = [("Volumen", 1)]
        , _sArmor = const def
        , _sCripple = const def

        , _sDamage = const 0
        , _sFatigue = 0

        , _sSequence = Nothing
        , _sTimer = Nothing
        
        , _sPainShock = def
        , _sFatigueShock = def

        , _sExtraSkills = []
        , _sModifiers = []

        , _sEquipment = []
        }

applyModifier :: String -> (Test -> FormulaM Stats Test) -> Effect
applyModifier effectName modifier = Effect (CI.mk effectName) $ previews ctx apply
  where
    apply = sModifiers <>~ [Modifier (CI.mk $ effectName ++ " (modifier)") modifier]

vStrength = val sAStrength ["Stärke"] True
vEndurance = val sAEndurance ["Ausdauer"] True
vMass = val sAMass ["Masse"] True
vReflexes = val sAReflexes ["Reflexe"] True
vMobility = val sAMobility ["Beweglichkeit"] True
vDexterity = val sADexterity ["Geschicklichkeit"] True
vIntelligence = val sAIntelligence ["Intelligenz"] True
vCharisma = val sACharisma ["Charisma"] True
vPerception = val sAPerception ["Wahrnehmung"] True
vWillpower = val sAWillpower ["Entschlossenheit"] True

scaled :: Ratio Int -> Iso' Int Int
scaled r = iso (\x -> floor $ x % 1 * r) (\x -> round $ x % 1 / r)

sDamage' :: Hitzone -> Traversal' Stats Int
sDamage' zone = sDamage . ix zone

sCripple' :: Hitzone -> Traversal' Stats ShockEffect
sCripple' zone = sCripple . ix zone

sEquipment' :: Typeable a => String -> Lens' Stats (Maybe a)
sEquipment' (CI.mk -> k) = lens (preview _Dynamic <=< view (sEquipment . at k)) (flip $ set (sEquipment . at k) . (preview (re _Dynamic) =<<))

sTotalDamage :: Lens' Stats Int
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, sUnconscious, sDestroyed :: Fold Stats (FormulaM Stats Bool)
sDead = folding $ do
  maxVitality <- preview sMaxVitality
  damage <- view sTotalDamage
  return $ liftM2 (>=) <$> Just (return damage) <*> maxVitality
sUnconscious = folding $ do
  maxVitality <- preview sMaxVitality
  damage <- view sFatigue
  return $ liftM2 (>=) <$> Just (return damage) <*> maxVitality
sDestroyed = folding $ do
  robustness <- preview $ sRobustness . _Just
  damage <- view sTotalDamage
  return $ liftM2 (>=) <$> Just (return damage) <*> robustness

absorb :: Armor -> DamageType -> Int -> FormulaM Stats (Map DamageType Int)
absorb armor dType (Finite -> dmg) = fmap ensureFinite <$> absorb' Map.empty dType dmg
  where
    absorb' :: Map DamageType Int' -> DamageType -> Int' -> FormulaM Stats (Map DamageType Int')
    absorb' old dType dmg = do
      mass <- maybe (return (Nothing :: Maybe Int')) (fmap $ Just . Finite) =<< preview (ctx . sAMass)
      armor' <- wArmor dType
      let
        current = transmit mass dType $ min dmg armor'
      new <- Map.unionsWith (+) <$> (sequence . Map.elems $ Map.mapWithKey (absorb' current) current)
      return . Map.unionWith (+) (leftover mass dType . clamp $ dmg - armor') $ if old /= current then new else current

    ensureFinite (Finite n) = n
    ensureFinite _ = error "Infinite amounts of damage should not occur"

    wArmor :: DamageType -> FormulaM Stats Int'
    wArmor Passthrough = 0
    wArmor Fatigue = 0
    wArmor Electric = (2 *) . maximum . filter isFinite <$> mapM wArmor ([minBound..maxBound] \\ [Electric] :: [DamageType])
    wArmor x = armor x

    clamp n
      | n <= 0 = 0
      | otherwise = n

    transmit, leftover :: Maybe Int' -> DamageType -> Int' -> Map DamageType Int'
    transmit  _       Ballistic n = [ (Blunt, n) ]
    transmit  _       Piercing  n = [ (Blunt, n) ]
    transmit  _       _         _ = []


    leftover (Just m) Blunt     n = [ (Fatigue, min n m)
                                    , (Blunt, clamp $ n - m)
                                    ]
    leftover (Just m) Cold      n = [ (Fatigue, min n $ m * 2)
                                    , (Cold, clamp $ n - m * 2)
                                    ]
    leftover _        Explosive n = [ (Fatigue, n)
                                    , (Explosive, n)
                                    ]
    leftover _        dType     n = [ (dType, n) ]