Framework for rolling tests

6 files changed, 165 insertions, 13 deletions

diff --git a/src/Main.hs b/src/Main.hs
index 9ea7a49..c6eee62 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -32,7 +32,9 @@ import Data.Function
 import Control.Monad.State.Strict
 
 import Sequence.Types
+import Sequence.Contact.Types
 import Sequence.Contact.Archetypes
+import Sequence.Contact.Tests
 import Sequence.Utils
 import Sequence.Formula
 
@@ -62,6 +64,7 @@ main = do
                                     , cmd "align" alignEntity "Align the focused entity to a faction – creating it, if necessary"
                                     , cmd "name" nameEntity "Name the current entity overriding previous name assignments"
                                     , cmd "spawn" spawnEntity "Create a new entity from an archetype focusing on it"
+                                    , cmd "roll" rollTest "Roll a test using the stats of the currently focused entity"
                                     ]
                   }
   void $ runShell description haskelineBackend (def :: GameState)
@@ -95,7 +98,7 @@ alignEntity = withArg $ \nFaction -> withFocus $ \ident -> gEntities %= Map.adju
 
 -- Automatic focus
 focusTip, blur :: Sh GameState ()
-focusTip = gFocus <~ use tip
+focusTip = gFocus <~ preuse tip
 blur     = gFocus .= Nothing
 
 -- Manual focus
@@ -122,3 +125,13 @@ spawnEntity = withArg $ \entity -> do
 nameEntity :: String -> Sh GameState ()
 nameEntity ('#':_) = shellPutErrLn "We do not allow names that might shadow explicit access to entities via their number (‘#<n>’)"
 nameEntity name = withFocus $ \ident -> modifying gEntityNames $ Bimap.insert ident (name ^. entityName)
+
+rollTest :: Completable (FormulaM Stats Test) -> Sh GameState ()
+rollTest = withArg $ enactTest' >=> maybe (return ()) (shellPutStrLn . show)
+
+enactTest' :: (FormulaM Stats Test) -> Sh GameState (Maybe TestResult)
+enactTest' test = withFocus' $ \focus -> do
+  (newStats, result) <- evalFormula (view eStats focus) (enactTest =<< test)
+  gFocus'.eStats .= newStats
+  return result
+      
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
diff --git a/src/Sequence/Formula.hs b/src/Sequence/Formula.hs
index 66672a2..c3e9e33 100644
--- a/src/Sequence/Formula.hs
+++ b/src/Sequence/Formula.hs
@@ -23,6 +23,9 @@ import Text.Read (readMaybe)
 import Data.Bool
 import Data.List
 import Data.Maybe
+import Data.Either
+
+import Debug.Trace
 
 
 type FormulaM input a = ReaderT input (ExceptT (Question input) EventM) a
@@ -35,6 +38,15 @@ data Question input = Question
                       , keepResult :: Bool
                       }
 
+instance Eq (Question a) where
+  (==) _ _ = True
+
+instance Ord (Question a) where
+  (<=) _ _ = True
+
+instance Show (Question a) where
+  show Question{..} = show prompt
+
 instance Integral a => Num (FormulaM input a) where
   (+) x y = (+) <$> x <*> y
   (-) x y = (-) <$> x <*> y
@@ -51,17 +63,18 @@ quot' = liftM2 quot
 askQuestion :: MonadIO m => input -> (Question input) -> m input
 askQuestion input q@(Question{..}) = flip (set answer) input . maybe (throwError q) return <$> askQ prompt (join . fmap readMaybe)
 
-evalFormula :: MonadIO m => input -> FormulaM input a -> m (input, a)
+evalFormula :: (MonadIO m, Ord a, Show a) => input -> FormulaM input a -> m (input, a)
 evalFormula = evalFormula' []
   where
