fixed questions

5 files changed, 51 insertions, 45 deletions

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)