From e93892c008759957e4ee567e7e642bd8a0dd9286 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Sun, 5 Jun 2016 01:10:24 +0200
Subject: Framework for rolling tests

---
 src/Sequence/Contact/Tests.hs | 100 ++++++++++++++++++++++++++++++++++++++++++
 src/Sequence/Contact/Types.hs |   3 +-
 2 files changed, 102 insertions(+), 1 deletion(-)
 create mode 100644 src/Sequence/Contact/Tests.hs

(limited to 'src/Sequence/Contact')

diff --git a/src/Sequence/Contact/Tests.hs b/src/Sequence/Contact/Tests.hs
new file mode 100644
index 0000000..86f72b5
--- /dev/null
+++ b/src/Sequence/Contact/Tests.hs
@@ -0,0 +1,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)
diff --git a/src/Sequence/Contact/Types.hs b/src/Sequence/Contact/Types.hs
index 4166812..c00a60d 100644
--- a/src/Sequence/Contact/Types.hs
+++ b/src/Sequence/Contact/Types.hs
@@ -1,9 +1,10 @@
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TemplateHaskell, RecordWildCards, OverloadedStrings, OverloadedLists, ViewPatterns, RankNTypes #-}
 
 module Sequence.Contact.Types where
 
 import Sequence.Formula
 
+import Control.Monad
 import Control.Lens
 
 import Data.Default
-- 
cgit v1.2.3