From ce890f4b6fd478bf5a254390f5bc49e4afd97c8c Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 16 Jan 2017 18:10:17 +0100 Subject: Burstfire --- src/Main.hs | 57 ++++++++++++++++++++++++++----- src/Sequence/Contact/Archetypes.hs | 61 ++++++++++++++++------------------ src/Sequence/Contact/Tests.hs | 56 ++++++++++++++++++++++++++++--- src/Sequence/Contact/Types.hs | 16 +++++---- src/Sequence/Contact/Types/Internal.hs | 10 +++--- src/Sequence/Formula.hs | 13 ++++++-- 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 import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map + +import Data.Map as Lazy (Map) +import qualified Data.Map as Lazy.Map import Data.Set (Set) import qualified Data.Set as Set @@ -34,7 +37,7 @@ import Data.List import Data.List import Data.Maybe import Data.Bool -import Data.Monoid (All(..)) +import Data.Monoid (Monoid(..), (<>), All(..)) import Data.Ord import Data.Ratio @@ -67,6 +70,8 @@ import qualified Data.Text.Lazy as Lazy (Text) import qualified Data.Text.Lazy as Lazy.Text import Data.Text.Template +import Debug.Trace + main :: IO () main = do historyFile <- getUserCacheFile "sequence" "history" @@ -115,6 +120,7 @@ main = do , cmd "log" dumpLog "Print the combat log" , cmd "val" printVal "Find the distribution of a specific value of the current entities" , cmd "summary" printVals "Find the averages of applicable all values" + , cmd "burstfire" burstfire "Roll an automatic burst of shots against given skill compensating for recoil with the given attribute" ] , wordBreakChars = wordBreakChars initialShellDescription \\ [',', '\''] } @@ -385,7 +391,13 @@ spawnFaction cFaction num cEntity nameTemplate -- Dice rolls rollTest :: Completable (FormulaM Stats Test) -> Sh GameState () -rollTest = withArg $ maybe (return ()) ((>>) <$> outputResult <*> applyEffect) <=< enactTest' +rollTest = withArg rollTest' + +rollTest' :: FormulaM Stats Test -> Sh GameState () +rollTest' = rollTest'' Nothing + +rollTest'' :: Maybe (Formula Stats) -> FormulaM Stats Test -> Sh GameState () +rollTest'' testMod = maybe (return ()) ((>>) <$> outputResult <*> applyEffect) <=< enactTest' testMod where outputResult :: (String, TestResult) -> Sh GameState () outputResult (test, view (rRoll . to ppResult) -> result) = do @@ -408,7 +420,8 @@ rollTest = withArg $ maybe (return ()) ((>>) <$> outputResult <*> applyEffect) < applyEffect :: (String, TestResult) -> Sh GameState () - applyEffect (test, view rResult -> (Effect (CI.original -> effectDesc) effect)) = void . runMaybeT $ do + applyEffect (_, view rResult -> Nothing) = return () + applyEffect (test, view rResult -> Just (Effect (CI.original -> effectDesc) effect)) = void . runMaybeT $ do focusId <- MaybeT $ use gFocus name <- toName focusId let @@ -416,15 +429,15 @@ rollTest = withArg $ maybe (return ()) ((>>) <$> outputResult <*> applyEffect) < lStats = gEntities . ix focusId . eStats evalF = MaybeT . focusState lStats . evalFormula' [name] guard =<< askBool ("Apply effects (" ++ effectDesc ++ ")?") True - lStats <~ (MaybeT . fmap join . runMaybeT $ evalF effect) + lStats <~ (MaybeT . fmap join . runMaybeT . evalF $ runMaybeT effect) lift . outputLogged focusId $ test ++ " effects: " ++ effectDesc -enactTest' :: FormulaM Stats Test -> Sh GameState (Maybe (String, TestResult)) -enactTest' test = runMaybeT $ do +enactTest' :: Maybe (Formula Stats) -> FormulaM Stats Test -> Sh GameState (Maybe (String, TestResult)) +enactTest' testMod test = runMaybeT $ do focusName <- MaybeT (use gFocus) >>= lift . toName let evalF = MaybeT . focusState (gFocus' . eStats) . evalFormula' [focusName] test' <- evalF test - result <- evalF $ enactTest test' + result <- evalF $ (maybe enactTest (flip enactTestMod) testMod) test' return (view (tName . to CI.original) test', result) entitySeqVal :: Sh GameState () @@ -502,7 +515,7 @@ doShock dmg efLens = withFocus $ \focusId -> do else guard $ val >= bar lStats . efLens . seApplied .= True Effect (CI.original -> effectName) effect <- evalF . table $ cripple ^. seEffect - lStats <~ (MaybeT . fmap join . runMaybeT $ evalF effect) + lStats <~ (MaybeT . fmap join . runMaybeT . evalF $ runMaybeT effect) lift . outputLogged focusId $ "Effect: " ++ effectName lift . addNote $ "Effect: " ++ effectName @@ -586,3 +599,31 @@ printVals = withFocus $ \focusId -> do Just avg -> shellPutStrLn $ printf "%*s: %5.1f" maxLength (CI.original str) (fromRational avg :: Double) Nothing -> return () mapM_ printAvg $ Map.toList sheet + +burstfire :: Int -> Completable (Formula Stats) -> Completable (Formula Stats) -> Sh GameState () +burstfire nShots skill' attr' = skill' <~> \skill -> attr' <~> \attr -> withFocus (burstfire' skill attr) + where + burstfire' skill attr focusId = void . runMaybeT $ do + name <- lift $ toName focusId + let + lStats :: Traversal' GameState Stats + lStats = gEntities . ix focusId . eStats + evalF formula = do + stats <- MaybeT $ preuse lStats + (nStats, x) <- (evalFormula [name] :: Stats -> FormulaM Stats a -> MaybeT (Sh GameState) (Stats, a)) stats formula + lStats .= nStats + return x + skillVal <- evalF skill + attrVal <- evalF attr + minStrRaw <- evalF $ val ignored ["Mindeststärke der Waffe"] False + minStrMod <- evalF $ val ignored ["Mindeststärke der Waffe", "Modifikator"] False + mod <- evalF $ val ignored ["Modifikator"] False + let + recoilMod = max 0 $ 10 + (minStr - attrVal) + minStr = minStrRaw + minStrMod + lift . forM_ [1..nShots] $ \n -> do + rollTest'' (Just $ fromIntegral mod) . return $ def + & tName . iso CI.original CI.mk .~ printf "Schuss %2d" n + & tBaseDifficulty .~ skillVal + & tMod .~ (n - 1) * (-recoilMod) + & 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) , ("AUV", auv) ] -cTable :: Ord v => [(Integer, Integer, v)] -> Table v -cTable = Map.fromList . map (\(from, to, value) -> (value, (abs (to - from) + 1) % 100)) - death :: Hitzone -> Effect -death zone = Effect "Tod" . runMaybeT $ do +death zone = Effect "Tod" $ do maxVitality <- (MaybeT . preview $ ctx . sMaxVitality) >>= lift currentDmg <- MaybeT . preview $ ctx . sDamage' zone allDmg <- MaybeT . preview $ ctx . sTotalDamage @@ -87,16 +84,16 @@ death zone = Effect "Tod" . runMaybeT $ do dmg' = if dmg >= 0 then dmg else 0 MaybeT . previews ctx $ set (sDamage' zone) dmg' -unconsciousR :: Formula Stats -> FormulaM Stats (Maybe Stats) +unconsciousR :: Formula Stats -> FormulaMT MaybeT Stats Stats unconsciousR roundsF = do - rounds <- roundsF - previews ctx $ over (sSequence . _Just . seqRound . _Wrapped) (+ rounds) + rounds <- lift roundsF + MaybeT . previews ctx $ over (sSequence . _Just . seqRound . _Wrapped) (+ rounds) -unconscious :: FormulaM Stats (Maybe Stats) -unconscious = previews ctx $ set sSequence Nothing +unconscious :: FormulaMT MaybeT Stats Stats +unconscious = MaybeT . previews ctx $ set sSequence Nothing amputate :: Hitzone -> Effect -amputate zone = Effect (CI.mk $ review hitzone zone ++ " ist verloren") . runMaybeT $ do +amputate zone = Effect (CI.mk $ review hitzone zone ++ " ist verloren") $ do hitzones <- MaybeT . preview $ ctx . sHitzones (fromRational -> zoneProp) <- MaybeT . return $ Map.lookup zone hitzones MaybeT . previews ctx . execState $ do @@ -221,7 +218,7 @@ human = Humanoid & set seBar (vitBar 0.75) & set seReBar (vitBar 0.2) & set seEffect (cTable [ (1, 5, death "Torso") - , (6, 25, Effect "Organschäden" . previews ctx $ over sFatigue (+ 25) . over (sDamage' "Torso") (+ 10)) + , (6, 25, Effect "Organschäden" . MaybeT . previews ctx $ over sFatigue (+ 25) . over (sDamage' "Torso") (+ 10)) , (26, 45, effect "Innere Blutung (3 Schaden (Au) Minuten)") , (46, 75, Effect "Bewusstlos" unconscious) , (76, 100, Effect "Bewusstlos" . unconsciousR $ d 10) @@ -234,7 +231,7 @@ human = Humanoid & set seBar (vitBar 0.2) & set seReBar (vitBar 0.2) & set seEffect ( cTable [ (1, 5, effect "Querschnittsgelähmt") - , (6, 25, Effect "Kastration" . previews ctx $ over sFatigue (+ 15)) + , (6, 25, Effect "Kastration" . MaybeT . previews ctx $ over sFatigue (+ 15)) , (26, 50, effect "Innere Blutung (2 Schaden (Au) Minuten)") , (51, 100, Effect "Bewusstlos" unconscious) ]) @@ -255,14 +252,14 @@ human = Humanoid , (6, 25, Effect "Koma" unconscious) , (26, 45, Effect "Bewusstlos" . unconsciousR $ d 10) , (46, 75, Effect "Bewusstlos" unconscious) - , (76, 100, Effect "Verlangsamt" $ d 10 >>= (\loss -> previews ctx $ over (sSequence . _Just . seqVal . _Just) (+ (-loss)))) + , (76, 100, Effect "Verlangsamt" $ lift (d 10) >>= (\loss -> MaybeT . previews ctx $ over (sSequence . _Just . seqVal . _Just) (+ (-loss)))) ]) , _sFatigueShock = def & set seReBar (vitBar 0.75) & set seEffect ( cTable [ (1, 25, Effect "Bewusstlos" . unconsciousR $ 2 * d 10) , (26, 50, Effect "Bewusstlos" . unconsciousR $ d 10) , (51, 75, Effect "Bewusstlos" unconscious) - , (76, 100, Effect "Verlangsamt" $ 2 * d 10 >>= (\loss -> previews ctx $ over (sSequence . _Just . seqVal . _Just) (+ (-loss)))) + , (76, 100, Effect "Verlangsamt" $ lift (2 * d 10) >>= (\loss -> MaybeT . previews ctx $ over (sSequence . _Just . seqVal . _Just) (+ (-loss)))) ]) , _sExtraSkills = [] @@ -278,7 +275,7 @@ human = Humanoid & set seEffect (cTable [ (1, 10, amputate zone) , (11, 25, effect $ review hitzone zone ++ " ist gelähmt und unbrauchbar") , (26, 45, effect $ review hitzone zone ++ " hat eingeschränkte Funktion (-50%)") - , (46, 75, Effect "Schwerste Schmerzen" . previews ctx $ over sFatigue (+ 10)) + , (46, 75, Effect "Schwerste Schmerzen" . MaybeT . previews ctx $ over sFatigue (+ 10)) , (76, 100, effect "Fleischwunde") ]) bein zone = def @@ -287,7 +284,7 @@ human = Humanoid & set seReBar (vitBar 0.2) & set seEffect (cTable [ (1, 10, amputate zone) , (11, 45, effect $ review hitzone zone ++ " ist gelähmt und unbrauchbar (halbierte Bewegung)") - , (46, 75, Effect "Schwerste Schmerzen" . previews ctx $ over sFatigue (+ 10)) + , (46, 75, Effect "Schwerste Schmerzen" . MaybeT . previews ctx $ over sFatigue (+ 10)) , (76, 100, effect "Fleischwunde") ]) @@ -343,7 +340,7 @@ dog = Quadruped & set seBar (vitBar 0.75) & set seReBar (vitBar 0.2) & set seEffect ( cTable [ (1, 5, death "Torso") - , (6, 25, Effect "Organschäden" . previews ctx $ over sFatigue (+ 25) . over (sDamage' "Torso") (+ 10)) + , (6, 25, Effect "Organschäden" . MaybeT . previews ctx $ over sFatigue (+ 25) . over (sDamage' "Torso") (+ 10)) , (26, 45, effect "Innere Blutung (3 Schaden (Au) Minuten)") , (46, 75, Effect "Bewusstlos" unconscious) , (76, 100, Effect "Bewusstlos" . unconsciousR $ d 10) @@ -354,7 +351,7 @@ dog = Quadruped & set seBar (vitBar 0.2) & set seReBar (vitBar 0.2) & set seEffect ( cTable [ (1, 5, effect "Querschnittsgelähmt") - , (6, 25, Effect "Kastration" . previews ctx $ over sFatigue (+ 10)) + , (6, 25, Effect "Kastration" . MaybeT . previews ctx $ over sFatigue (+ 10)) , (26, 50, effect "Innere Blutung (2 Schaden (Au) Minuten)") , (51, 100, Effect "Bewusstlos" . unconsciousR $ 2 * d 10) ]) @@ -386,8 +383,8 @@ dog = Quadruped & set seReBar (vitBar 0.2) & set seEffect ( cTable [ (1, 10, amputate zone) , (11, 25, effect $ review hitzone zone ++ " ist gelähmt und unbrauchbar (halbierte Bewegung)") - , (26, 45, Effect "Schmerzen" . previews ctx $ over sFatigue (+ 15)) - , (46, 100, Effect "Fleischwunde" . previews ctx $ over sFatigue (+ 5)) + , (26, 45, Effect "Schmerzen" . MaybeT . previews ctx $ over sFatigue (+ 15)) + , (46, 100, Effect "Fleischwunde" . MaybeT . previews ctx $ over sFatigue (+ 5)) ]) dolphin = Dolphin @@ -437,7 +434,7 @@ dolphin = Dolphin & set seBar (vitBar 0.8) & set seReBar (vitBar 0.2) & set seEffect ( cTable [ (1, 5, death "Rumpf") - , (6, 25, Effect "Organschäden" . previews ctx $ over sFatigue (+ 7) . over (sDamage' "Rumpf") (+ 20)) + , (6, 25, Effect "Organschäden" . MaybeT . previews ctx $ over sFatigue (+ 7) . over (sDamage' "Rumpf") (+ 20)) , (26, 45, effect "Blutung (2 Schaden (Au) Minuten)") , (46, 75, Effect "Bewusstlos" unconscious) , (76, 100, Effect "Bewusstlos" . unconsciousR $ d 10) @@ -449,7 +446,7 @@ dolphin = Dolphin & set seReBar (vitBar 0.2) & set seEffect ( cTable [ (1, 10, amputate "Schwanz") , (11, 25, effect "Halbierte Bewegung") - , (26, 45, Effect "Schmerz" . previews ctx $ over sFatigue (+ 15)) + , (26, 45, Effect "Schmerz" . MaybeT . previews ctx $ over sFatigue (+ 15)) , (46, 100, effect "Fleischwunde") ]) ) @@ -508,28 +505,28 @@ silicoid = Silicoid & set seVal (sDamage' "Auge" . to return) & set seBar (vitBar 0.2) & set seReBar (vitBar 0.2) - & set seEffect ( cTable [ (1, 25, effect "Explosion") - , (26, 75, effect "Permanent desorientiert (nur rammen in zufällige Richtungen)") - , (76, 100, effect "Detonation in 3w10 AP") + & set seEffect ( cTable [ (1, 25, "Explosion") + , (26, 75, "Permanent desorientiert (nur rammen in zufällige Richtungen)") + , (76, 100, "Detonation in 3w10 AP") ]) ) , ("Thorax", def & set seVal (sDamage' "Thorax" . to return) & set seBar (vitBar 0.65) & set seReBar (vitBar 0.2) - & set seEffect ( cTable [ (1, 10, effect "Explosion") - , (11, 25, effect "Halbe Bewegung") - , (26, 65, effect "10 Schaden, Sprühattacke auf nächsten Charakter (Blut)") - , (66, 100, effect "3w10 Erschöpfung") + & set seEffect ( cTable [ (1, 10, "Explosion") + , (11, 25, "Halbe Bewegung") + , (26, 65, "10 Schaden, Sprühattacke auf nächsten Charakter (Blut)") + , (66, 100, "3w10 Erschöpfung") ]) ) , ("Schwanz", def & set seVal (sDamage' "Schwanz" . to return) & set seBar (vitBar 0.2) & set seReBar (vitBar 0.2) - & set seEffect ( cTable [ (1, 25, effect "10 Schaden, Schwanzdrüse unbrauchbar") - , (26, 60, effect "3 Schaden, Sprühattacke auf nächsten Charakter (Blut)") - , (61, 100, effect "Amok und Detonation nach 1w10+6 AP") + & set seEffect ( cTable [ (1, 25, "10 Schaden, Schwanzdrüse unbrauchbar") + , (26, 60, "3 Schaden, Sprühattacke auf nächsten Charakter (Blut)") + , (61, 100, "Amok und Detonation nach 1w10+6 AP") ]) ) ] <> 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 @@ -{-# LANGUAGE TemplateHaskell, OverloadedStrings, OverloadedLists, ViewPatterns, MultiParamTypeClasses, FlexibleContexts, RankNTypes, TypeSynonymInstances, FlexibleInstances #-} +{-# LANGUAGE TemplateHaskell, OverloadedStrings, OverloadedLists, ViewPatterns, MultiParamTypeClasses, FlexibleContexts, RankNTypes, TypeSynonymInstances, FlexibleInstances, RecordWildCards #-} module Sequence.Contact.Tests - ( enactTest + ( enactTest, enactTestMod + , critTables ) where import Sequence.Formula @@ -12,6 +13,7 @@ import Sequence.Contact.Types import Control.Monad import Control.Monad.Reader import Control.Monad.Base +import Control.Monad.Trans.Maybe import Control.Lens import Data.Default @@ -29,6 +31,8 @@ import Data.Traversable (mapM) import Prelude hiding (mapM) +import Debug.Trace + tests :: MonadReader Stats m => m (Map (CI String) (FormulaM Stats Test)) tests = do baseTests <- mconcat <$> sequence [ test "Stärke" $ sAStrength . attributeTest @@ -94,6 +98,45 @@ tests = do skillTest = to (\x -> flip (set tBaseDifficulty) def <$> x) attributeTest = to (\x -> flip (set tBaseDifficulty) def . (* 10) <$> x) +critTables :: CI String -> (DiceResult -> Table (Maybe Effect)) +critTables skill CritSuccess{..} + | skill `elem` ([ "Handfeuerwaffen" + , "Schwere Waffen" + , "Energiewaffen" + , "Archaische Distanzwaffen" + ] :: [CI String]) + || skill == "Fernkampfangriffe" + = cTable [ (1, 5, Just "Ziel wird zu Boden geschleudert und verliert 10-(En) AP") + , (6, 15, Just "Glückstreffer an einer ungepanzerten Stelle (Schutzwert 0)") + , (16, 25, Just "Schwachstelle in der Panzerung getroffen (Halber Schutzwert)") + , (26, 35, Just "Lähmender Schmerz (Ziel verliert 12-(En) AP)") + , (36, 55, Just "Ziel wird zu Boden geworfen") + , (56, 75, Just "Kopfschuss") + , (76, 95, Just "1w10 Bonusschaden") + , (96, 100, Nothing) + ] + | otherwise = [(Nothing, 1)] +critTables skill CritFailure{..} + | skill `elem` ([ "Handfeuerwaffen" + , "Schwere Waffen" + , "Energiewaffen" + , "Archaische Distanzwaffen" + ] :: [CI String]) + || skill == "Fernkampfangriffe" + = cTable [ (1, 5, Nothing) + , (6, 25, Just "Ladehemmung oder andere Fehlfunktion der Waffe. Erfordert zum Beheben die gleiche Anzahl AP wie das vollständige Nachladen der Waffe.") + , (26, 45, Just "Waffe wird fallengelassen") + , (46, 65, Just "Ein anderer Charakter in der Nähe wird getroffen") + , (66, 75, Just "Angreifer schießt sich selbst in den Fuß (voller Schaden, Trefferzone: ein Bein)") + , (76, 85, Just "Waffe wird beschädigt und praktisch nutzlos (Qualität -100%)") + , (86, 95, Just "Charakter verliert geladene Munition (fällt heraus oder zündet im Magazin)") + , (96, 100, Just $ "Unkoordinierter Schuss in eine zufällige Richtung" + <> "Waffe wird fallengelassen" + ) + ] + | otherwise = [(Nothing, 1)] +critTables _ _ = [(Nothing, 1)] + getTest :: String -> Fold Stats (FormulaM Stats Test) getTest (CI.mk -> str) = folding tests' @@ -108,9 +151,12 @@ instance Argument (FormulaM Stats Test) GameState where arg str = join <$> preuses (gFocus' . eStats) (preview (getTest str)) enactTest :: Test -> FormulaM Stats TestResult -enactTest rawTest = do +enactTest rawTest = enactTestMod rawTest $ val ignored [CI.original (rawTest ^. tName), "Modifier"] False + +enactTestMod :: Test -> Formula Stats -> FormulaM Stats TestResult +enactTestMod rawTest modFormula = do test <- foldM (&) rawTest =<< toListOf (ctx . sModifiers . folded . _Modifier . _2) <$> ask - manualMod <- val ignored [CI.original (rawTest ^. tName), "Modifier"] False + manualMod <- modFormula let critFailureBar = 95 - test^.tCritFailureMod critSuccessBar = 5 + test^.tCritSuccessMod @@ -123,7 +169,7 @@ enactTest rawTest = do | pw >= critFailureBar = CritFailure | otherwise = Failure dResult <- toResult <$> d 100 - TestResult <$> pure dResult <*> (test ^. tEffect) dResult + TestResult <$> pure dResult <*> runMaybeT ((test ^. tEffect) dResult) -- hasTest :: Stats -> String -> Bool -- 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 import Control.Monad.Reader (ask, local) import Control.Monad.State +import Control.Monad.Trans.Maybe import Sequence.Contact.Types.Internal @@ -77,17 +78,17 @@ instance Show Effect where show = show . view effectName instance Default Effect where - def = Effect "" $ preview ctx + def = Effect "" mzero instance Monoid Effect where mempty = def - (Effect aName aEff) `mappend` (Effect bName bEff) = Effect name $ do - new <- aEff + (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)) - $ bEff + $ runMaybeT bEff where name | aName /= "" @@ -97,6 +98,9 @@ instance Monoid Effect where effect :: String -> Effect effect str = def & set effectName str +instance IsString Effect where + fromString = effect + makeLenses ''Test instance Default Test where @@ -106,7 +110,7 @@ instance Default Test where , _tCritFailureMod = 0 , _tBaseDifficulty = 50 , _tMod = 0 - , _tEffect = const $ pure (def :: Effect) + , _tEffect = const mzero } deriving instance Eq TestResult @@ -174,7 +178,7 @@ instance Default Stats where } applyModifier :: String -> (Test -> FormulaM Stats Test) -> Effect -applyModifier effectName modifier = Effect (CI.mk effectName) $ previews ctx apply +applyModifier effectName modifier = Effect (CI.mk effectName) . MaybeT $ previews ctx apply where apply = sModifiers <>~ [Modifier (CI.mk $ effectName ++ " (modifier)") modifier] 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 @@ module Sequence.Contact.Types.Internal where -import Sequence.Formula (Formula, FormulaM, Table) +import Sequence.Formula (Formula, FormulaM, FormulaMT, Table) import Data.Map (Map) import Data.Set (Set) @@ -18,6 +18,8 @@ import Data.CaseInsensitive (CI) import Data.ExtendedReal +import Control.Monad.Trans.Maybe (MaybeT) + newtype Hitzone = Hitzone { _hitzone :: CI String } deriving (Eq, Ord) @@ -60,7 +62,7 @@ data DiceResult = CritSuccess { _rWith, _rBy :: Int } data TestResult = TestResult { _rRoll :: DiceResult - , _rResult :: Effect + , _rResult :: Maybe Effect } data Test = Test @@ -69,12 +71,12 @@ data Test = Test , _tCritFailureMod , _tBaseDifficulty , _tMod :: Int - , _tEffect :: DiceResult -> FormulaM Stats Effect + , _tEffect :: DiceResult -> FormulaMT MaybeT Stats Effect } data Modifier = Modifier (CI String) (Test -> FormulaM Stats Test) -data Effect = Effect (CI String) (FormulaM Stats (Maybe Stats)) +data Effect = Effect (CI String) (FormulaMT MaybeT Stats Stats) data SeqVal = SeqVal { _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 @@ {-# LANGUAGE RecordWildCards, RankNTypes, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, ViewPatterns, TypeFamilies, GADTs, TypeOperators, ExistentialQuantification, FlexibleContexts, IncoherentInstances #-} module Sequence.Formula - ( FormulaM, Formula, quot' + ( FormulaM, FormulaMT, Formula, quot' , (:<:)(..), Context(..), ctx , evalFormula, evalFormula' , findDistribution, findDistribution' , findAverage , val , d, z - , Table, table + , Table, table, cTable ) where import Control.Lens hiding (Context(..)) @@ -31,6 +31,7 @@ import Data.List import Data.Maybe import Data.Either import Data.Tuple +import Data.Ratio import Data.Map (Map) import qualified Data.Map as Map @@ -38,6 +39,8 @@ import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set +import Debug.Trace + class (:<:) small large where ctx' :: Traversal' large small @@ -68,6 +71,7 @@ ctxStore :: Traversal' (Context input) (Formula input) ctxStore modifyF (Context large fSt) = Context large <$> _Just modifyF fSt type FormulaM input a = StateT (Set [String]) (ReaderT (Context input) (ExceptT (Question input) EventM)) a +type FormulaMT t input a = t (StateT (Set [String]) (ReaderT (Context input) (ExceptT (Question input) EventM))) a type Formula input = FormulaM input Int @@ -154,3 +158,8 @@ type Table a = Map a Rational table :: Ord a => Table a -> FormulaM input a table = liftBase . makeEventProb . Map.assocs + +cTable :: Ord v => [(Integer, Integer, v)] -> Table v +cTable results = Map.fromList $ map (\(from, to, value) -> (value, (abs (to - from) + 1) % (range + 1))) results + where + 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 @@ module Sequence.Utils ( TimerLength(..), TimerOrigin(..) - , withArg, withFocus, withFocus' + , withArg, (<~>), withFocus, withFocus' , focusState , toName, toDesc , outputLogged @@ -65,6 +65,10 @@ withArg f (Completable str) = arg str >>= \a -> case a of Nothing -> shellPutErrLn $ "Could not parse ‘" ++ str ++ "’" Just a -> f a +infixr 0 <~> +(<~>) :: Argument a st => Completable a -> (a -> Sh st ()) -> Sh st () +(<~>) = flip withArg + withFocus :: (EntityIdentifier -> Sh GameState ()) -> Sh GameState () withFocus f = use gFocus >>= maybe (shellPutErrLn $ "Currently not focusing any entity") f @@ -178,9 +182,12 @@ instance Completion (Formula Stats) GameState where 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 instance Argument (Formula Stats) GameState where - arg (CI.mk -> name) = runMaybeT $ do - accessor <- MaybeT . return $ Map.lookup name statAccessors - MaybeT . preuse $ gFocus' . eStats . folding accessor + arg (CI.mk -> name) = runMaybeT $ fromAccessor `mplus` fromNumber + where + fromAccessor = do + accessor <- MaybeT . return $ Map.lookup name statAccessors + MaybeT . preuse $ gFocus' . eStats . folding accessor + fromNumber = MaybeT . return . fmap fromInteger . (readMaybe :: String -> Maybe Integer) $ CI.original name statAccessors :: Map (CI String) (Stats -> Maybe (Formula Stats)) statAccessors = [ ("Stärke", preview sAStrength) -- cgit v1.2.3