-    evalFormula' finalChanges input formula = do
-      result <- liftIO . enact . runExceptT . (runReaderT ?? input) $ formula
+    evalFormula' finalChanges input formula = trace "evalFormula'" $ do
+      result <- liftIO . enact . traceShowId . runExceptT . (runReaderT ?? input) $ formula
+      liftIO . traceIO $ show (isLeft result, isRight result)
       case result of
         Left q@(Question{..}) -> askQuestion input q >>= flip (evalFormula' $ bool (pure . set 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
-val answer prompt keepResult = preview answer >>= maybe (throwError Question{..}) id
+val answer prompt keepResult = preview answer >>= maybe (throwError Question{..}) id . trace "val"
 
 -- viewL :: Lens' lInput sInput -> Prism' (FormulaM sInput a) (FormulaM lInput a)
 -- viewL lTrav = iso asL asS
diff --git a/src/Sequence/Types.hs b/src/Sequence/Types.hs
index c47136c..541505c 100644
--- a/src/Sequence/Types.hs
+++ b/src/Sequence/Types.hs
@@ -7,7 +7,7 @@ module Sequence.Types
   , Entity(..), eFaction, eSeqVal, eStats
   , EntityName(..), entityName
   , EntityIdentifier(..), entityId, entityId'
-  , inhabitedFactions, priorityQueue, tip, insertEntity
+  , inhabitedFactions, priorityQueue, tip, insertEntity, gFocus'
   ) where
 
 import Control.Lens
@@ -24,6 +24,7 @@ import qualified Data.Map.Strict as Map
 import Data.Bimap (Bimap)
 import qualified Data.Bimap as Bimap
 
+import Control.Monad.Reader
 import Control.Monad.State
 
 import Data.List
@@ -117,8 +118,31 @@ priorityQueue = to priorityQueue'
     filter (Nothing, _) = mempty
     filter (Just val, id) = pure (val, id)
 
-tip :: Getter GameState (Maybe EntityIdentifier)
-tip = priorityQueue . to (fmap snd . listToMaybe)
+tip :: Fold GameState EntityIdentifier
+tip = priorityQueue . folding (fmap snd . listToMaybe)
+
+gFocus' :: Traversal' GameState Entity
+gFocus' modifyFocus = do
+  focusIdent <- view gFocus
+  case focusIdent of
+    Nothing -> pure <$> ask
+    Just focusIdent -> do
+      focus <- view (gEntities . at focusIdent)
+      case focus of
+        Nothing -> pure <$> ask
+        Just focus -> do
+          st <- ask
+          return $ flip (set $ gEntities . at focusIdent) st . Just <$> modifyFocus focus
+      
+-- gFocus' = prism' getFocus setFocus
+--   where
+--     getFocus = do
+--       ident <- preview tip
+--       case ident of
+--         Nothing -> return Nothing
+--         Just ident' -> do
+--           views gEntities $ Map.lookup ident'
+--     setFocus 
 
 gNextId' :: Getter GameState EntityIdentifier
 gNextId' = gNextId
diff --git a/src/Sequence/Utils.hs b/src/Sequence/Utils.hs
index 9fc0ab2..517c3c2 100644
--- a/src/Sequence/Utils.hs
+++ b/src/Sequence/Utils.hs
@@ -1,7 +1,7 @@
 {-# LANGUAGE ViewPatterns, FlexibleContexts, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, UndecidableInstances, OverloadedStrings #-}
 
 module Sequence.Utils
-  ( withArg, withFocus
+  ( withArg, withFocus, withFocus'
   , toName
   , Argument(..)
   , Completion(..)
@@ -48,9 +48,10 @@ withArg f (Completable str) = arg str >>= \a -> case a of
   Just a  -> f a
 
 withFocus :: (EntityIdentifier -> Sh GameState ()) -> Sh GameState ()
-withFocus f = use gFocus >>= \focus -> case focus of
-  Nothing -> shellPutErrLn $ "Currently not focusing any entity"
-  Just id -> f id
+withFocus f = use gFocus >>= maybe (shellPutErrLn $ "Currently not focusing any entity") f
+
+withFocus' :: (Entity -> Sh GameState a) -> Sh GameState (Maybe a)
+withFocus' f = preuse gFocus' >>= maybe (Nothing <$ shellPutErrLn "Currently not focusing any entity") (fmap Just . f)
 
 unaligned = view faction' def