From 85486c4838e23ca6d8b643c759d4e2a3035ef61d Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 8 Jun 2016 22:45:07 +0200 Subject: framework for damage tracking --- src/Main.hs | 8 +- src/Sequence/Contact/Archetypes.hs | 29 +++++ src/Sequence/Contact/Tests.hs | 32 +---- src/Sequence/Contact/Types.hs | 218 ++++++++++++++++++--------------- src/Sequence/Contact/Types/Internal.hs | 200 ++++++++++++++++++++++++++++++ src/Sequence/Formula.hs | 25 +++- 6 files changed, 377 insertions(+), 135 deletions(-) create mode 100644 src/Sequence/Contact/Types/Internal.hs diff --git a/src/Main.hs b/src/Main.hs index 145df7a..b7c6a6e 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -15,7 +15,7 @@ import System.Directory import Data.Default import Data.CaseInsensitive (CI) -import qualified Data.CaseInsensitive +import qualified Data.CaseInsensitive as CI import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map @@ -183,7 +183,8 @@ rollTest = withArg $ enactTest' >=> maybe (return ()) (shellPutStrLn . ppResult) enactTest' :: (FormulaM Stats Test) -> Sh GameState (Maybe TestResult) enactTest' test = withFocus' $ \focus -> do - (newFocus, result) <- evalFormula focus (enactTest =<< test) + focusName <- use gFocus >>= toName . fromJust + (newFocus, result) <- evalFormula focusName focus (enactTest =<< test) gFocus' .= newFocus return result @@ -200,5 +201,6 @@ entitySeqVal' ident = do case (,) <$> entity <*> sVal of Nothing -> return () Just (entity, sVal) -> do - (newEntity, view (seqVal . re _Just) -> val) <- evalFormula entity sVal + name <- toName ident + (newEntity, view (seqVal . re _Just) -> val) <- evalFormula name entity sVal gEntities . at ident .= Just (newEntity & set eSeqVal val) diff --git a/src/Sequence/Contact/Archetypes.hs b/src/Sequence/Contact/Archetypes.hs index 193892a..3e9b416 100644 --- a/src/Sequence/Contact/Archetypes.hs +++ b/src/Sequence/Contact/Archetypes.hs @@ -85,6 +85,17 @@ human = Humanoid , _sSeqVal = vReflexes * 2 + vMobility + vPerception + d 10 , _sPainTolerance = vMass `quot'` 2 + vWillpower , _sFatigueTolerance = vWillpower `quot'` 2 + vEndurance + + , _sHitzones = [ ("Kopf", 0.05) + , ("Torso", 0.49) + , ("Rechter Arm", 0.08) + , ("Linker Arm", 0.08) + , ("Unterleib", 0.10) + , ("Rechtes Bein", 0.10) + , ("Linkes Bein", 0.10) + ] + , _sDamage = const 0 + , _sArmor = const def } dog = Quadruped @@ -109,6 +120,17 @@ dog = Quadruped , _sSeqVal = vReflexes * 2 + vMobility + vPerception + 2 * d 10 , _sPainTolerance = vMass `quot'` 2 + vWillpower , _sFatigueTolerance = vWillpower `quot'` 2 + vEndurance + + , _sHitzones = [ ("Kopf", 0.05) + , ("Torso", 0.49) + , ("Rechter Vorderlauf", 0.08) + , ("Linker Vorderlauf", 0.08) + , ("Hinterteil", 0.10) + , ("Rechter Hinterlauf", 0.10) + , ("Linker Hinterlauf", 0.10) + ] + , _sDamage = const 0 + , _sArmor = const def } dolphin = Dolphin @@ -133,6 +155,13 @@ dolphin = Dolphin , _sSeqVal = vReflexes * 2 + vMobility + vPerception + 2 * d 10 , _sPainTolerance = vMass `quot'` 2 + vWillpower , _sFatigueTolerance = vWillpower `quot'` 2 + vEndurance + + , _sHitzones = [ ("Kopf", 0.10) + , ("Rumpf", 0.65) + , ("Schwanz", 0.25) + ] + , _sDamage = const 0 + , _sArmor = const def } childOfMu = human diff --git a/src/Sequence/Contact/Tests.hs b/src/Sequence/Contact/Tests.hs index 8aa072a..82b1cf3 100644 --- a/src/Sequence/Contact/Tests.hs +++ b/src/Sequence/Contact/Tests.hs @@ -1,9 +1,7 @@ -{-# LANGUAGE TemplateHaskell, OverloadedStrings, OverloadedLists, ViewPatterns, MultiParamTypeClasses, FlexibleContexts, RankNTypes, TypeSynonymInstances, FlexibleInstances, ImpredicativeTypes #-} +{-# LANGUAGE TemplateHaskell, OverloadedStrings, OverloadedLists, ViewPatterns, MultiParamTypeClasses, FlexibleContexts, RankNTypes, TypeSynonymInstances, FlexibleInstances #-} module Sequence.Contact.Tests - ( TestResult(..), rWith, rBy - , Test, tCritSuccessMod, tCritFailureMod, tBaseDifficulty, tMod - , enactTest + ( enactTest ) where import Sequence.Formula @@ -13,6 +11,7 @@ import Sequence.Contact.Types import Control.Monad import Control.Monad.Reader +import Control.Monad.Base import Control.Lens import Data.Default @@ -29,31 +28,6 @@ import Data.Traversable (mapM) import Prelude hiding (mapM) - -data TestResult = CritSuccess { _rWith, _rBy :: Int } - | Success { _rWith, _rBy :: Int } - | Failure { _rWith, _rBy :: Int } - | CritFailure { _rWith, _rBy :: Int } - deriving (Eq, Ord, Show) -makeLenses ''TestResult - -data Test = Test - { _tCritSuccessMod - , _tCritFailureMod - , _tBaseDifficulty - , _tMod :: Int - } - deriving (Eq, Ord) -makeLenses ''Test - -instance Default Test where - def = Test - { _tCritSuccessMod = 0 - , _tCritFailureMod = 0 - , _tBaseDifficulty = 50 - , _tMod = 0 - } - tests :: MonadReader Stats m => m (Map (CI String) (FormulaM Stats Test)) tests = mconcat <$> sequence [ test "Stärke" $ sAStrength . attributeTest diff --git a/src/Sequence/Contact/Types.hs b/src/Sequence/Contact/Types.hs index c00a60d..cd1bc02 100644 --- a/src/Sequence/Contact/Types.hs +++ b/src/Sequence/Contact/Types.hs @@ -1,6 +1,9 @@ -{-# LANGUAGE TemplateHaskell, RecordWildCards, OverloadedStrings, OverloadedLists, ViewPatterns, RankNTypes #-} +{-# LANGUAGE TemplateHaskell, RecordWildCards, OverloadedStrings, OverloadedLists, ViewPatterns, RankNTypes, ImpredicativeTypes #-} -module Sequence.Contact.Types where +module Sequence.Contact.Types + ( module Sequence.Contact.Types + , module Sequence.Contact.Types.Internal + ) where import Sequence.Formula @@ -9,105 +12,103 @@ import Control.Lens import Data.Default -data Stats = Prop - | Humanoid - { _sAStrength - , _sAEndurance - , _sAMass - , _sAReflexes - , _sAMobility - , _sADexterity - , _sAIntelligence - , _sACharisma - , _sAPerception - , _sAWillpower - - , _sSArchaicRanged - , _sSFirearms - , _sSHeavyWeapons - , _sSEnergyWeapons - , _sSUnarmedMelee - , _sSArmedMelee - , _sSThrownWeapons - , _sSStealth - , _sSThievery - , _sSLockpicking - , _sSTrapping - , _sSSciences - , _sSFirstAid - , _sSMedicine - , _sSHumanities - , _sSEngineering - , _sSCraft - , _sSInterface - , _sSSpeech - , _sSLeadership - , _sSHomeEconomics - , _sSSurvival - , _sSMotorcycle - , _sSWheeled - , _sSHovercraft - , _sSAircraft - , _sSSpacecraft - , _sSWatercraft - , _sSTracked - , _sSExoskeleton - - , _sMaxVitality - , _sSeqVal - , _sPainTolerance - , _sFatigueTolerance :: Formula Stats - } - | Quadruped - { _sAStrength - , _sAEndurance - , _sAMass - , _sAReflexes - , _sAMobility - , _sADexterity - , _sAIntelligence - , _sACharisma - , _sAPerception - , _sAWillpower - - , _sSBiting - , _sSSearching - , _sSStealth - , _sSLeadership - , _sSDemeanour - - , _sMaxVitality - , _sSeqVal - , _sPainTolerance - , _sFatigueTolerance :: Formula Stats - } - | Dolphin - { _sAStrength - , _sAEndurance - , _sAMass - , _sAReflexes - , _sAMobility - , _sADexterity - , _sAIntelligence - , _sACharisma - , _sAPerception - , _sAWillpower - - , _sSRamming - , _sSTargeting - , _sSSearching - , _sSStealth - , _sSComprehension - - , _sMaxVitality - , _sSeqVal - , _sPainTolerance - , _sFatigueTolerance :: Formula Stats - } +import Data.Map (Map) +import qualified Data.Map as Map + +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI + +import Data.String (IsString(..)) +import Data.Function (on) +import Data.Maybe +import Data.Ratio + +import Control.Monad.Reader (ask) +import Control.Monad.State + +import Sequence.Contact.Types.Internal + +hitzone :: Iso' String Hitzone +hitzone = iso (Hitzone . CI.mk) (CI.original . _hitzone) + +instance IsString Hitzone where + fromString = view hitzone + +makeLenses ''Armor + +instance Default Armor where + def = Armor + { _aBallistic = 0 + , _aPiercing = 0 + , _aBlunt = 0 + , _aHeat = 0 + , _aCold = 0 + , _aToxic = 0 + , _aExplosive = 0 + } + +makeLenses ''TestResult + +makeLenses ''Test + +instance Default Test where + def = Test + { _tName = "" + , _tCritSuccessMod = 0 + , _tCritFailureMod = 0 + , _tBaseDifficulty = 50 + , _tMod = 0 + } + +makePrisms ''Modifier + +instance Eq Modifier where + (==) = (==) `on` (view $ _Modifier . _1) + +instance Ord Modifier where + compare = compare `on` (view $ _Modifier . _1) + +instance Default Modifier where + def = Modifier "" pure + +makePrisms ''Effect + +instance Eq Effect where + (==) = (==) `on` (view $ _Effect . _1) + +instance Ord Effect where + compare = compare `on` (view $ _Effect . _1) + +instance Default Effect where + def = Effect "" pure + +makeLenses ''ShockEffect + +instance Default ShockEffect where + def = ShockEffect { _seApplied = False + , _seVal = pure Nothing + , _seBar = pure Nothing + , _seEffect = def + } + makeLenses ''Stats instance Default Stats where def = Prop + { _sHitzones = [("Volumen", 1)] + , _sDamage = const 0 + , _sFatigue = 0 + , _sCripple = const def + , _sArmor = const def + + , _sExtraSkills = [] + , _sModifiers = [] + } + +applyModifier :: String -> (Test -> FormulaM Stats Test) -> Effect +applyModifier effectName modifier = Effect (CI.mk effectName) $ return . apply + where + apply = sModifiers <>~ [Modifier (CI.mk $ effectName ++ " (modifier)") modifier] vStrength = val sAStrength "Stärke?" True vEndurance = val sAEndurance "Ausdauer?" True @@ -119,3 +120,26 @@ vIntelligence = val sAIntelligence "Intelligenz?" True vCharisma = val sACharisma "Charisma?" True vPerception = val sAPerception "Wahrnehmung?" True vWillpower = val sAWillpower "Entschlossenheit?" True + +scaled :: (Real a, Fractional a, Integral b) => Ratio b -> Iso' a a +scaled (realToFrac -> ratio) = iso (* ratio) (/ ratio) + +sDamage' :: String -> Traversal' Stats Int +sDamage' (view hitzone -> zone) = sDamage . ix zone + +sCripple' :: String -> Traversal' Stats ShockEffect +sCripple' (view hitzone -> zone) = sCripple . ix zone + +sTotalDamage :: Lens' Stats Int +sTotalDamage = lens retrieve undefined + where + retrieve = do + hitzones <- Map.keys <$> view sHitzones + damageMap <- view sDamage + return . sum $ pure damageMap <*> hitzones + +sDead :: Fold Stats (FormulaM Stats Bool) +sDead = folding $ do + maxVitality <- preview sMaxVitality + damage <- view sTotalDamage + return $ liftM2 (>) <$> Just (return damage) <*> maxVitality diff --git a/src/Sequence/Contact/Types/Internal.hs b/src/Sequence/Contact/Types/Internal.hs new file mode 100644 index 0000000..9929801 --- /dev/null +++ b/src/Sequence/Contact/Types/Internal.hs @@ -0,0 +1,200 @@ +{-# LANGUAGE RankNTypes #-} + +module Sequence.Contact.Types.Internal where + +import Sequence.Formula (Formula, FormulaM, Table) + +import Data.Map (Map) +import Data.Set (Set) +import Data.Ratio + +import Control.Lens + +import Data.CaseInsensitive (CI) + +newtype Hitzone = Hitzone { _hitzone :: CI String } + deriving (Eq, Ord) + +data Armor = Armor + { _aBallistic + , _aPiercing + , _aBlunt + , _aHeat + , _aCold + , _aToxic + , _aExplosive :: Int + } + +data TestResult = CritSuccess { _rWith, _rBy :: Int } + | Success { _rWith, _rBy :: Int } + | Failure { _rWith, _rBy :: Int } + | CritFailure { _rWith, _rBy :: Int } + deriving (Eq, Ord, Show) + +data Test = Test + { _tName :: CI String + , _tCritSuccessMod + , _tCritFailureMod + , _tBaseDifficulty + , _tMod :: Int + } + deriving (Eq, Ord) + +data Modifier = Modifier (CI String) (Test -> FormulaM Stats Test) + +data Effect = Effect (CI String) (Stats -> FormulaM Stats Stats) + +data ShockEffect = ShockEffect + { _seApplied :: Bool + , _seVal :: FormulaM Stats (Maybe Int) + , _seBar :: FormulaM Stats (Maybe Int) + , _seEffect :: Table Effect + } + +data Stats = Prop + { _sHitzones :: Table Hitzone + , _sArmor :: Hitzone -> Armor + , _sCripple :: Hitzone -> ShockEffect + + , _sDamage :: Hitzone -> Int + , _sFatigue :: Int + + , _sPainShock :: ShockEffect + , _sFatigueShock :: ShockEffect + + , _sExtraSkills :: Map (CI String) (FormulaM Stats Test) + , _sModifiers :: Set Modifier + } + | Humanoid + { _sAStrength + , _sAEndurance + , _sAMass + , _sAReflexes + , _sAMobility + , _sADexterity + , _sAIntelligence + , _sACharisma + , _sAPerception + , _sAWillpower + + , _sSArchaicRanged + , _sSFirearms + , _sSHeavyWeapons + , _sSEnergyWeapons + , _sSUnarmedMelee + , _sSArmedMelee + , _sSThrownWeapons + , _sSStealth + , _sSThievery + , _sSLockpicking + , _sSTrapping + , _sSSciences + , _sSFirstAid + , _sSMedicine + , _sSHumanities + , _sSEngineering + , _sSCraft + , _sSInterface + , _sSSpeech + , _sSLeadership + , _sSHomeEconomics + , _sSSurvival + , _sSMotorcycle + , _sSWheeled + , _sSHovercraft + , _sSAircraft + , _sSSpacecraft + , _sSWatercraft + , _sSTracked + , _sSExoskeleton + + , _sMaxVitality + , _sSeqVal + , _sPainTolerance + , _sFatigueTolerance :: Formula Stats + + , _sHitzones :: Table Hitzone + , _sArmor :: Hitzone -> Armor + , _sCripple :: Hitzone -> ShockEffect + + , _sDamage :: Hitzone -> Int + , _sFatigue :: Int + + , _sPainShock :: ShockEffect + , _sFatigueShock :: ShockEffect + + , _sExtraSkills :: Map (CI String) (FormulaM Stats Test) + , _sModifiers :: Set Modifier + } + | Quadruped + { _sAStrength + , _sAEndurance + , _sAMass + , _sAReflexes + , _sAMobility + , _sADexterity + , _sAIntelligence + , _sACharisma + , _sAPerception + , _sAWillpower + + , _sSBiting + , _sSSearching + , _sSStealth + , _sSLeadership + , _sSDemeanour + + , _sMaxVitality + , _sSeqVal + , _sPainTolerance + , _sFatigueTolerance :: Formula Stats + + , _sHitzones :: Table Hitzone + , _sArmor :: Hitzone -> Armor + , _sCripple :: Hitzone -> ShockEffect + + , _sDamage :: Hitzone -> Int + , _sFatigue :: Int + + , _sPainShock :: ShockEffect + , _sFatigueShock :: ShockEffect + + , _sExtraSkills :: Map (CI String) (FormulaM Stats Test) + , _sModifiers :: Set Modifier + } + | Dolphin + { _sAStrength + , _sAEndurance + , _sAMass + , _sAReflexes + , _sAMobility + , _sADexterity + , _sAIntelligence + , _sACharisma + , _sAPerception + , _sAWillpower + + , _sSRamming + , _sSTargeting + , _sSSearching + , _sSStealth + , _sSComprehension + + , _sMaxVitality + , _sSeqVal + , _sPainTolerance + , _sFatigueTolerance :: Formula Stats + + , _sHitzones :: Table Hitzone + , _sArmor :: Hitzone -> Armor + , _sCripple :: Hitzone -> ShockEffect + + , _sDamage :: Hitzone -> Int + , _sFatigue :: Int + + , _sPainShock :: ShockEffect + , _sFatigueShock :: ShockEffect + + , _sExtraSkills :: Map (CI String) (FormulaM Stats Test) + , _sModifiers :: Set Modifier + } diff --git a/src/Sequence/Formula.hs b/src/Sequence/Formula.hs index d486bab..ca945f8 100644 --- a/src/Sequence/Formula.hs +++ b/src/Sequence/Formula.hs @@ -2,10 +2,11 @@ module Sequence.Formula ( FormulaM, Formula, quot' - , (:<:)(..), Context(..) + , (:<:)(..), Context(..), ctx , evalFormula , val , d, z + , Table, table ) where import Control.Lens hiding (Context(..)) @@ -31,6 +32,9 @@ import Data.Either import Data.Set (Set) import qualified Data.Set as Set +import Data.Map (Map) +import qualified Data.Map as Map + class (:<:) small large where ctx' :: Traversal' large small @@ -89,16 +93,20 @@ instance Integral a => Num (FormulaM input a) where quot' :: Integral a => FormulaM input a -> FormulaM input a -> FormulaM input a quot' = liftM2 quot -askQuestion :: (MonadIO m, sInput :<: lInput) => lInput -> Question sInput -> m lInput -askQuestion input q@(Question{..}) = flip (set $ ctx' . answer) input . maybe (throwError q) return <$> askQ prompt (join . fmap readMaybe) +askQuestion :: (MonadIO m, sInput :<: lInput) => String -> lInput -> Question sInput -> m lInput +askQuestion promptPref input q@(Question{..}) = flip (set $ ctx' . answer) input . maybe (throwError q) return <$> askQ (promptPref' ++ prompt) (join . fmap readMaybe) + where + promptPref' + | null promptPref = "" + | otherwise = promptPref ++ " » " -evalFormula :: (MonadIO m, sInput :<: lInput) => lInput -> FormulaM sInput a -> m (lInput, a) +evalFormula :: (MonadIO m, sInput :<: lInput) => String -> lInput -> FormulaM sInput a -> m (lInput, a) evalFormula = evalFormula' [] where - evalFormula' finalChanges input formula = do + evalFormula' finalChanges promptPref input formula = do result <- liftIO . enact . runExceptT . (runReaderT ?? (Context input)) . (evalStateT ?? Set.empty) $ formula case result of - Left q@(Question{..}) -> askQuestion input q >>= flip (evalFormula' $ bool (pure . set (ctx' . answer) $ throwError q) mempty keepResult ++ finalChanges) formula + Left q@(Question{..}) -> askQuestion promptPref input q >>= flip (flip evalFormula' promptPref $ bool (pure . set (ctx' . answer) $ throwError q) mempty keepResult ++ finalChanges) formula Right result -> return (foldr ($) input finalChanges, result) val :: Integral a => Traversal' input (Formula input) -> String -> Bool -> Formula input @@ -109,3 +117,8 @@ val answer prompt keepResult = do d, z :: Integral a => Int -> FormulaM input a d n = liftBase . fmap fromIntegral $ D.d n z n = liftBase . fmap fromIntegral $ D.z n + +type Table a = Map a Rational + +table :: Ord a => Table a -> FormulaM input a +table = liftBase . makeEventProb . Map.assocs -- cgit v1.2.3