From e65e3f11fe911a6ca1009cf35f4b3e7ca907c459 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 12 Aug 2016 16:35:55 +0200 Subject: support for tests applying effects --- sequence.cabal | 2 +- sequence.nix | 2 +- src/Main.hs | 17 +++++++++-- src/Sequence/Contact/Tests.hs | 3 +- src/Sequence/Contact/Types.hs | 54 +++++++++++++++++++++++++--------- src/Sequence/Contact/Types/Internal.hs | 9 ++++-- 6 files changed, 66 insertions(+), 21 deletions(-) diff --git a/sequence.cabal b/sequence.cabal index 05672e7..3550262 100644 --- a/sequence.cabal +++ b/sequence.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: sequence -version: 0.0.1 +version: 0.1.0 -- synopsis: -- description: license: MIT diff --git a/sequence.nix b/sequence.nix index 1e2dd40..35347cc 100644 --- a/sequence.nix +++ b/sequence.nix @@ -6,7 +6,7 @@ }: mkDerivation { pname = "sequence"; - version = "0.0.1"; + version = "0.1.0"; src = ./.; isLibrary = false; isExecutable = true; diff --git a/src/Main.hs b/src/Main.hs index 2d9f876..3b7b3f5 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -274,10 +274,10 @@ spawnFaction cFaction num cEntity nameTemplate -- Dice rolls rollTest :: Completable (FormulaM Stats Test) -> Sh GameState () -rollTest = withArg $ maybe (return ()) outputResult <=< enactTest' +rollTest = withArg $ maybe (return ()) ((>>) <$> outputResult <*> applyEffect) <=< enactTest' where outputResult :: (String, TestResult) -> Sh GameState () - outputResult (test, ppResult -> result) = do + outputResult (test, view (rRoll . to ppResult) -> result) = do focusId <- use gFocus case focusId of Nothing -> shellPutStrLn result @@ -295,6 +295,19 @@ rollTest = withArg $ maybe (return ()) outputResult <=< enactTest' | length str >= n = str | otherwise = ' ' : pad (n - 1) str + + applyEffect :: (String, TestResult) -> Sh GameState () + applyEffect (test, view rResult -> (Effect (CI.original -> effectDesc) effect)) = void . runMaybeT $ do + focusId <- MaybeT $ use gFocus + name <- toName focusId + let + lStats :: Traversal' GameState Stats + lStats = gEntities . ix focusId . eStats + evalF = MaybeT . focusState lStats . evalFormula' [name] + guard =<< askBool ("Apply effects (" ++ effectDesc ++ ")?") True + lStats <~ (MaybeT . fmap join . runMaybeT $ evalF effect) + lift . outputLogged focusId $ test ++ " effects: " ++ effectDesc + enactTest' :: FormulaM Stats Test -> Sh GameState (Maybe (String, TestResult)) enactTest' test = runMaybeT $ do focusName <- MaybeT (use gFocus) >>= lift . toName diff --git a/src/Sequence/Contact/Tests.hs b/src/Sequence/Contact/Tests.hs index 2c21834..81b8d3c 100644 --- a/src/Sequence/Contact/Tests.hs +++ b/src/Sequence/Contact/Tests.hs @@ -117,7 +117,8 @@ enactTest rawTest = do | pw <= bar = Success | pw >= critFailureBar = CritFailure | otherwise = Failure - toResult <$> d 100 + dResult <- toResult <$> d 100 + TestResult <$> pure dResult <*> (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 ca7da1f..12283b9 100644 --- a/src/Sequence/Contact/Types.hs +++ b/src/Sequence/Contact/Types.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TemplateHaskell, RecordWildCards, OverloadedStrings, OverloadedLists, ViewPatterns, RankNTypes, ImpredicativeTypes, FlexibleContexts, TypeSynonymInstances, FlexibleInstances #-} +{-# LANGUAGE TemplateHaskell, RecordWildCards, OverloadedStrings, OverloadedLists, ViewPatterns, RankNTypes, ImpredicativeTypes, FlexibleContexts, TypeSynonymInstances, FlexibleInstances, StandaloneDeriving #-} module Sequence.Contact.Types ( module Sequence.Contact.Types @@ -8,7 +8,7 @@ module Sequence.Contact.Types import Sequence.Formula import Control.Monad -import Control.Lens +import Control.Lens hiding (Context) import Data.Default @@ -25,8 +25,9 @@ import Data.Ratio import Data.List import Data.Ord import Data.ExtendedReal +import Data.Monoid (Monoid(..), (<>)) -import Control.Monad.Reader (ask) +import Control.Monad.Reader (ask, local) import Control.Monad.State import Sequence.Contact.Types.Internal @@ -44,18 +45,9 @@ makePrisms ''DamageType instance {-# OVERLAPS #-} Default Armor where def = const $ return 0 -makeLenses ''TestResult - -makeLenses ''Test +makeLenses ''DiceResult -instance Default Test where - def = Test - { _tName = "" - , _tCritSuccessMod = 0 - , _tCritFailureMod = 0 - , _tBaseDifficulty = 50 - , _tMod = 0 - } +makeLenses ''TestResult makePrisms ''Modifier @@ -79,12 +71,46 @@ instance Eq Effect where instance Ord Effect where compare = compare `on` (view effectName) +instance Show Effect where + show = show . view effectName + instance Default Effect where def = Effect "" $ preview ctx +instance Monoid Effect where + mempty = def + (Effect aName aEff) `mappend` (Effect bName bEff) = Effect name $ do + new <- aEff + maybe + (id :: FormulaM Stats (Maybe Stats) -> FormulaM Stats (Maybe Stats)) + (local :: (Context Stats -> Context Stats) -> FormulaM Stats (Maybe Stats) -> FormulaM Stats (Maybe Stats)) + (set ctx <$> new :: Maybe (Context Stats -> Context Stats)) + $ bEff + where + name + | aName /= "" + , bName /= "" = aName <> ", " <> bName + | otherwise = aName <> bName + effect :: String -> Effect effect str = def & set effectName str +makeLenses ''Test + +instance Default Test where + def = Test + { _tName = "" + , _tCritSuccessMod = 0 + , _tCritFailureMod = 0 + , _tBaseDifficulty = 50 + , _tMod = 0 + , _tEffect = const $ pure (def :: Effect) + } + +deriving instance Eq TestResult +deriving instance Ord TestResult +deriving instance Show TestResult + makePrisms ''SeqVal makeLenses ''SeqVal diff --git a/src/Sequence/Contact/Types/Internal.hs b/src/Sequence/Contact/Types/Internal.hs index e9bb268..ca4d022 100644 --- a/src/Sequence/Contact/Types/Internal.hs +++ b/src/Sequence/Contact/Types/Internal.hs @@ -50,20 +50,25 @@ data DamageType = Ballistic | Passthrough deriving (Eq, Ord, Enum, Bounded, Show) -data TestResult = CritSuccess { _rWith, _rBy :: Int } +data DiceResult = CritSuccess { _rWith, _rBy :: Int } | Success { _rWith, _rBy :: Int } | Failure { _rWith, _rBy :: Int } | CritFailure { _rWith, _rBy :: Int } deriving (Eq, Ord, Show) +data TestResult = TestResult + { _rRoll :: DiceResult + , _rResult :: Effect + } + data Test = Test { _tName :: CI String , _tCritSuccessMod , _tCritFailureMod , _tBaseDifficulty , _tMod :: Int + , _tEffect :: DiceResult -> FormulaM Stats Effect } - deriving (Eq, Ord) data Modifier = Modifier (CI String) (Test -> FormulaM Stats Test) -- cgit v1.2.3