From e93892c008759957e4ee567e7e642bd8a0dd9286 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 5 Jun 2016 01:10:24 +0200 Subject: Framework for rolling tests --- src/Main.hs | 15 ++++++- src/Sequence/Contact/Tests.hs | 100 ++++++++++++++++++++++++++++++++++++++++++ src/Sequence/Contact/Types.hs | 3 +- src/Sequence/Formula.hs | 21 +++++++-- src/Sequence/Types.hs | 30 +++++++++++-- src/Sequence/Utils.hs | 9 ++-- 6 files changed, 165 insertions(+), 13 deletions(-) create mode 100644 src/Sequence/Contact/Tests.hs 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 (‘#’)" 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 _ = "" + 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 -- cgit v1.2.3