summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorGregor Kleen <pngwjpgh@users.noreply.github.com>2017-01-16 18:10:17 +0100
committerGregor Kleen <pngwjpgh@users.noreply.github.com>2017-01-16 18:10:17 +0100
commitce890f4b6fd478bf5a254390f5bc49e4afd97c8c (patch)
treefb5a239a32b610470cbefbd279f465df89c5f5f1 /src
parent7ff2052235140669bc9e9c5c1e94b194626dee67 (diff)
download2017-01-16_17:13:37-rewrite.tar
2017-01-16_17:13:37-rewrite.tar.gz
2017-01-16_17:13:37-rewrite.tar.bz2
2017-01-16_17:13:37-rewrite.tar.xz
2017-01-16_17:13:37-rewrite.zip
Burstfirerewrite
Diffstat (limited to 'src')
-rw-r--r--src/Main.hs57
-rw-r--r--src/Sequence/Contact/Archetypes.hs61
-rw-r--r--src/Sequence/Contact/Tests.hs56
-rw-r--r--src/Sequence/Contact/Types.hs16
-rw-r--r--src/Sequence/Contact/Types/Internal.hs10
-rw-r--r--src/Sequence/Formula.hs13
-rw-r--r--src/Sequence/Utils.hs15
7 files changed, 167 insertions, 61 deletions
diff --git a/src/Main.hs b/src/Main.hs
index 236e779..a0799e0 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -19,6 +19,9 @@ import qualified Data.CaseInsensitive as CI
19 19
20import Data.Map.Strict (Map) 20import Data.Map.Strict (Map)
21import qualified Data.Map.Strict as Map 21import qualified Data.Map.Strict as Map
22
23import Data.Map as Lazy (Map)
24import qualified Data.Map as Lazy.Map
22 25
23import Data.Set (Set) 26import Data.Set (Set)
24import qualified Data.Set as Set 27import qualified Data.Set as Set
@@ -34,7 +37,7 @@ import Data.List
34import Data.List 37import Data.List
35import Data.Maybe 38import Data.Maybe
36import Data.Bool 39import Data.Bool
37import Data.Monoid (All(..)) 40import Data.Monoid (Monoid(..), (<>), All(..))
38import Data.Ord 41import Data.Ord
39import Data.Ratio 42import Data.Ratio
40 43
@@ -67,6 +70,8 @@ import qualified Data.Text.Lazy as Lazy (Text)
67import qualified Data.Text.Lazy as Lazy.Text 70import qualified Data.Text.Lazy as Lazy.Text
68import Data.Text.Template 71import Data.Text.Template
69 72
73import Debug.Trace
74
70main :: IO () 75main :: IO ()
71main = do 76main = do
72 historyFile <- getUserCacheFile "sequence" "history" 77 historyFile <- getUserCacheFile "sequence" "history"
@@ -115,6 +120,7 @@ main = do
115 , cmd "log" dumpLog "Print the combat log" 120 , cmd "log" dumpLog "Print the combat log"
116 , cmd "val" printVal "Find the distribution of a specific value of the current entities" 121 , cmd "val" printVal "Find the distribution of a specific value of the current entities"
117 , cmd "summary" printVals "Find the averages of applicable all values" 122 , cmd "summary" printVals "Find the averages of applicable all values"
123 , cmd "burstfire" burstfire "Roll an automatic burst of <n> shots against given skill compensating for recoil with the given attribute"
118 ] 124 ]
119 , wordBreakChars = wordBreakChars initialShellDescription \\ [',', '\''] 125 , wordBreakChars = wordBreakChars initialShellDescription \\ [',', '\'']
120 } 126 }
@@ -385,7 +391,13 @@ spawnFaction cFaction num cEntity nameTemplate
385 391
386-- Dice rolls 392-- Dice rolls
387rollTest :: Completable (FormulaM Stats Test) -> Sh GameState () 393rollTest :: Completable (FormulaM Stats Test) -> Sh GameState ()
388rollTest = withArg $ maybe (return ()) ((>>) <$> outputResult <*> applyEffect) <=< enactTest' 394rollTest = withArg rollTest'
395
396rollTest' :: FormulaM Stats Test -> Sh GameState ()
397rollTest' = rollTest'' Nothing
398
399rollTest'' :: Maybe (Formula Stats) -> FormulaM Stats Test -> Sh GameState ()
400rollTest'' testMod = maybe (return ()) ((>>) <$> outputResult <*> applyEffect) <=< enactTest' testMod
389 where 401 where
390 outputResult :: (String, TestResult) -> Sh GameState () 402 outputResult :: (String, TestResult) -> Sh GameState ()
391 outputResult (test, view (rRoll . to ppResult) -> result) = do 403 outputResult (test, view (rRoll . to ppResult) -> result) = do
@@ -408,7 +420,8 @@ rollTest = withArg $ maybe (return ()) ((>>) <$> outputResult <*> applyEffect) <
408 420
409 421
410 applyEffect :: (String, TestResult) -> Sh GameState () 422 applyEffect :: (String, TestResult) -> Sh GameState ()
411 applyEffect (test, view rResult -> (Effect (CI.original -> effectDesc) effect)) = void . runMaybeT $ do 423 applyEffect (_, view rResult -> Nothing) = return ()
424 applyEffect (test, view rResult -> Just (Effect (CI.original -> effectDesc) effect)) = void . runMaybeT $ do
412 focusId <- MaybeT $ use gFocus 425 focusId <- MaybeT $ use gFocus
413 name <- toName focusId 426 name <- toName focusId
414 let 427 let
@@ -416,15 +429,15 @@ rollTest = withArg $ maybe (return ()) ((>>) <$> outputResult <*> applyEffect) <
416 lStats = gEntities . ix focusId . eStats 429 lStats = gEntities . ix focusId . eStats
417 evalF = MaybeT . focusState lStats . evalFormula' [name] 430 evalF = MaybeT . focusState lStats . evalFormula' [name]
418 guard =<< askBool ("Apply effects (" ++ effectDesc ++ ")?") True 431 guard =<< askBool ("Apply effects (" ++ effectDesc ++ ")?") True
419 lStats <~ (MaybeT . fmap join . runMaybeT $ evalF effect) 432 lStats <~ (MaybeT . fmap join . runMaybeT . evalF $ runMaybeT effect)
420 lift . outputLogged focusId $ test ++ " effects: " ++ effectDesc 433 lift . outputLogged focusId $ test ++ " effects: " ++ effectDesc
421 434
422enactTest' :: FormulaM Stats Test -> Sh GameState (Maybe (String, TestResult)) 435enactTest' :: Maybe (Formula Stats) -> FormulaM Stats Test -> Sh GameState (Maybe (String, TestResult))
423enactTest' test = runMaybeT $ do 436enactTest' testMod test = runMaybeT $ do
424 focusName <- MaybeT (use gFocus) >>= lift . toName 437 focusName <- MaybeT (use gFocus) >>= lift . toName
425 let evalF = MaybeT . focusState (gFocus' . eStats) . evalFormula' [focusName] 438 let evalF = MaybeT . focusState (gFocus' . eStats) . evalFormula' [focusName]
426 test' <- evalF test 439 test' <- evalF test
427 result <- evalF $ enactTest test' 440 result <- evalF $ (maybe enactTest (flip enactTestMod) testMod) test'
428 return (view (tName . to CI.original) test', result) 441 return (view (tName . to CI.original) test', result)
429 442
430entitySeqVal :: Sh GameState () 443entitySeqVal :: Sh GameState ()
@@ -502,7 +515,7 @@ doShock dmg efLens = withFocus $ \focusId -> do
502 else guard $ val >= bar 515 else guard $ val >= bar
503 lStats . efLens . seApplied .= True 516 lStats . efLens . seApplied .= True
504 Effect (CI.original -> effectName) effect <- evalF . table $ cripple ^. seEffect 517 Effect (CI.original -> effectName) effect <- evalF . table $ cripple ^. seEffect
505 lStats <~ (MaybeT . fmap join . runMaybeT $ evalF effect) 518 lStats <~ (MaybeT . fmap join . runMaybeT . evalF $ runMaybeT effect)
506 lift . outputLogged focusId $ "Effect: " ++ effectName 519 lift . outputLogged focusId $ "Effect: " ++ effectName
507 lift . addNote $ "Effect: " ++ effectName 520 lift . addNote $ "Effect: " ++ effectName
508 521
@@ -586,3 +599,31 @@ printVals = withFocus $ \focusId -> do
586 Just avg -> shellPutStrLn $ printf "%*s: %5.1f" maxLength (CI.original str) (fromRational avg :: Double) 599 Just avg -> shellPutStrLn $ printf "%*s: %5.1f" maxLength (CI.original str) (fromRational avg :: Double)
587 Nothing -> return () 600 Nothing -> return ()
588 mapM_ printAvg $ Map.toList sheet 601 mapM_ printAvg $ Map.toList sheet
602
603burstfire :: Int -> Completable (Formula Stats) -> Completable (Formula Stats) -> Sh GameState ()
604burstfire nShots skill' attr' = skill' <~> \skill -> attr' <~> \attr -> withFocus (burstfire' skill attr)
605 where
606 burstfire' skill attr focusId = void . runMaybeT $ do
607 name <- lift $ toName focusId
608 let
609 lStats :: Traversal' GameState Stats
610 lStats = gEntities . ix focusId . eStats
611 evalF formula = do
612 stats <- MaybeT $ preuse lStats
613 (nStats, x) <- (evalFormula [name] :: Stats -> FormulaM Stats a -> MaybeT (Sh GameState) (Stats, a)) stats formula
614 lStats .= nStats
615 return x
616 skillVal <- evalF skill
617 attrVal <- evalF attr
618 minStrRaw <- evalF $ val ignored ["Mindeststärke der Waffe"] False
619 minStrMod <- evalF $ val ignored ["Mindeststärke der Waffe", "Modifikator"] False
620 mod <- evalF $ val ignored ["Modifikator"] False
621 let
622 recoilMod = max 0 $ 10 + (minStr - attrVal)
623 minStr = minStrRaw + minStrMod
624 lift . forM_ [1..nShots] $ \n -> do
625 rollTest'' (Just $ fromIntegral mod) . return $ def
626 & tName . iso CI.original CI.mk .~ printf "Schuss %2d" n
627 & tBaseDifficulty .~ skillVal
628 & tMod .~ (n - 1) * (-recoilMod)
629 & tEffect .~ MaybeT . table . critTables "Fernkampfangriffe"
diff --git a/src/Sequence/Contact/Archetypes.hs b/src/Sequence/Contact/Archetypes.hs
index b8bc1b0..566d72d 100644
--- a/src/Sequence/Contact/Archetypes.hs
+++ b/src/Sequence/Contact/Archetypes.hs
@@ -75,11 +75,8 @@ archetypes = [ ("Requisite", prop)
75 , ("AUV", auv) 75 , ("AUV", auv)
76 ] 76 ]
77 77
78cTable :: Ord v => [(Integer, Integer, v)] -> Table v
79cTable = Map.fromList . map (\(from, to, value) -> (value, (abs (to - from) + 1) % 100))
80
81death :: Hitzone -> Effect 78death :: Hitzone -> Effect
82death zone = Effect "Tod" . runMaybeT $ do 79death zone = Effect "Tod" $ do
83 maxVitality <- (MaybeT . preview $ ctx . sMaxVitality) >>= lift 80 maxVitality <- (MaybeT . preview $ ctx . sMaxVitality) >>= lift
84 currentDmg <- MaybeT . preview $ ctx . sDamage' zone 81 currentDmg <- MaybeT . preview $ ctx . sDamage' zone
85 allDmg <- MaybeT . preview $ ctx . sTotalDamage 82 allDmg <- MaybeT . preview $ ctx . sTotalDamage
@@ -87,16 +84,16 @@ death zone = Effect "Tod" . runMaybeT $ do
87 dmg' = if dmg >= 0 then dmg else 0 84 dmg' = if dmg >= 0 then dmg else 0
88 MaybeT . previews ctx $ set (sDamage' zone) dmg' 85 MaybeT . previews ctx $ set (sDamage' zone) dmg'
89 86
90unconsciousR :: Formula Stats -> FormulaM Stats (Maybe Stats) 87unconsciousR :: Formula Stats -> FormulaMT MaybeT Stats Stats
91unconsciousR roundsF = do 88unconsciousR roundsF = do
92 rounds <- roundsF 89 rounds <- lift roundsF
93 previews ctx $ over (sSequence . _Just . seqRound . _Wrapped) (+ rounds) 90 MaybeT . previews ctx $ over (sSequence . _Just . seqRound . _Wrapped) (+ rounds)
94 91
95unconscious :: FormulaM Stats (Maybe Stats) 92unconscious :: FormulaMT MaybeT Stats Stats
96unconscious = previews ctx $ set sSequence Nothing 93unconscious = MaybeT . previews ctx $ set sSequence Nothing
97 94
98amputate :: Hitzone -> Effect 95amputate :: Hitzone -> Effect
99amputate zone = Effect (CI.mk $ review hitzone zone ++ " ist verloren") . runMaybeT $ do 96amputate zone = Effect (CI.mk $ review hitzone zone ++ " ist verloren") $ do
100 hitzones <- MaybeT . preview $ ctx . sHitzones 97 hitzones <- MaybeT . preview $ ctx . sHitzones
101 (fromRational -> zoneProp) <- MaybeT . return $ Map.lookup zone hitzones 98 (fromRational -> zoneProp) <- MaybeT . return $ Map.lookup zone hitzones
102 MaybeT . previews ctx . execState $ do 99 MaybeT . previews ctx . execState $ do
@@ -221,7 +218,7 @@ human = Humanoid
221 & set seBar (vitBar 0.75) 218 & set seBar (vitBar 0.75)
222 & set seReBar (vitBar 0.2) 219 & set seReBar (vitBar 0.2)
223 & set seEffect (cTable [ (1, 5, death "Torso") 220 & set seEffect (cTable [ (1, 5, death "Torso")
224 , (6, 25, Effect "Organschäden" . previews ctx $ over sFatigue (+ 25) . over (sDamage' "Torso") (+ 10)) 221 , (6, 25, Effect "Organschäden" . MaybeT . previews ctx $ over sFatigue (+ 25) . over (sDamage' "Torso") (+ 10))
225 , (26, 45, effect "Innere Blutung (3 Schaden (Au) Minuten)") 222 , (26, 45, effect "Innere Blutung (3 Schaden (Au) Minuten)")
226 , (46, 75, Effect "Bewusstlos" unconscious) 223 , (46, 75, Effect "Bewusstlos" unconscious)
227 , (76, 100, Effect "Bewusstlos" . unconsciousR $ d 10) 224 , (76, 100, Effect "Bewusstlos" . unconsciousR $ d 10)
@@ -234,7 +231,7 @@ human = Humanoid
234 & set seBar (vitBar 0.2) 231 & set seBar (vitBar 0.2)
235 & set seReBar (vitBar 0.2) 232 & set seReBar (vitBar 0.2)
236 & set seEffect ( cTable [ (1, 5, effect "Querschnittsgelähmt") 233 & set seEffect ( cTable [ (1, 5, effect "Querschnittsgelähmt")
237 , (6, 25, Effect "Kastration" . previews ctx $ over sFatigue (+ 15)) 234 , (6, 25, Effect "Kastration" . MaybeT . previews ctx $ over sFatigue (+ 15))
238 , (26, 50, effect "Innere Blutung (2 Schaden (Au) Minuten)") 235 , (26, 50, effect "Innere Blutung (2 Schaden (Au) Minuten)")
239 , (51, 100, Effect "Bewusstlos" unconscious) 236 , (51, 100, Effect "Bewusstlos" unconscious)
240 ]) 237 ])
@@ -255,14 +252,14 @@ human = Humanoid
255 , (6, 25, Effect "Koma" unconscious) 252 , (6, 25, Effect "Koma" unconscious)
256 , (26, 45, Effect "Bewusstlos" . unconsciousR $ d 10) 253 , (26, 45, Effect "Bewusstlos" . unconsciousR $ d 10)
257 , (46, 75, Effect "Bewusstlos" unconscious) 254 , (46, 75, Effect "Bewusstlos" unconscious)
258 , (76, 100, Effect "Verlangsamt" $ d 10 >>= (\loss -> previews ctx $ over (sSequence . _Just . seqVal . _Just) (+ (-loss)))) 255 , (76, 100, Effect "Verlangsamt" $ lift (d 10) >>= (\loss -> MaybeT . previews ctx $ over (sSequence . _Just . seqVal . _Just) (+ (-loss))))
259 ]) 256 ])
260 , _sFatigueShock = def 257 , _sFatigueShock = def
261 & set seReBar (vitBar 0.75) 258 & set seReBar (vitBar 0.75)
262 & set seEffect ( cTable [ (1, 25, Effect "Bewusstlos" . unconsciousR $ 2 * d 10) 259 & set seEffect ( cTable [ (1, 25, Effect "Bewusstlos" . unconsciousR $ 2 * d 10)
263 , (26, 50, Effect "Bewusstlos" . unconsciousR $ d 10) 260 , (26, 50, Effect "Bewusstlos" . unconsciousR $ d 10)
264 , (51, 75, Effect "Bewusstlos" unconscious) 261 , (51, 75, Effect "Bewusstlos" unconscious)
265 , (76, 100, Effect "Verlangsamt" $ 2 * d 10 >>= (\loss -> previews ctx $ over (sSequence . _Just . seqVal . _Just) (+ (-loss)))) 262 , (76, 100, Effect "Verlangsamt" $ lift (2 * d 10) >>= (\loss -> MaybeT . previews ctx $ over (sSequence . _Just . seqVal . _Just) (+ (-loss))))
266 ]) 263 ])
267 264
268 , _sExtraSkills = [] 265 , _sExtraSkills = []
@@ -278,7 +275,7 @@ human = Humanoid
278 & set seEffect (cTable [ (1, 10, amputate zone) 275 & set seEffect (cTable [ (1, 10, amputate zone)
279 , (11, 25, effect $ review hitzone zone ++ " ist gelähmt und unbrauchbar") 276 , (11, 25, effect $ review hitzone zone ++ " ist gelähmt und unbrauchbar")
280 , (26, 45, effect $ review hitzone zone ++ " hat eingeschränkte Funktion (-50%)") 277 , (26, 45, effect $ review hitzone zone ++ " hat eingeschränkte Funktion (-50%)")
281 , (46, 75, Effect "Schwerste Schmerzen" . previews ctx $ over sFatigue (+ 10)) 278 , (46, 75, Effect "Schwerste Schmerzen" . MaybeT . previews ctx $ over sFatigue (+ 10))
282 , (76, 100, effect "Fleischwunde") 279 , (76, 100, effect "Fleischwunde")
283 ]) 280 ])
284 bein zone = def 281 bein zone = def
@@ -287,7 +284,7 @@ human = Humanoid
287 & set seReBar (vitBar 0.2) 284 & set seReBar (vitBar 0.2)
288 & set seEffect (cTable [ (1, 10, amputate zone) 285 & set seEffect (cTable [ (1, 10, amputate zone)
289 , (11, 45, effect $ review hitzone zone ++ " ist gelähmt und unbrauchbar (halbierte Bewegung)") 286 , (11, 45, effect $ review hitzone zone ++ " ist gelähmt und unbrauchbar (halbierte Bewegung)")
290 , (46, 75, Effect "Schwerste Schmerzen" . previews ctx $ over sFatigue (+ 10)) 287 , (46, 75, Effect "Schwerste Schmerzen" . MaybeT . previews ctx $ over sFatigue (+ 10))
291 , (76, 100, effect "Fleischwunde") 288 , (76, 100, effect "Fleischwunde")
292 ]) 289 ])
293 290
@@ -343,7 +340,7 @@ dog = Quadruped
343 & set seBar (vitBar 0.75) 340 & set seBar (vitBar 0.75)
344 & set seReBar (vitBar 0.2) 341 & set seReBar (vitBar 0.2)
345 & set seEffect ( cTable [ (1, 5, death "Torso") 342 & set seEffect ( cTable [ (1, 5, death "Torso")
346 , (6, 25, Effect "Organschäden" . previews ctx $ over sFatigue (+ 25) . over (sDamage' "Torso") (+ 10)) 343 , (6, 25, Effect "Organschäden" . MaybeT . previews ctx $ over sFatigue (+ 25) . over (sDamage' "Torso") (+ 10))
347 , (26, 45, effect "Innere Blutung (3 Schaden (Au) Minuten)") 344 , (26, 45, effect "Innere Blutung (3 Schaden (Au) Minuten)")
348 , (46, 75, Effect "Bewusstlos" unconscious) 345 , (46, 75, Effect "Bewusstlos" unconscious)
349 , (76, 100, Effect "Bewusstlos" . unconsciousR $ d 10) 346 , (76, 100, Effect "Bewusstlos" . unconsciousR $ d 10)
@@ -354,7 +351,7 @@ dog = Quadruped
354 & set seBar (vitBar 0.2) 351 & set seBar (vitBar 0.2)
355 & set seReBar (vitBar 0.2) 352 & set seReBar (vitBar 0.2)
356 & set seEffect ( cTable [ (1, 5, effect "Querschnittsgelähmt") 353 & set seEffect ( cTable [ (1, 5, effect "Querschnittsgelähmt")
357 , (6, 25, Effect "Kastration" . previews ctx $ over sFatigue (+ 10)) 354 , (6, 25, Effect "Kastration" . MaybeT . previews ctx $ over sFatigue (+ 10))
358 , (26, 50, effect "Innere Blutung (2 Schaden (Au) Minuten)") 355 , (26, 50, effect "Innere Blutung (2 Schaden (Au) Minuten)")
359 , (51, 100, Effect "Bewusstlos" . unconsciousR $ 2 * d 10) 356 , (51, 100, Effect "Bewusstlos" . unconsciousR $ 2 * d 10)
360 ]) 357 ])
@@ -386,8 +383,8 @@ dog = Quadruped
386 & set seReBar (vitBar 0.2) 383 & set seReBar (vitBar 0.2)
387 & set seEffect ( cTable [ (1, 10, amputate zone) 384 & set seEffect ( cTable [ (1, 10, amputate zone)
388 , (11, 25, effect $ review hitzone zone ++ " ist gelähmt und unbrauchbar (halbierte Bewegung)") 385 , (11, 25, effect $ review hitzone zone ++ " ist gelähmt und unbrauchbar (halbierte Bewegung)")
389 , (26, 45, Effect "Schmerzen" . previews ctx $ over sFatigue (+ 15)) 386 , (26, 45, Effect "Schmerzen" . MaybeT . previews ctx $ over sFatigue (+ 15))
390 , (46, 100, Effect "Fleischwunde" . previews ctx $ over sFatigue (+ 5)) 387 , (46, 100, Effect "Fleischwunde" . MaybeT . previews ctx $ over sFatigue (+ 5))
391 ]) 388 ])
392 389
393dolphin = Dolphin 390dolphin = Dolphin
@@ -437,7 +434,7 @@ dolphin = Dolphin
437 & set seBar (vitBar 0.8) 434 & set seBar (vitBar 0.8)
438 & set seReBar (vitBar 0.2) 435 & set seReBar (vitBar 0.2)
439 & set seEffect ( cTable [ (1, 5, death "Rumpf") 436 & set seEffect ( cTable [ (1, 5, death "Rumpf")
440 , (6, 25, Effect "Organschäden" . previews ctx $ over sFatigue (+ 7) . over (sDamage' "Rumpf") (+ 20)) 437 , (6, 25, Effect "Organschäden" . MaybeT . previews ctx $ over sFatigue (+ 7) . over (sDamage' "Rumpf") (+ 20))
441 , (26, 45, effect "Blutung (2 Schaden (Au) Minuten)") 438 , (26, 45, effect "Blutung (2 Schaden (Au) Minuten)")
442 , (46, 75, Effect "Bewusstlos" unconscious) 439 , (46, 75, Effect "Bewusstlos" unconscious)
443 , (76, 100, Effect "Bewusstlos" . unconsciousR $ d 10) 440 , (76, 100, Effect "Bewusstlos" . unconsciousR $ d 10)
@@ -449,7 +446,7 @@ dolphin = Dolphin
449 & set seReBar (vitBar 0.2) 446 & set seReBar (vitBar 0.2)
450 & set seEffect ( cTable [ (1, 10, amputate "Schwanz") 447 & set seEffect ( cTable [ (1, 10, amputate "Schwanz")
451 , (11, 25, effect "Halbierte Bewegung") 448 , (11, 25, effect "Halbierte Bewegung")
452 , (26, 45, Effect "Schmerz" . previews ctx $ over sFatigue (+ 15)) 449 , (26, 45, Effect "Schmerz" . MaybeT . previews ctx $ over sFatigue (+ 15))
453 , (46, 100, effect "Fleischwunde") 450 , (46, 100, effect "Fleischwunde")
454 ]) 451 ])
455 ) 452 )
@@ -508,28 +505,28 @@ silicoid = Silicoid
508 & set seVal (sDamage' "Auge" . to return) 505 & set seVal (sDamage' "Auge" . to return)
509 & set seBar (vitBar 0.2) 506 & set seBar (vitBar 0.2)
510 & set seReBar (vitBar 0.2) 507 & set seReBar (vitBar 0.2)
511 & set seEffect ( cTable [ (1, 25, effect "Explosion") 508 & set seEffect ( cTable [ (1, 25, "Explosion")
512 , (26, 75, effect "Permanent desorientiert (nur rammen in zufällige Richtungen)") 509 , (26, 75, "Permanent desorientiert (nur rammen in zufällige Richtungen)")
513 , (76, 100, effect "Detonation in 3w10 AP") 510 , (76, 100, "Detonation in 3w10 AP")
514 ]) 511 ])
515 ) 512 )
516 , ("Thorax", def 513 , ("Thorax", def
517 & set seVal (sDamage' "Thorax" . to return) 514 & set seVal (sDamage' "Thorax" . to return)
518 & set seBar (vitBar 0.65) 515 & set seBar (vitBar 0.65)
519 & set seReBar (vitBar 0.2) 516 & set seReBar (vitBar 0.2)
520 & set seEffect ( cTable [ (1, 10, effect "Explosion") 517 & set seEffect ( cTable [ (1, 10, "Explosion")
521 , (11, 25, effect "Halbe Bewegung") 518 , (11, 25, "Halbe Bewegung")
522 , (26, 65, effect "10 Schaden, Sprühattacke auf nächsten Charakter (Blut)") 519 , (26, 65, "10 Schaden, Sprühattacke auf nächsten Charakter (Blut)")
523 , (66, 100, effect "3w10 Erschöpfung") 520 , (66, 100, "3w10 Erschöpfung")
524 ]) 521 ])
525 ) 522 )
526 , ("Schwanz", def 523 , ("Schwanz", def
527 & set seVal (sDamage' "Schwanz" . to return) 524 & set seVal (sDamage' "Schwanz" . to return)
528 & set seBar (vitBar 0.2) 525 & set seBar (vitBar 0.2)
529 & set seReBar (vitBar 0.2) 526 & set seReBar (vitBar 0.2)
530 & set seEffect ( cTable [ (1, 25, effect "10 Schaden, Schwanzdrüse unbrauchbar") 527 & set seEffect ( cTable [ (1, 25, "10 Schaden, Schwanzdrüse unbrauchbar")
531 , (26, 60, effect "3 Schaden, Sprühattacke auf nächsten Charakter (Blut)") 528 , (26, 60, "3 Schaden, Sprühattacke auf nächsten Charakter (Blut)")
532 , (61, 100, effect "Amok und Detonation nach 1w10+6 AP") 529 , (61, 100, "Amok und Detonation nach 1w10+6 AP")
533 ]) 530 ])
534 ) 531 )
535 ] <> Map.fromList [(name, bein name) | side <- ["Rechtes", "Linkes"], length <- ["Vorderes", "Mittleres", "Hinteres"], let name = Hitzone . CI.mk $ side ++ " " ++ length ++ " Bein"] 532 ] <> Map.fromList [(name, bein name) | side <- ["Rechtes", "Linkes"], length <- ["Vorderes", "Mittleres", "Hinteres"], let name = Hitzone . CI.mk $ side ++ " " ++ length ++ " Bein"]
diff --git a/src/Sequence/Contact/Tests.hs b/src/Sequence/Contact/Tests.hs
index d10819e..be61ed3 100644
--- a/src/Sequence/Contact/Tests.hs
+++ b/src/Sequence/Contact/Tests.hs
@@ -1,7 +1,8 @@
1{-# LANGUAGE TemplateHaskell, OverloadedStrings, OverloadedLists, ViewPatterns, MultiParamTypeClasses, FlexibleContexts, RankNTypes, TypeSynonymInstances, FlexibleInstances #-} 1{-# LANGUAGE TemplateHaskell, OverloadedStrings, OverloadedLists, ViewPatterns, MultiParamTypeClasses, FlexibleContexts, RankNTypes, TypeSynonymInstances, FlexibleInstances, RecordWildCards #-}
2 2
3module Sequence.Contact.Tests 3module Sequence.Contact.Tests
4 ( enactTest 4 ( enactTest, enactTestMod
5 , critTables
5 ) where 6 ) where
6 7
7import Sequence.Formula 8import Sequence.Formula
@@ -12,6 +13,7 @@ import Sequence.Contact.Types
12import Control.Monad 13import Control.Monad
13import Control.Monad.Reader 14import Control.Monad.Reader
14import Control.Monad.Base 15import Control.Monad.Base
16import Control.Monad.Trans.Maybe
15import Control.Lens 17import Control.Lens
16 18
17import Data.Default 19import Data.Default
@@ -29,6 +31,8 @@ import Data.Traversable (mapM)
29 31
30import Prelude hiding (mapM) 32import Prelude hiding (mapM)
31 33
34import Debug.Trace
35
32tests :: MonadReader Stats m => m (Map (CI String) (FormulaM Stats Test)) 36tests :: MonadReader Stats m => m (Map (CI String) (FormulaM Stats Test))
33tests = do 37tests = do
34 baseTests <- mconcat <$> sequence [ test "Stärke" $ sAStrength . attributeTest 38 baseTests <- mconcat <$> sequence [ test "Stärke" $ sAStrength . attributeTest
@@ -94,6 +98,45 @@ tests = do
94 skillTest = to (\x -> flip (set tBaseDifficulty) def <$> x) 98 skillTest = to (\x -> flip (set tBaseDifficulty) def <$> x)
95 attributeTest = to (\x -> flip (set tBaseDifficulty) def . (* 10) <$> x) 99 attributeTest = to (\x -> flip (set tBaseDifficulty) def . (* 10) <$> x)
96 100
101critTables :: CI String -> (DiceResult -> Table (Maybe Effect))
102critTables skill CritSuccess{..}
103 | skill `elem` ([ "Handfeuerwaffen"
104 , "Schwere Waffen"
105 , "Energiewaffen"
106 , "Archaische Distanzwaffen"
107 ] :: [CI String])
108 || skill == "Fernkampfangriffe"
109 = cTable [ (1, 5, Just "Ziel wird zu Boden geschleudert und verliert 10-(En) AP")
110 , (6, 15, Just "Glückstreffer an einer ungepanzerten Stelle (Schutzwert 0)")
111 , (16, 25, Just "Schwachstelle in der Panzerung getroffen (Halber Schutzwert)")
112 , (26, 35, Just "Lähmender Schmerz (Ziel verliert 12-(En) AP)")
113 , (36, 55, Just "Ziel wird zu Boden geworfen")
114 , (56, 75, Just "Kopfschuss")
115 , (76, 95, Just "1w10 Bonusschaden")
116 , (96, 100, Nothing)
117 ]
118 | otherwise = [(Nothing, 1)]
119critTables skill CritFailure{..}
120 | skill `elem` ([ "Handfeuerwaffen"
121 , "Schwere Waffen"
122 , "Energiewaffen"
123 , "Archaische Distanzwaffen"
124 ] :: [CI String])
125 || skill == "Fernkampfangriffe"
126 = cTable [ (1, 5, Nothing)
127 , (6, 25, Just "Ladehemmung oder andere Fehlfunktion der Waffe. Erfordert zum Beheben die gleiche Anzahl AP wie das vollständige Nachladen der Waffe.")
128 , (26, 45, Just "Waffe wird fallengelassen")
129 , (46, 65, Just "Ein anderer Charakter in der Nähe wird getroffen")
130 , (66, 75, Just "Angreifer schießt sich selbst in den Fuß (voller Schaden, Trefferzone: ein Bein)")
131 , (76, 85, Just "Waffe wird beschädigt und praktisch nutzlos (Qualität -100%)")
132 , (86, 95, Just "Charakter verliert geladene Munition (fällt heraus oder zündet im Magazin)")
133 , (96, 100, Just $ "Unkoordinierter Schuss in eine zufällige Richtung"
134 <> "Waffe wird fallengelassen"
135 )
136 ]
137 | otherwise = [(Nothing, 1)]
138critTables _ _ = [(Nothing, 1)]
139
97 140
98getTest :: String -> Fold Stats (FormulaM Stats Test) 141getTest :: String -> Fold Stats (FormulaM Stats Test)
99getTest (CI.mk -> str) = folding tests' 142getTest (CI.mk -> str) = folding tests'
@@ -108,9 +151,12 @@ instance Argument (FormulaM Stats Test) GameState where
108 arg str = join <$> preuses (gFocus' . eStats) (preview (getTest str)) 151 arg str = join <$> preuses (gFocus' . eStats) (preview (getTest str))
109 152
110enactTest :: Test -> FormulaM Stats TestResult 153enactTest :: Test -> FormulaM Stats TestResult
111enactTest rawTest = do 154enactTest rawTest = enactTestMod rawTest $ val ignored [CI.original (rawTest ^. tName), "Modifier"] False
155
156enactTestMod :: Test -> Formula Stats -> FormulaM Stats TestResult
157enactTestMod rawTest modFormula = do
112 test <- foldM (&) rawTest =<< toListOf (ctx . sModifiers . folded . _Modifier . _2) <$> ask 158 test <- foldM (&) rawTest =<< toListOf (ctx . sModifiers . folded . _Modifier . _2) <$> ask
113 manualMod <- val ignored [CI.original (rawTest ^. tName), "Modifier"] False 159 manualMod <- modFormula
114 let 160 let
115 critFailureBar = 95 - test^.tCritFailureMod 161 critFailureBar = 95 - test^.tCritFailureMod
116 critSuccessBar = 5 + test^.tCritSuccessMod 162 critSuccessBar = 5 + test^.tCritSuccessMod
@@ -123,7 +169,7 @@ enactTest rawTest = do
123 | pw >= critFailureBar = CritFailure 169 | pw >= critFailureBar = CritFailure
124 | otherwise = Failure 170 | otherwise = Failure
125 dResult <- toResult <$> d 100 171 dResult <- toResult <$> d 100
126 TestResult <$> pure dResult <*> (test ^. tEffect) dResult 172 TestResult <$> pure dResult <*> runMaybeT ((test ^. tEffect) dResult)
127 173
128-- hasTest :: Stats -> String -> Bool 174-- hasTest :: Stats -> String -> Bool
129-- hasTest stats str = has (getTest str) stats 175-- hasTest stats str = has (getTest str) stats
diff --git a/src/Sequence/Contact/Types.hs b/src/Sequence/Contact/Types.hs
index c69a698..80d35d2 100644
--- a/src/Sequence/Contact/Types.hs
+++ b/src/Sequence/Contact/Types.hs
@@ -31,6 +31,7 @@ import Data.Dynamic.Lens
31 31
32import Control.Monad.Reader (ask, local) 32import Control.Monad.Reader (ask, local)
33import Control.Monad.State 33import Control.Monad.State
34import Control.Monad.Trans.Maybe
34 35
35import Sequence.Contact.Types.Internal 36import Sequence.Contact.Types.Internal
36 37
@@ -77,17 +78,17 @@ instance Show Effect where
77 show = show . view effectName 78 show = show . view effectName
78 79
79instance Default Effect where 80instance Default Effect where
80 def = Effect "" $ preview ctx 81 def = Effect "" mzero
81 82
82instance Monoid Effect where 83instance Monoid Effect where
83 mempty = def 84 mempty = def
84 (Effect aName aEff) `mappend` (Effect bName bEff) = Effect name $ do 85 (Effect aName aEff) `mappend` (Effect bName bEff) = Effect name . MaybeT $ do
85 new <- aEff 86 new <- runMaybeT aEff
86 maybe 87 maybe
87 (id :: FormulaM Stats (Maybe Stats) -> FormulaM Stats (Maybe Stats)) 88 (id :: FormulaM Stats (Maybe Stats) -> FormulaM Stats (Maybe Stats))
88 (local :: (Context Stats -> Context Stats) -> FormulaM Stats (Maybe Stats) -> FormulaM Stats (Maybe Stats)) 89 (local :: (Context Stats -> Context Stats) -> FormulaM Stats (Maybe Stats) -> FormulaM Stats (Maybe Stats))
89 (set ctx <$> new :: Maybe (Context Stats -> Context Stats)) 90 (set ctx <$> new :: Maybe (Context Stats -> Context Stats))
90 $ bEff 91 $ runMaybeT bEff
91 where 92 where
92 name 93 name
93 | aName /= "" 94 | aName /= ""
@@ -97,6 +98,9 @@ instance Monoid Effect where
97effect :: String -> Effect 98effect :: String -> Effect
98effect str = def & set effectName str 99effect str = def & set effectName str
99 100
101instance IsString Effect where
102 fromString = effect
103
100makeLenses ''Test 104makeLenses ''Test
101 105
102instance Default Test where 106instance Default Test where
@@ -106,7 +110,7 @@ instance Default Test where
106 , _tCritFailureMod = 0 110 , _tCritFailureMod = 0
107 , _tBaseDifficulty = 50 111 , _tBaseDifficulty = 50
108 , _tMod = 0 112 , _tMod = 0
109 , _tEffect = const $ pure (def :: Effect) 113 , _tEffect = const mzero
110 } 114 }
111 115
112deriving instance Eq TestResult 116deriving instance Eq TestResult
@@ -174,7 +178,7 @@ instance Default Stats where
174 } 178 }
175 179
176applyModifier :: String -> (Test -> FormulaM Stats Test) -> Effect 180applyModifier :: String -> (Test -> FormulaM Stats Test) -> Effect
177applyModifier effectName modifier = Effect (CI.mk effectName) $ previews ctx apply 181applyModifier effectName modifier = Effect (CI.mk effectName) . MaybeT $ previews ctx apply
178 where 182 where
179 apply = sModifiers <>~ [Modifier (CI.mk $ effectName ++ " (modifier)") modifier] 183 apply = sModifiers <>~ [Modifier (CI.mk $ effectName ++ " (modifier)") modifier]
180 184
diff --git a/src/Sequence/Contact/Types/Internal.hs b/src/Sequence/Contact/Types/Internal.hs
index eaa1e19..f2052ee 100644
--- a/src/Sequence/Contact/Types/Internal.hs
+++ b/src/Sequence/Contact/Types/Internal.hs
@@ -2,7 +2,7 @@
2 2
3module Sequence.Contact.Types.Internal where 3module Sequence.Contact.Types.Internal where
4 4
5import Sequence.Formula (Formula, FormulaM, Table) 5import Sequence.Formula (Formula, FormulaM, FormulaMT, Table)
6 6
7import Data.Map (Map) 7import Data.Map (Map)
8import Data.Set (Set) 8import Data.Set (Set)
@@ -18,6 +18,8 @@ import Data.CaseInsensitive (CI)
18 18
19import Data.ExtendedReal 19import Data.ExtendedReal
20 20
21import Control.Monad.Trans.Maybe (MaybeT)
22
21newtype Hitzone = Hitzone { _hitzone :: CI String } 23newtype Hitzone = Hitzone { _hitzone :: CI String }
22 deriving (Eq, Ord) 24 deriving (Eq, Ord)
23 25
@@ -60,7 +62,7 @@ data DiceResult = CritSuccess { _rWith, _rBy :: Int }
60 62
61data TestResult = TestResult 63data TestResult = TestResult
62 { _rRoll :: DiceResult 64 { _rRoll :: DiceResult
63 , _rResult :: Effect 65 , _rResult :: Maybe Effect
64 } 66 }
65 67
66data Test = Test 68data Test = Test
@@ -69,12 +71,12 @@ data Test = Test
69 , _tCritFailureMod 71 , _tCritFailureMod
70 , _tBaseDifficulty 72 , _tBaseDifficulty
71 , _tMod :: Int 73 , _tMod :: Int
72 , _tEffect :: DiceResult -> FormulaM Stats Effect 74 , _tEffect :: DiceResult -> FormulaMT MaybeT Stats Effect
73 } 75 }
74 76
75data Modifier = Modifier (CI String) (Test -> FormulaM Stats Test) 77data Modifier = Modifier (CI String) (Test -> FormulaM Stats Test)
76 78
77data Effect = Effect (CI String) (FormulaM Stats (Maybe Stats)) 79data Effect = Effect (CI String) (FormulaMT MaybeT Stats Stats)
78 80
79data SeqVal = SeqVal 81data SeqVal = SeqVal
80 { _seqRound :: Down Int 82 { _seqRound :: Down Int
diff --git a/src/Sequence/Formula.hs b/src/Sequence/Formula.hs
index 878ec7f..5c06503 100644
--- a/src/Sequence/Formula.hs
+++ b/src/Sequence/Formula.hs
@@ -1,14 +1,14 @@
1{-# LANGUAGE RecordWildCards, RankNTypes, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, ViewPatterns, TypeFamilies, GADTs, TypeOperators, ExistentialQuantification, FlexibleContexts, IncoherentInstances #-} 1{-# LANGUAGE RecordWildCards, RankNTypes, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, ViewPatterns, TypeFamilies, GADTs, TypeOperators, ExistentialQuantification, FlexibleContexts, IncoherentInstances #-}
2 2
3module Sequence.Formula 3module Sequence.Formula
4 ( FormulaM, Formula, quot' 4 ( FormulaM, FormulaMT, Formula, quot'
5 , (:<:)(..), Context(..), ctx 5 , (:<:)(..), Context(..), ctx
6 , evalFormula, evalFormula' 6 , evalFormula, evalFormula'
7 , findDistribution, findDistribution' 7 , findDistribution, findDistribution'
8 , findAverage 8 , findAverage
9 , val 9 , val
10 , d, z 10 , d, z
11 , Table, table 11 , Table, table, cTable
12 ) where 12 ) where
13 13
14import Control.Lens hiding (Context(..)) 14import Control.Lens hiding (Context(..))
@@ -31,6 +31,7 @@ import Data.List
31import Data.Maybe 31import Data.Maybe
32import Data.Either 32import Data.Either
33import Data.Tuple 33import Data.Tuple
34import Data.Ratio
34 35
35import Data.Map (Map) 36import Data.Map (Map)
36import qualified Data.Map as Map 37import qualified Data.Map as Map
@@ -38,6 +39,8 @@ import qualified Data.Map as Map
38import Data.Set (Set) 39import Data.Set (Set)
39import qualified Data.Set as Set 40import qualified Data.Set as Set
40 41
42import Debug.Trace
43
41class (:<:) small large where 44class (:<:) small large where
42 ctx' :: Traversal' large small 45 ctx' :: Traversal' large small
43 46
@@ -68,6 +71,7 @@ ctxStore :: Traversal' (Context input) (Formula input)
68ctxStore modifyF (Context large fSt) = Context large <$> _Just modifyF fSt 71ctxStore modifyF (Context large fSt) = Context large <$> _Just modifyF fSt
69 72
70type FormulaM input a = StateT (Set [String]) (ReaderT (Context input) (ExceptT (Question input) EventM)) a 73type FormulaM input a = StateT (Set [String]) (ReaderT (Context input) (ExceptT (Question input) EventM)) a
74type FormulaMT t input a = t (StateT (Set [String]) (ReaderT (Context input) (ExceptT (Question input) EventM))) a
71 75
72type Formula input = FormulaM input Int 76type Formula input = FormulaM input Int
73 77
@@ -154,3 +158,8 @@ type Table a = Map a Rational
154 158
155table :: Ord a => Table a -> FormulaM input a 159table :: Ord a => Table a -> FormulaM input a
156table = liftBase . makeEventProb . Map.assocs 160table = liftBase . makeEventProb . Map.assocs
161
162cTable :: Ord v => [(Integer, Integer, v)] -> Table v
163cTable results = Map.fromList $ map (\(from, to, value) -> (value, (abs (to - from) + 1) % (range + 1))) results
164 where
165 range = maximum [ max from to | (from, to, _) <- results ] - minimum [ min from to | (from, to, _) <- results ]
diff --git a/src/Sequence/Utils.hs b/src/Sequence/Utils.hs
index 9f03ca7..667d520 100644
--- a/src/Sequence/Utils.hs
+++ b/src/Sequence/Utils.hs
@@ -2,7 +2,7 @@
2 2
3module Sequence.Utils 3module Sequence.Utils
4 ( TimerLength(..), TimerOrigin(..) 4 ( TimerLength(..), TimerOrigin(..)
5 , withArg, withFocus, withFocus' 5 , withArg, (<~>), withFocus, withFocus'
6 , focusState 6 , focusState
7 , toName, toDesc 7 , toName, toDesc
8 , outputLogged 8 , outputLogged
@@ -65,6 +65,10 @@ withArg f (Completable str) = arg str >>= \a -> case a of
65 Nothing -> shellPutErrLn $ "Could not parse ‘" ++ str ++ "’" 65 Nothing -> shellPutErrLn $ "Could not parse ‘" ++ str ++ "’"
66 Just a -> f a 66 Just a -> f a
67 67
68infixr 0 <~>
69(<~>) :: Argument a st => Completable a -> (a -> Sh st ()) -> Sh st ()
70(<~>) = flip withArg
71
68withFocus :: (EntityIdentifier -> Sh GameState ()) -> Sh GameState () 72withFocus :: (EntityIdentifier -> Sh GameState ()) -> Sh GameState ()
69withFocus f = use gFocus >>= maybe (shellPutErrLn $ "Currently not focusing any entity") f 73withFocus f = use gFocus >>= maybe (shellPutErrLn $ "Currently not focusing any entity") f
70 74
@@ -178,9 +182,12 @@ instance Completion (Formula Stats) GameState where
178 complete _ st (CI.foldCase -> prefix) = return . map CI.original . filter ((prefix `isPrefixOf`) . CI.foldedCase) . Map.keys $ Map.filter (isJust . (\a -> preview (gFocus' . eStats . folding a) st)) statAccessors 182 complete _ st (CI.foldCase -> prefix) = return . map CI.original . filter ((prefix `isPrefixOf`) . CI.foldedCase) . Map.keys $ Map.filter (isJust . (\a -> preview (gFocus' . eStats . folding a) st)) statAccessors
179 183
180instance Argument (Formula Stats) GameState where 184instance Argument (Formula Stats) GameState where
181 arg (CI.mk -> name) = runMaybeT $ do 185 arg (CI.mk -> name) = runMaybeT $ fromAccessor `mplus` fromNumber
182 accessor <- MaybeT . return $ Map.lookup name statAccessors 186 where
183 MaybeT . preuse $ gFocus' . eStats . folding accessor 187 fromAccessor = do
188 accessor <- MaybeT . return $ Map.lookup name statAccessors
189 MaybeT . preuse $ gFocus' . eStats . folding accessor
190 fromNumber = MaybeT . return . fmap fromInteger . (readMaybe :: String -> Maybe Integer) $ CI.original name
184 191
185statAccessors :: Map (CI String) (Stats -> Maybe (Formula Stats)) 192statAccessors :: Map (CI String) (Stats -> Maybe (Formula Stats))
186statAccessors = [ ("Stärke", preview sAStrength) 193statAccessors = [ ("Stärke", preview sAStrength)
generated by cgit v1.2.3 (git 2.25.1) at 2025-11-02 17:19:06 +0000