1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
|
{-# LANGUAGE TemplateHaskell, OverloadedStrings, OverloadedLists, ViewPatterns, MultiParamTypeClasses, FlexibleContexts, RankNTypes, TypeSynonymInstances, FlexibleInstances, ImpredicativeTypes #-}
module Sequence.Contact.Tests
( TestResult(..)
, Test
, enactTest
) where
import Sequence.Formula
import Sequence.Types
import Sequence.Utils
import Sequence.Contact.Types
import Control.Monad
import Control.Monad.Reader
import Control.Lens
import Data.Default
import Data.List
import Data.Maybe
import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
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)
]
where
test k v = maybe mempty (Map.singleton k) <$> preview v
-- skillTest = to (\x -> flip (set tBaseDifficulty) def <$> x)
attributeTest = to (\x -> flip (set tBaseDifficulty) def . (* 10) <$> x)
getTest :: String -> Fold Stats (FormulaM Stats Test)
getTest (CI.mk -> str) = folding tests'
where
tests' state = Map.lookup str (tests state) -- >>= (\get -> preview get state)
instance Completion (FormulaM Stats Test) GameState where
completableLabel _ = "<test>"
complete _ st (CI.foldCase -> prefix) = return . fromMaybe [] . fmap (filter (prefix `isPrefixOf`) . map CI.foldedCase . Map.keys) $ previews (gFocus' . eStats) tests st
instance Argument (FormulaM Stats Test) GameState where
arg str = join <$> preuses (gFocus' . eStats) (preview (getTest str))
enactTest :: Test -> FormulaM input TestResult
enactTest test = toResult <$> d 100
where
critFailureBar = 95 - test^.tCritFailureMod
critSuccessBar = 5 + test^.tCritSuccessMod
bar = test^.tBaseDifficulty + test^.tMod
toResult pw = (toResult' pw) pw (abs $ bar - pw)
toResult' pw
| bar > critSuccessBar
, pw <= critSuccessBar = CritSuccess
| pw <= bar = Success
| pw >= critFailureBar = CritFailure
| otherwise = Failure
-- hasTest :: Stats -> String -> Bool
-- hasTest stats str = has (getTest str) stats
-- rollTest :: String -> FormulaM Stats (Maybe TestResult)
-- rollTest str = preview (getTest str) >>= enactTest'
-- where
-- enactTest' Nothing = return Nothing
-- enactTest' (Just t) = Just <$> (enactTest =<< t)
|
