From eea3a546370ed95321dcc21b4db739ad0d893dfb Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sat, 25 Jun 2016 17:50:52 +0200 Subject: Inspect entities --- src/Main.hs | 10 ++++++++-- src/Sequence/Formula.hs | 26 +++++++++++++++++++++----- src/Sequence/Utils.hs | 15 ++++++++++++++- 3 files changed, 43 insertions(+), 8 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index 636e5ea..eeed4d9 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -99,8 +99,9 @@ main = do , cmd "hit" takeHit "Damage the focused entity" , cmd "fatigue" takeFatigue "Inflict fatigue damage upon the focused entity" , cmd "log" dumpLog "Print the combat log" + , cmd "val" printVal "Find the distribution of a specific value of the current entities" ] - , wordBreakChars = wordBreakChars initialShellDescription \\ [',', '*'] + , wordBreakChars = wordBreakChars initialShellDescription \\ [','] } void $ runShell description haskelineBackend (def :: GameState) @@ -336,7 +337,7 @@ doShock dmg efLens = withFocus $ \focusId -> do then guard $ dmg >= reBar else guard $ val >= bar lStats . efLens . seApplied .= True - (CI.original -> effectName, effect) <- view _Effect <$> (evalF . table $ cripple ^. seEffect) + Effect (CI.original -> effectName) effect <- evalF . table $ cripple ^. seEffect lStats <~ (MaybeT . fmap join . runMaybeT $ evalF effect) lift $ shellPutStrLn effectName lift . addNote $ "Effect: " ++ effectName @@ -371,3 +372,8 @@ dumpLog = use gLog >>= mapMOf (each . _1) toName >>= shellPutStrLn . toTable where toTable :: Seq (String, String) -> String toTable (map (rowG . toListOf both) . toList -> table) = layoutTableToString table (Just (["Entity", "String"], [def, def])) [def, def] unicodeBoldHeaderS + +printVal :: Completable (Formula Stats) -> Sh GameState () +printVal = withArg $ \formula -> withFocus $ \focusId -> do + name <- toName focusId + shellPutStrLn . show =<< focusState (gEntities . ix focusId . eStats) (findDistribution' [name] formula) diff --git a/src/Sequence/Formula.hs b/src/Sequence/Formula.hs index a3675c6..2ac1210 100644 --- a/src/Sequence/Formula.hs +++ b/src/Sequence/Formula.hs @@ -4,6 +4,7 @@ module Sequence.Formula ( FormulaM, Formula, quot' , (:<:)(..), Context(..), ctx , evalFormula, evalFormula' + , findDistribution, findDistribution' , val , d, z , Table, table @@ -109,18 +110,33 @@ askQuestion promptPref input q@(Question{..}) = flip (if keepResult then set $ _ sep = "ยป" evalFormula :: (MonadIO m, sInput :<: lInput) => [String] -> lInput -> FormulaM sInput a -> m (lInput, a) -evalFormula promptPref input = evalFormula' [] promptPref (input, Nothing) +evalFormula = primEvalFormula $ liftIO . enact + +findDistribution :: (MonadIO m, sInput :<: lInput, Ord a) => [String] -> lInput -> FormulaM sInput a -> m (lInput, (Map a Rational)) +findDistribution = primEvalFormula $ return . fmap Map.fromList . seqEither . outcomes where - 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 + seqEither :: [(Either q a, Rational)] -> Either q [(a, Rational)] + seqEither = mapM seqEither' + + seqEither' (Left a, _) = Left a + seqEither' (Right b, c) = Right (b, c) + +primEvalFormula :: (MonadIO m, sInput :<: lInput) => (EventM (Either (Question sInput) a) -> m (Either (Question sInput) r)) -> [String] -> lInput -> FormulaM sInput a -> m (lInput, r) +primEvalFormula fromOutcomes promptPref input = evalFormula' fromOutcomes [] promptPref (input, Nothing) + where + evalFormula' :: (MonadIO m, sInput :<: lInput) => (EventM (Either (Question sInput) a) -> m (Either (Question sInput) r)) -> [lInput -> lInput] -> [String] -> (lInput, Maybe (Formula sInput)) -> FormulaM sInput a -> m (lInput, r) + evalFormula' fromOutcomes finalChanges promptPref (input, fSt) formula = do + result <- fromOutcomes . runExceptT . (runReaderT ?? (Context input fSt)) . (evalStateT ?? Set.empty) $ formula case result of - Left q@(Question{..}) -> askQuestion promptPref (input, fSt) q >>= flip (flip evalFormula' promptPref $ set (ctx' . answer) (throwError q) : finalChanges) formula + Left q@(Question{..}) -> askQuestion promptPref (input, fSt) q >>= flip (flip (evalFormula' fromOutcomes) 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' promptPref formula = uncurry (<$) . over _2 put . swap =<< flip (evalFormula promptPref) formula =<< get +findDistribution' :: (MonadIO m, sInput :<: lInput, MonadState lInput m, Ord a) => [String] -> FormulaM sInput a -> m (Map a Rational) +findDistribution' promptPref formula = uncurry (<$) . over _2 put . swap =<< flip (findDistribution promptPref) formula =<< get + 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{..}) diff --git a/src/Sequence/Utils.hs b/src/Sequence/Utils.hs index 929189e..ba6ce95 100644 --- a/src/Sequence/Utils.hs +++ b/src/Sequence/Utils.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ViewPatterns, FlexibleContexts, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, UndecidableInstances, OverloadedStrings, RankNTypes #-} +{-# LANGUAGE ViewPatterns, FlexibleContexts, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, UndecidableInstances, OverloadedStrings, OverloadedLists, RankNTypes #-} module Sequence.Utils ( withArg, withFocus, withFocus' @@ -140,3 +140,16 @@ instance Argument DamageType GameState where arg (CI.mk -> word) = return $ Map.lookup word types where types = Map.fromList [(CI.mk $ show dType, dType) | dType <- [minBound .. maxBound]] + +instance Completion (Formula Stats) GameState where + completableLabel _ = "" + complete _ st (CI.foldCase -> prefix) = return . map CI.original . filter ((prefix `isPrefixOf`) . CI.foldedCase) . Map.keys $ Map.filter (isJust . (\a -> preview (gFocus' . eStats . folding a) st)) statAccessors + +instance Argument (Formula Stats) GameState where + arg (CI.mk -> name) = runMaybeT $ do + accessor <- MaybeT . return $ Map.lookup name statAccessors + MaybeT . preuse $ gFocus' . eStats . folding accessor + +statAccessors :: Map (CI String) (Stats -> Maybe (Formula Stats)) +statAccessors = [ + ] -- cgit v1.2.3