From d196ace4100ec5f8cfb0fad265d3baa44873fc9d Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 14 Jun 2016 03:26:18 +0200 Subject: fixed questions --- src/Main.hs | 14 +++++------ src/Sequence/Contact/Tests.hs | 5 ++-- src/Sequence/Contact/Types.hs | 20 ++++++++-------- src/Sequence/Formula.hs | 55 ++++++++++++++++++++++++------------------- src/Sequence/Utils.hs | 2 +- 5 files changed, 51 insertions(+), 45 deletions(-) (limited to 'src') diff --git a/src/Main.hs b/src/Main.hs index 3e6b750..636e5ea 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -62,8 +62,6 @@ import qualified Data.Text.Lazy as Lazy (Text) import qualified Data.Text.Lazy as Lazy.Text import Data.Text.Template -import Debug.Trace - main :: IO () main = do historyFile <- getUserCacheFile "sequence" "history" @@ -158,7 +156,7 @@ stateMaintenance = do lStats = gEntities . ix focusId . eStats evalF formula = do stats <- MaybeT $ preuse lStats - (nStats, x) <- (evalFormula name :: Stats -> FormulaM Stats a -> MaybeT (Sh GameState) (Stats, a)) stats formula + (nStats, x) <- (evalFormula [name] :: Stats -> FormulaM Stats a -> MaybeT (Sh GameState) (Stats, a)) stats formula lStats .= nStats return x isDead <- evalF =<< MaybeT (preuse $ lStats . sDead) @@ -182,7 +180,7 @@ stateMaintenance = do cVal <- MaybeT . preuse $ eStats . sSequence . _Just . seqVal . _Just name <- lift . lift $ toName ident nVal' <- MaybeT . preuse $ eStats . sSeqVal - nVal <- MaybeT . focusState eStats $ evalFormula' name nVal' + nVal <- MaybeT . focusState eStats $ evalFormula' [name] nVal' eStats . sSequence . _Just . seqVal . _Just += nVal eStats . sSequence . _Just . seqRound . _Wrapped += 1 gRounds -= 1 @@ -274,7 +272,7 @@ rollTest = withArg $ enactTest' >=> maybe (return ()) (shellPutStrLn . ppResult) enactTest' :: (FormulaM Stats Test) -> Sh GameState (Maybe TestResult) enactTest' test = withFocus' $ \focus -> do focusName <- use gFocus >>= toName . fromJust - (newFocus, result) <- evalFormula focusName focus (enactTest =<< test) + (newFocus, result) <- evalFormula [focusName] focus (enactTest =<< test) gFocus' .= newFocus return result @@ -290,7 +288,7 @@ entitySeqVal' ident = void . runMaybeT $ do sVal <- MaybeT . return $ preview (eStats . sSeqVal) entity name <- toName ident round <- use gRound - (newEntity, sNum) <- evalFormula name entity sVal + (newEntity, sNum) <- evalFormula [name] entity sVal let val = Just $ def & set (seqRound . _Wrapped) round & set seqVal (Just sNum) @@ -329,7 +327,7 @@ doShock dmg efLens = withFocus $ \focusId -> do -- (nStats, x) <- (evalFormula name :: Stats -> FormulaM Stats a -> MaybeT (Sh GameState) (Stats, a)) stats formula -- lStats .= nStats -- return x - evalF = MaybeT . focusState lStats . evalFormula' name + evalF = MaybeT . focusState lStats . evalFormula' [name] cVar cLens = evalF =<< MaybeT (preuse $ lStats . (cripple ^. cLens)) bar <- cVar seBar val <- cVar seVal @@ -350,7 +348,7 @@ takeHit dmg a1 a2 = flip withArg a1 $ \zones -> flip withArg a2 $ \dType -> with lStats = gEntities . ix focusId . eStats name <- toName focusId armor <- MaybeT . preuse $ lStats . sArmor . ix zone - dmg' <- MaybeT . focusState lStats . evalFormula' name $ absorb armor dType dmg + dmg' <- MaybeT . focusState lStats . evalFormula' [name] $ absorb armor dType dmg forM_ (Map.toList dmg') $ \(dType, dmg) -> lift . runMaybeT $ do guard $ dmg > 0 lift $ shellPutStrLn $ name ++ " took " ++ show dmg ++ " " ++ show dType diff --git a/src/Sequence/Contact/Tests.hs b/src/Sequence/Contact/Tests.hs index 8665186..c100ce9 100644 --- a/src/Sequence/Contact/Tests.hs +++ b/src/Sequence/Contact/Tests.hs @@ -40,7 +40,7 @@ tests = do views sExtraSkills (baseTests <>) where - test k v = maybe mempty (Map.singleton k) <$> preview v + test k v = maybe mempty (Map.singleton k) <$> previews v (set (mapped . tName) k) skillTest = to (\x -> flip (set tBaseDifficulty) def <$> x) attributeTest = to (\x -> flip (set tBaseDifficulty) def . (* 10) <$> x) @@ -61,10 +61,11 @@ instance Argument (FormulaM Stats Test) GameState where enactTest :: Test -> FormulaM Stats TestResult enactTest rawTest = do test <- foldM (&) rawTest =<< toListOf (ctx . sModifiers . folded . _Modifier . _2) <$> ask + manualMod <- val ignored [CI.original (rawTest ^. tName), "Modifier"] False let critFailureBar = 95 - test^.tCritFailureMod critSuccessBar = 5 + test^.tCritSuccessMod - bar = test^.tBaseDifficulty + test^.tMod + bar = test^.tBaseDifficulty + test^.tMod + manualMod toResult pw = (toResult' pw) pw (abs $ bar - pw) toResult' pw | bar > critSuccessBar diff --git a/src/Sequence/Contact/Types.hs b/src/Sequence/Contact/Types.hs index 9bb9903..4bd9790 100644 --- a/src/Sequence/Contact/Types.hs +++ b/src/Sequence/Contact/Types.hs @@ -130,16 +130,16 @@ applyModifier effectName modifier = Effect (CI.mk effectName) $ previews ctx app where apply = sModifiers <>~ [Modifier (CI.mk $ effectName ++ " (modifier)") modifier] -vStrength = val sAStrength "Stärke?" True -vEndurance = val sAEndurance "Ausdauer?" True -vMass = val sAMass "Masse?" True -vReflexes = val sAReflexes "Reflexe?" True -vMobility = val sAMobility "Beweglichkeit?" True -vDexterity = val sADexterity "Geschicklichkeit?" True -vIntelligence = val sAIntelligence "Intelligenz?" True -vCharisma = val sACharisma "Charisma?" True -vPerception = val sAPerception "Wahrnehmung?" True -vWillpower = val sAWillpower "Entschlossenheit?" True +vStrength = val sAStrength ["Stärke"] True +vEndurance = val sAEndurance ["Ausdauer"] True +vMass = val sAMass ["Masse"] True +vReflexes = val sAReflexes ["Reflexe"] True +vMobility = val sAMobility ["Beweglichkeit"] True +vDexterity = val sADexterity ["Geschicklichkeit"] True +vIntelligence = val sAIntelligence ["Intelligenz"] True +vCharisma = val sACharisma ["Charisma"] True +vPerception = val sAPerception ["Wahrnehmung"] True +vWillpower = val sAWillpower ["Entschlossenheit"] True scaled :: Ratio Int -> Iso' Int Int scaled r = iso (\x -> floor $ x % 1 * r) (\x -> round $ x % 1 / r) diff --git a/src/Sequence/Formula.hs b/src/Sequence/Formula.hs index 4830788..be5032a 100644 --- a/src/Sequence/Formula.hs +++ b/src/Sequence/Formula.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RecordWildCards, RankNTypes, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, ViewPatterns, TypeFamilies, GADTs, TypeOperators, ExistentialQuantification, FlexibleContexts #-} +{-# LANGUAGE RecordWildCards, RankNTypes, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, ViewPatterns, TypeFamilies, GADTs, TypeOperators, ExistentialQuantification, FlexibleContexts, IncoherentInstances #-} module Sequence.Formula ( FormulaM, Formula, quot' @@ -30,12 +30,12 @@ import Data.Maybe import Data.Either import Data.Tuple -import Data.Set (Set) -import qualified Data.Set as Set - import Data.Map (Map) import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set + class (:<:) small large where ctx' :: Traversal' large small @@ -45,21 +45,27 @@ instance a :<: a where instance a :<: (a, a) where ctx' = both -instance a :<: (a, b) where - ctx' = _1 +instance a :<: b => a :<: (b, c) where + ctx' = _1 . ctx' -instance a :<: (b, a) where +instance a :<: (c, a) where ctx' = _2 instance () :<: a where ctx' = united -data Context small = forall large. (small :<: large) => Context large +instance a :<: b => a :<: Maybe b where + ctx' = _Just . ctx' + +data Context small = forall large. (small :<: large) => Context large (Maybe (Formula small)) ctx :: Traversal' (Context input) input -ctx modifySmall (Context large) = Context <$> ctx' modifySmall large +ctx modifySmall (Context large fSt) = flip Context fSt <$> ctx' modifySmall large + +ctxStore :: Traversal' (Context input) (Formula input) +ctxStore modifyF (Context large fSt) = Context large <$> _Just modifyF fSt -type FormulaM input a = StateT (Set String) (ReaderT (Context input) (ExceptT (Question input) EventM)) a +type FormulaM input a = StateT (Set [String]) (ReaderT (Context input) (ExceptT (Question input) EventM)) a type Formula input = FormulaM input Int @@ -68,7 +74,7 @@ instance MonadBase EventM EventM where data Question input = Question { answer :: Traversal' input (Formula input) - , prompt :: String + , prompt :: [String] , keepResult :: Bool } @@ -94,29 +100,30 @@ instance Integral a => Num (FormulaM input a) where quot' :: Integral a => FormulaM input a -> FormulaM input a -> FormulaM input a quot' = liftM2 quot -askQuestion :: (MonadIO m, sInput :<: lInput) => String -> lInput -> Question sInput -> m lInput -askQuestion promptPref input q@(Question{..}) = flip (set $ ctx' . answer) input . maybe (throwError q) return <$> askQ (promptPref' ++ prompt) (join . fmap readMaybe) +askQuestion :: (MonadIO m, sInput :<: lInput) => [String] -> (lInput, Maybe (Formula sInput)) -> Question sInput -> m (lInput, Maybe (Formula sInput)) +askQuestion promptPref input q@(Question{..}) = flip (if keepResult then set $ _1 . ctx' . answer else set _2 . Just) input . maybe (throwError q) return <$> askQ (wPromptPref $ promptPref ++ prompt) (join . fmap readMaybe) where - promptPref' - | null promptPref = "" - | otherwise = promptPref ++ " » " + wPromptPref [] = " »" + wPromptPref [x] = x ++ " »" + wPromptPref (x:xs) = x ++ " » " ++ wPromptPref xs -evalFormula :: (MonadIO m, sInput :<: lInput) => String -> lInput -> FormulaM sInput a -> m (lInput, a) -evalFormula = evalFormula' [] +evalFormula :: (MonadIO m, sInput :<: lInput) => [String] -> lInput -> FormulaM sInput a -> m (lInput, a) +evalFormula promptPref input = evalFormula' [] promptPref (input, Nothing) where - evalFormula' finalChanges promptPref input formula = do - result <- liftIO . enact . runExceptT . (runReaderT ?? (Context input)) . (evalStateT ?? Set.empty) $ formula + evalFormula' :: (MonadIO m, sInput :<: lInput) => [lInput -> lInput] -> [String] -> (lInput, Maybe (Formula sInput)) -> FormulaM sInput a -> m (lInput, a) + evalFormula' finalChanges promptPref (input, fSt) formula = do + result <- liftIO . enact . runExceptT . (runReaderT ?? (Context input fSt)) . (evalStateT ?? Set.empty) $ formula case result of - Left q@(Question{..}) -> askQuestion promptPref input q >>= flip (flip evalFormula' promptPref $ bool (pure . set (ctx' . answer) $ throwError q) mempty keepResult ++ finalChanges) formula + Left q@(Question{..}) -> askQuestion promptPref (input, fSt) q >>= flip (flip evalFormula' promptPref $ set (ctx' . answer) (throwError q) : finalChanges) formula Right result -> return (foldr ($) input finalChanges, result) -evalFormula' :: (MonadIO m, sInput :<: lInput, MonadState lInput m) => String -> FormulaM sInput a -> m a +evalFormula' :: (MonadIO m, sInput :<: lInput, MonadState lInput m) => [String] -> FormulaM sInput a -> m a evalFormula' promptPref formula = uncurry (<$) . over _2 put . swap =<< flip (evalFormula promptPref) formula =<< get -val :: Integral a => Traversal' input (Formula input) -> String -> Bool -> Formula input +val :: Traversal' input (Formula input) -> [String] -> Bool -> Formula input val answer prompt keepResult = do gets (Set.member prompt) >>= bool (modify $ Set.insert prompt) (modify (Set.delete prompt) >> throwError Question{..}) - preview (ctx . answer) >>= maybe (throwError Question{..}) id + preview (if keepResult then ctx . answer else ctxStore) >>= (modify (Set.delete prompt) >>) . fromMaybe (throwError Question{..}) d, z :: Integral a => Int -> FormulaM input a d n = liftBase . fmap fromIntegral $ D.d n diff --git a/src/Sequence/Utils.hs b/src/Sequence/Utils.hs index 513cb0b..929189e 100644 --- a/src/Sequence/Utils.hs +++ b/src/Sequence/Utils.hs @@ -77,7 +77,7 @@ toDesc :: (MonadState GameState m, MonadIO m) => EntityIdentifier -> m String toDesc ident = do name <- toName ident health <- runMaybeT $ do - maxVit <- MaybeT . focusState (gEntities . ix ident) . evalFormula' name =<< (MaybeT . preuse $ gEntities . ix ident . eStats . sMaxVitality) + maxVit <- MaybeT . focusState (gEntities . ix ident) . evalFormula' [name] =<< (MaybeT . preuse $ gEntities . ix ident . eStats . sMaxVitality) hDamage <- MaybeT . preuse $ gEntities . ix ident . eStats . sTotalDamage fDamage <- MaybeT . preuse $ gEntities . ix ident . eStats . sFatigue return $ (maxVit - hDamage, maxVit - fDamage) -- cgit v1.2.3