1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
|
{-# 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 Control.Monad.Trans.Maybe
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 "" mzero
instance Monoid Effect where
mempty = def
(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))
$ runMaybeT bEff
where
name
| aName /= ""
, bName /= "" = aName <> ", " <> bName
| otherwise = aName <> bName
effect :: String -> Effect
effect str = def & set effectName str
instance IsString Effect where
fromString = effect
makeLenses ''Test
instance Default Test where
def = Test
{ _tName = ""
, _tCritSuccessMod = 0
, _tCritFailureMod = 0
, _tBaseDifficulty = 50
, _tMod = 0
, _tEffect = const mzero
}
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) . MaybeT $ 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) ]
|