summaryrefslogtreecommitdiff
path: root/src/Sequence/Contact
diff options
context:
space:
mode:
authorGregor Kleen <gkleen@yggdrasil.li>2016-06-05 02:11:43 +0200
committerGregor Kleen <gkleen@yggdrasil.li>2016-06-05 02:11:43 +0200
commitf434263fcce697f29c668a1c9ac2f05a1de1012c (patch)
tree3104ff38f383f64253a62d5b9faad0046d09668b /src/Sequence/Contact
parentbf7b92a4daff86e3853b1005dcd18c94d14ac362 (diff)
download2017-01-16_17:13:37-f434263fcce697f29c668a1c9ac2f05a1de1012c.tar
2017-01-16_17:13:37-f434263fcce697f29c668a1c9ac2f05a1de1012c.tar.gz
2017-01-16_17:13:37-f434263fcce697f29c668a1c9ac2f05a1de1012c.tar.bz2
2017-01-16_17:13:37-f434263fcce697f29c668a1c9ac2f05a1de1012c.tar.xz
2017-01-16_17:13:37-f434263fcce697f29c668a1c9ac2f05a1de1012c.zip
more pretty
Diffstat (limited to 'src/Sequence/Contact')
-rw-r--r--src/Sequence/Contact/Archetypes.hs2
-rw-r--r--src/Sequence/Contact/Tests.hs14
2 files changed, 10 insertions, 6 deletions
diff --git a/src/Sequence/Contact/Archetypes.hs b/src/Sequence/Contact/Archetypes.hs
index 3b014e4..8eb9dd7 100644
--- a/src/Sequence/Contact/Archetypes.hs
+++ b/src/Sequence/Contact/Archetypes.hs
@@ -23,7 +23,7 @@ import qualified Data.CaseInsensitive as CI
23 23
24instance Completion Entity GameState where 24instance Completion Entity GameState where
25 completableLabel _ = "<archetype>" 25 completableLabel _ = "<archetype>"
26 complete _ _ (CI.foldCase -> prefix) = return . filter (prefix `isPrefixOf`) . map CI.foldedCase $ Map.keys archetypes 26 complete _ _ (CI.foldCase -> prefix) = return . map CI.original . filter ((prefix `isPrefixOf`) . CI.foldedCase) $ Map.keys archetypes
27 27
28instance Argument Entity GameState where 28instance Argument Entity GameState where
29 arg = return . fmap (flip (set eStats) def) . flip Map.lookup archetypes . CI.mk 29 arg = return . fmap (flip (set eStats) def) . flip Map.lookup archetypes . CI.mk
diff --git a/src/Sequence/Contact/Tests.hs b/src/Sequence/Contact/Tests.hs
index 86f72b5..8aa072a 100644
--- a/src/Sequence/Contact/Tests.hs
+++ b/src/Sequence/Contact/Tests.hs
@@ -1,8 +1,8 @@
1{-# LANGUAGE TemplateHaskell, OverloadedStrings, OverloadedLists, ViewPatterns, MultiParamTypeClasses, FlexibleContexts, RankNTypes, TypeSynonymInstances, FlexibleInstances, ImpredicativeTypes #-} 1{-# LANGUAGE TemplateHaskell, OverloadedStrings, OverloadedLists, ViewPatterns, MultiParamTypeClasses, FlexibleContexts, RankNTypes, TypeSynonymInstances, FlexibleInstances, ImpredicativeTypes #-}
2 2
3module Sequence.Contact.Tests 3module Sequence.Contact.Tests
4 ( TestResult(..) 4 ( TestResult(..), rWith, rBy
5 , Test 5 , Test, tCritSuccessMod, tCritFailureMod, tBaseDifficulty, tMod
6 , enactTest 6 , enactTest
7 ) where 7 ) where
8 8
@@ -55,12 +55,16 @@ instance Default Test where
55 } 55 }
56 56
57tests :: MonadReader Stats m => m (Map (CI String) (FormulaM Stats Test)) 57tests :: MonadReader Stats m => m (Map (CI String) (FormulaM Stats Test))
58tests = mconcat <$> sequence [ test "Stärke" (sAStrength . attributeTest) 58tests = mconcat <$> sequence [ test "Stärke" $ sAStrength . attributeTest
59
60 , test "Archaische Distanzwaffen" $ sSArchaicRanged . skillTest
61
62 , test "Beißen" $ sSBiting . skillTest
59 ] 63 ]
60 where 64 where
61 test k v = maybe mempty (Map.singleton k) <$> preview v 65 test k v = maybe mempty (Map.singleton k) <$> preview v
62 66
63 -- skillTest = to (\x -> flip (set tBaseDifficulty) def <$> x) 67 skillTest = to (\x -> flip (set tBaseDifficulty) def <$> x)
64 attributeTest = to (\x -> flip (set tBaseDifficulty) def . (* 10) <$> x) 68 attributeTest = to (\x -> flip (set tBaseDifficulty) def . (* 10) <$> x)
65 69
66 70
@@ -71,7 +75,7 @@ getTest (CI.mk -> str) = folding tests'
71 75
72instance Completion (FormulaM Stats Test) GameState where 76instance Completion (FormulaM Stats Test) GameState where
73 completableLabel _ = "<test>" 77 completableLabel _ = "<test>"
74 complete _ st (CI.foldCase -> prefix) = return . fromMaybe [] . fmap (filter (prefix `isPrefixOf`) . map CI.foldedCase . Map.keys) $ previews (gFocus' . eStats) tests st 78 complete _ st (CI.foldCase -> prefix) = return . fromMaybe [] . fmap (map CI.original . filter ((prefix `isPrefixOf`) . CI.foldedCase) . Map.keys) $ previews (gFocus' . eStats) tests st
75 79
76instance Argument (FormulaM Stats Test) GameState where 80instance Argument (FormulaM Stats Test) GameState where
77 arg str = join <$> preuses (gFocus' . eStats) (preview (getTest str)) 81 arg str = join <$> preuses (gFocus' . eStats) (preview (getTest str))