diff options
author | Gregor Kleen <pngwjpgh@users.noreply.github.com> | 2017-01-16 18:10:17 +0100 |
---|---|---|
committer | Gregor Kleen <pngwjpgh@users.noreply.github.com> | 2017-01-16 18:10:17 +0100 |
commit | ce890f4b6fd478bf5a254390f5bc49e4afd97c8c (patch) | |
tree | fb5a239a32b610470cbefbd279f465df89c5f5f1 /src | |
parent | 7ff2052235140669bc9e9c5c1e94b194626dee67 (diff) | |
download | 2017-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.hs | 57 | ||||
-rw-r--r-- | src/Sequence/Contact/Archetypes.hs | 61 | ||||
-rw-r--r-- | src/Sequence/Contact/Tests.hs | 56 | ||||
-rw-r--r-- | src/Sequence/Contact/Types.hs | 16 | ||||
-rw-r--r-- | src/Sequence/Contact/Types/Internal.hs | 10 | ||||
-rw-r--r-- | src/Sequence/Formula.hs | 13 | ||||
-rw-r--r-- | src/Sequence/Utils.hs | 15 |
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 | ||
20 | import Data.Map.Strict (Map) | 20 | import Data.Map.Strict (Map) |
21 | import qualified Data.Map.Strict as Map | 21 | import qualified Data.Map.Strict as Map |
22 | |||
23 | import Data.Map as Lazy (Map) | ||
24 | import qualified Data.Map as Lazy.Map | ||
22 | 25 | ||
23 | import Data.Set (Set) | 26 | import Data.Set (Set) |
24 | import qualified Data.Set as Set | 27 | import qualified Data.Set as Set |
@@ -34,7 +37,7 @@ import Data.List | |||
34 | import Data.List | 37 | import Data.List |
35 | import Data.Maybe | 38 | import Data.Maybe |
36 | import Data.Bool | 39 | import Data.Bool |
37 | import Data.Monoid (All(..)) | 40 | import Data.Monoid (Monoid(..), (<>), All(..)) |
38 | import Data.Ord | 41 | import Data.Ord |
39 | import Data.Ratio | 42 | import Data.Ratio |
40 | 43 | ||
@@ -67,6 +70,8 @@ import qualified Data.Text.Lazy as Lazy (Text) | |||
67 | import qualified Data.Text.Lazy as Lazy.Text | 70 | import qualified Data.Text.Lazy as Lazy.Text |
68 | import Data.Text.Template | 71 | import Data.Text.Template |
69 | 72 | ||
73 | import Debug.Trace | ||
74 | |||
70 | main :: IO () | 75 | main :: IO () |
71 | main = do | 76 | main = 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 |
387 | rollTest :: Completable (FormulaM Stats Test) -> Sh GameState () | 393 | rollTest :: Completable (FormulaM Stats Test) -> Sh GameState () |
388 | rollTest = withArg $ maybe (return ()) ((>>) <$> outputResult <*> applyEffect) <=< enactTest' | 394 | rollTest = withArg rollTest' |
395 | |||
396 | rollTest' :: FormulaM Stats Test -> Sh GameState () | ||
397 | rollTest' = rollTest'' Nothing | ||
398 | |||
399 | rollTest'' :: Maybe (Formula Stats) -> FormulaM Stats Test -> Sh GameState () | ||
400 | rollTest'' 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 | ||
422 | enactTest' :: FormulaM Stats Test -> Sh GameState (Maybe (String, TestResult)) | 435 | enactTest' :: Maybe (Formula Stats) -> FormulaM Stats Test -> Sh GameState (Maybe (String, TestResult)) |
423 | enactTest' test = runMaybeT $ do | 436 | enactTest' 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 | ||
430 | entitySeqVal :: Sh GameState () | 443 | entitySeqVal :: 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 | |||
603 | burstfire :: Int -> Completable (Formula Stats) -> Completable (Formula Stats) -> Sh GameState () | ||
604 | burstfire 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 | ||
78 | cTable :: Ord v => [(Integer, Integer, v)] -> Table v | ||
79 | cTable = Map.fromList . map (\(from, to, value) -> (value, (abs (to - from) + 1) % 100)) | ||
80 | |||
81 | death :: Hitzone -> Effect | 78 | death :: Hitzone -> Effect |
82 | death zone = Effect "Tod" . runMaybeT $ do | 79 | death 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 | ||
90 | unconsciousR :: Formula Stats -> FormulaM Stats (Maybe Stats) | 87 | unconsciousR :: Formula Stats -> FormulaMT MaybeT Stats Stats |
91 | unconsciousR roundsF = do | 88 | unconsciousR 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 | ||
95 | unconscious :: FormulaM Stats (Maybe Stats) | 92 | unconscious :: FormulaMT MaybeT Stats Stats |
96 | unconscious = previews ctx $ set sSequence Nothing | 93 | unconscious = MaybeT . previews ctx $ set sSequence Nothing |
97 | 94 | ||
98 | amputate :: Hitzone -> Effect | 95 | amputate :: Hitzone -> Effect |
99 | amputate zone = Effect (CI.mk $ review hitzone zone ++ " ist verloren") . runMaybeT $ do | 96 | amputate 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 | ||
393 | dolphin = Dolphin | 390 | dolphin = 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 | ||
3 | module Sequence.Contact.Tests | 3 | module Sequence.Contact.Tests |
4 | ( enactTest | 4 | ( enactTest, enactTestMod |
5 | , critTables | ||
5 | ) where | 6 | ) where |
6 | 7 | ||
7 | import Sequence.Formula | 8 | import Sequence.Formula |
@@ -12,6 +13,7 @@ import Sequence.Contact.Types | |||
12 | import Control.Monad | 13 | import Control.Monad |
13 | import Control.Monad.Reader | 14 | import Control.Monad.Reader |
14 | import Control.Monad.Base | 15 | import Control.Monad.Base |
16 | import Control.Monad.Trans.Maybe | ||
15 | import Control.Lens | 17 | import Control.Lens |
16 | 18 | ||
17 | import Data.Default | 19 | import Data.Default |
@@ -29,6 +31,8 @@ import Data.Traversable (mapM) | |||
29 | 31 | ||
30 | import Prelude hiding (mapM) | 32 | import Prelude hiding (mapM) |
31 | 33 | ||
34 | import Debug.Trace | ||
35 | |||
32 | tests :: MonadReader Stats m => m (Map (CI String) (FormulaM Stats Test)) | 36 | tests :: MonadReader Stats m => m (Map (CI String) (FormulaM Stats Test)) |
33 | tests = do | 37 | tests = 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 | ||
101 | critTables :: CI String -> (DiceResult -> Table (Maybe Effect)) | ||
102 | critTables 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)] | ||
119 | critTables 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)] | ||
138 | critTables _ _ = [(Nothing, 1)] | ||
139 | |||
97 | 140 | ||
98 | getTest :: String -> Fold Stats (FormulaM Stats Test) | 141 | getTest :: String -> Fold Stats (FormulaM Stats Test) |
99 | getTest (CI.mk -> str) = folding tests' | 142 | getTest (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 | ||
110 | enactTest :: Test -> FormulaM Stats TestResult | 153 | enactTest :: Test -> FormulaM Stats TestResult |
111 | enactTest rawTest = do | 154 | enactTest rawTest = enactTestMod rawTest $ val ignored [CI.original (rawTest ^. tName), "Modifier"] False |
155 | |||
156 | enactTestMod :: Test -> Formula Stats -> FormulaM Stats TestResult | ||
157 | enactTestMod 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 | ||
32 | import Control.Monad.Reader (ask, local) | 32 | import Control.Monad.Reader (ask, local) |
33 | import Control.Monad.State | 33 | import Control.Monad.State |
34 | import Control.Monad.Trans.Maybe | ||
34 | 35 | ||
35 | import Sequence.Contact.Types.Internal | 36 | import 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 | ||
79 | instance Default Effect where | 80 | instance Default Effect where |
80 | def = Effect "" $ preview ctx | 81 | def = Effect "" mzero |
81 | 82 | ||
82 | instance Monoid Effect where | 83 | instance 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 | |||
97 | effect :: String -> Effect | 98 | effect :: String -> Effect |
98 | effect str = def & set effectName str | 99 | effect str = def & set effectName str |
99 | 100 | ||
101 | instance IsString Effect where | ||
102 | fromString = effect | ||
103 | |||
100 | makeLenses ''Test | 104 | makeLenses ''Test |
101 | 105 | ||
102 | instance Default Test where | 106 | instance 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 | ||
112 | deriving instance Eq TestResult | 116 | deriving instance Eq TestResult |
@@ -174,7 +178,7 @@ instance Default Stats where | |||
174 | } | 178 | } |
175 | 179 | ||
176 | applyModifier :: String -> (Test -> FormulaM Stats Test) -> Effect | 180 | applyModifier :: String -> (Test -> FormulaM Stats Test) -> Effect |
177 | applyModifier effectName modifier = Effect (CI.mk effectName) $ previews ctx apply | 181 | applyModifier 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 | ||
3 | module Sequence.Contact.Types.Internal where | 3 | module Sequence.Contact.Types.Internal where |
4 | 4 | ||
5 | import Sequence.Formula (Formula, FormulaM, Table) | 5 | import Sequence.Formula (Formula, FormulaM, FormulaMT, Table) |
6 | 6 | ||
7 | import Data.Map (Map) | 7 | import Data.Map (Map) |
8 | import Data.Set (Set) | 8 | import Data.Set (Set) |
@@ -18,6 +18,8 @@ import Data.CaseInsensitive (CI) | |||
18 | 18 | ||
19 | import Data.ExtendedReal | 19 | import Data.ExtendedReal |
20 | 20 | ||
21 | import Control.Monad.Trans.Maybe (MaybeT) | ||
22 | |||
21 | newtype Hitzone = Hitzone { _hitzone :: CI String } | 23 | newtype 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 | ||
61 | data TestResult = TestResult | 63 | data TestResult = TestResult |
62 | { _rRoll :: DiceResult | 64 | { _rRoll :: DiceResult |
63 | , _rResult :: Effect | 65 | , _rResult :: Maybe Effect |
64 | } | 66 | } |
65 | 67 | ||
66 | data Test = Test | 68 | data 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 | ||
75 | data Modifier = Modifier (CI String) (Test -> FormulaM Stats Test) | 77 | data Modifier = Modifier (CI String) (Test -> FormulaM Stats Test) |
76 | 78 | ||
77 | data Effect = Effect (CI String) (FormulaM Stats (Maybe Stats)) | 79 | data Effect = Effect (CI String) (FormulaMT MaybeT Stats Stats) |
78 | 80 | ||
79 | data SeqVal = SeqVal | 81 | data 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 | ||
3 | module Sequence.Formula | 3 | module 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 | ||
14 | import Control.Lens hiding (Context(..)) | 14 | import Control.Lens hiding (Context(..)) |
@@ -31,6 +31,7 @@ import Data.List | |||
31 | import Data.Maybe | 31 | import Data.Maybe |
32 | import Data.Either | 32 | import Data.Either |
33 | import Data.Tuple | 33 | import Data.Tuple |
34 | import Data.Ratio | ||
34 | 35 | ||
35 | import Data.Map (Map) | 36 | import Data.Map (Map) |
36 | import qualified Data.Map as Map | 37 | import qualified Data.Map as Map |
@@ -38,6 +39,8 @@ import qualified Data.Map as Map | |||
38 | import Data.Set (Set) | 39 | import Data.Set (Set) |
39 | import qualified Data.Set as Set | 40 | import qualified Data.Set as Set |
40 | 41 | ||
42 | import Debug.Trace | ||
43 | |||
41 | class (:<:) small large where | 44 | class (:<:) 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) | |||
68 | ctxStore modifyF (Context large fSt) = Context large <$> _Just modifyF fSt | 71 | ctxStore modifyF (Context large fSt) = Context large <$> _Just modifyF fSt |
69 | 72 | ||
70 | type FormulaM input a = StateT (Set [String]) (ReaderT (Context input) (ExceptT (Question input) EventM)) a | 73 | type FormulaM input a = StateT (Set [String]) (ReaderT (Context input) (ExceptT (Question input) EventM)) a |
74 | type FormulaMT t input a = t (StateT (Set [String]) (ReaderT (Context input) (ExceptT (Question input) EventM))) a | ||
71 | 75 | ||
72 | type Formula input = FormulaM input Int | 76 | type Formula input = FormulaM input Int |
73 | 77 | ||
@@ -154,3 +158,8 @@ type Table a = Map a Rational | |||
154 | 158 | ||
155 | table :: Ord a => Table a -> FormulaM input a | 159 | table :: Ord a => Table a -> FormulaM input a |
156 | table = liftBase . makeEventProb . Map.assocs | 160 | table = liftBase . makeEventProb . Map.assocs |
161 | |||
162 | cTable :: Ord v => [(Integer, Integer, v)] -> Table v | ||
163 | cTable 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 | ||
3 | module Sequence.Utils | 3 | module 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 | ||
68 | infixr 0 <~> | ||
69 | (<~>) :: Argument a st => Completable a -> (a -> Sh st ()) -> Sh st () | ||
70 | (<~>) = flip withArg | ||
71 | |||
68 | withFocus :: (EntityIdentifier -> Sh GameState ()) -> Sh GameState () | 72 | withFocus :: (EntityIdentifier -> Sh GameState ()) -> Sh GameState () |
69 | withFocus f = use gFocus >>= maybe (shellPutErrLn $ "Currently not focusing any entity") f | 73 | withFocus 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 | ||
180 | instance Argument (Formula Stats) GameState where | 184 | instance 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 | ||
185 | statAccessors :: Map (CI String) (Stats -> Maybe (Formula Stats)) | 192 | statAccessors :: Map (CI String) (Stats -> Maybe (Formula Stats)) |
186 | statAccessors = [ ("Stärke", preview sAStrength) | 193 | statAccessors = [ ("Stärke", preview sAStrength) |