From bf24ff9ffd25841da5e20386548fb63ff191ed9a Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sat, 11 Jun 2016 23:00:13 +0200 Subject: Death & Unconsciousness --- default.nix | 31 +++++++++++++++++ src/Main.hs | 81 +++++++++++++++++++++++++++++++------------ src/Sequence/Contact/Types.hs | 8 ++++- src/Sequence/Formula.hs | 2 +- src/Sequence/Utils.hs | 21 +++++++++-- 5 files changed, 117 insertions(+), 26 deletions(-) diff --git a/default.nix b/default.nix index 4b974c3..b496745 100644 --- a/default.nix +++ b/default.nix @@ -56,6 +56,37 @@ rec { -- The shell description and utility functions -- 2.8.0 + + + From 20e394aa3ea287fcaacde9c076c9f49929b28ece Mon Sep 17 00:00:00 2001 + From: Gregor Kleen + Date: Sat, 11 Jun 2016 22:06:36 +0200 + Subject: [PATCH] Allow modification of state in beforePrompt + + --- + src/System/Console/Shell/RunShell.hs | 6 ++++-- + 1 file changed, 4 insertions(+), 2 deletions(-) + + diff --git a/src/System/Console/Shell/RunShell.hs b/src/System/Console/Shell/RunShell.hs + index 79ffb54..3e0b95b 100644 + --- a/src/System/Console/Shell/RunShell.hs + +++ b/src/System/Console/Shell/RunShell.hs + @@ -217,9 +217,11 @@ shellLoop desc backend iss = loop + bst = backendState iss + + loop st = do + - flushOutput backend bst + + flushOutput backend bst + + + + runSh st (outputString backend bst) (beforePrompt desc) >>= loop' . fst + + - runSh st (outputString backend bst) (beforePrompt desc) + + loop' st = do + setAttemptedCompletionFunction backend bst + (completionFunction desc backend bst st) + + -- + 2.8.3 ''); }; }; diff --git a/src/Main.hs b/src/Main.hs index e8e0a49..f409a04 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -36,6 +36,7 @@ import Data.Function import Control.Monad.State.Strict import Control.Monad.Trans.Maybe +import Control.Monad.List import Sequence.Types import Sequence.Contact.Types @@ -54,6 +55,8 @@ 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" @@ -63,7 +66,8 @@ main = do { historyFile = Just historyFile , prompt = \st -> return $ maybe "" (++ " ") ((evalState ?? st) . toName <$> view gFocus st) ++ "→ " , beforePrompt = do - { gets stateOutline >>= (\str -> if null str then return () else shellPutStr str) + { stateMaintenance + ; stateOutline >>= (\str -> if null str then return () else shellPutStr str) ; gets focusNotes >>= (\str -> if null str then return () else shellPutStr str) } , commandStyle = OnlyCommands @@ -94,27 +98,38 @@ main = do } void $ runShell description haskelineBackend (def :: GameState) -stateOutline :: GameState -> String -stateOutline st - | null (st ^. priorityQueue) = "" - | otherwise = unlines . map table $ st ^. gRounds' +stateOutline :: Sh GameState String +stateOutline = do + st <- get + case st of + st | null (st ^. priorityQueue) -> return "" + | otherwise -> unlines <$> mapM table (st ^. gRounds') where - table round = layoutTableToString rowGs (Just (roundStr round : factions, repeat def)) (repeat def) unicodeBoldHeaderS - where - pQueue = filter (\(v, _) -> round == v ^. seqRound . _Wrapped)$ st ^. priorityQueue + table :: Int -> Sh GameState String + table round = do + factions <- map (view faction') <$> use inhabitedFactions + st <- get + let + roundStr 0 = "Current Round" + roundStr 1 = "Next Round" + roundStr n = show n ++ " Rounds later" + + pQueue = filter (\(v, _) -> round == v ^. seqRound . _Wrapped) $ st ^. priorityQueue protoRows = groupBy ((==) `on` fst) pQueue faction id = fromJust $ view eFaction <$> Map.lookup id (st ^. gEntities) - factionIndex id = fromJust $ elemIndex (view faction' $ faction id) factions - rowGs = do - rowGroup'@((seq, _):_) <- protoRows + + rowGs :: Sh GameState [RowGroup] + rowGs = runListT $ do + rowGroup'@((seq, _):_) <- ListT $ return protoRows let rowGroup = map snd rowGroup' - factionColumn i = [evalState ?? st $ toName x | x <- rowGroup, factionIndex x == i ] - return . colsAllG top $ [maybe "" show $ view seqVal seq] : map factionColumn [0..(length factions - 1)] - roundStr 0 = "Current Round" - roundStr 1 = "Next Round" - roundStr n = show n ++ " Rounds later" - factions = map (view faction') $ st ^. inhabitedFactions + factionColumn i = runListT $ do + x <- ListT $ return rowGroup + guard $ factionIndex x == i + toDesc x + factionIndex id = fromJust $ elemIndex (view faction' $ faction id) factions + colsAllG top . ([maybe "" show $ view seqVal seq] :) <$> mapM factionColumn [0..(length factions - 1)] + layoutTableToString <$> rowGs <*> pure (Just (roundStr round : factions, repeat def)) <*> pure (repeat def) <*> pure unicodeBoldHeaderS focusNotes :: GameState -> String focusNotes = maybe "" (unlines . map dotted) . preview (gFocus' . eNotes) @@ -125,6 +140,27 @@ focusNotes = maybe "" (unlines . map dotted) . preview (gFocus' . eNotes) | fstL : tailL <- lines str = " • " ++ fstL ++ "\n" ++ unlines (map (" " ++ ) tailL) | otherwise = "" +stateMaintenance :: Sh GameState () +stateMaintenance = do + void . runMaybeT $ do + focusId <- MaybeT $ use gFocus + name <- lift $ toName focusId + let + lStats :: Traversal' GameState Stats + 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 + lStats .= nStats + return x + isDead <- evalF =<< MaybeT (preuse $ lStats . sDead) + isUnconscious <- evalF =<< MaybeT (preuse $ lStats . sUnconscious) + guard $ isDead || isUnconscious + when isDead . lift . shellPutStrLn $ name ++ " died" + when isUnconscious . lift . shellPutStrLn $ name ++ " is unconscious" + gFocus' . eSeqVal .= Nothing + gFocus .= Nothing + -- Query state listFactions, listEntities :: Sh GameState () listFactions = use inhabitedFactions >>= mapM_ (shellPutStrLn . view faction') @@ -259,11 +295,12 @@ doShock dmg efLens = withFocus $ \focusId -> do name <- toName focusId void . runMaybeT $ do cripple <- MaybeT . preuse $ lStats . efLens - let evalF formula = do - stats <- MaybeT $ preuse lStats - (nStats, x) <- (evalFormula name :: Stats -> FormulaM Stats a -> MaybeT (Sh GameState) (Stats, a)) stats formula - lStats .= nStats - return x + let -- evalF formula = do + -- stats <- MaybeT $ preuse lStats + -- (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 cVar cLens = evalF =<< MaybeT (preuse $ lStats . (cripple ^. cLens)) bar <- cVar seBar val <- cVar seVal diff --git a/src/Sequence/Contact/Types.hs b/src/Sequence/Contact/Types.hs index 9854d92..80d4360 100644 --- a/src/Sequence/Contact/Types.hs +++ b/src/Sequence/Contact/Types.hs @@ -181,4 +181,10 @@ sDead :: Fold Stats (FormulaM Stats Bool) sDead = folding $ do maxVitality <- preview sMaxVitality damage <- view sTotalDamage - return $ liftM2 (>) <$> Just (return damage) <*> maxVitality + return $ liftM2 (>=) <$> Just (return damage) <*> maxVitality + +sUnconscious :: Fold Stats (FormulaM Stats Bool) +sUnconscious = folding $ do + maxVitality <- preview sMaxVitality + damage <- view sFatigue + return $ liftM2 (>=) <$> Just (return damage) <*> maxVitality diff --git a/src/Sequence/Formula.hs b/src/Sequence/Formula.hs index 4f2e61b..4830788 100644 --- a/src/Sequence/Formula.hs +++ b/src/Sequence/Formula.hs @@ -3,7 +3,7 @@ module Sequence.Formula ( FormulaM, Formula, quot' , (:<:)(..), Context(..), ctx - , evalFormula + , evalFormula, evalFormula' , val , d, z , Table, table diff --git a/src/Sequence/Utils.hs b/src/Sequence/Utils.hs index 8b205ea..1b52630 100644 --- a/src/Sequence/Utils.hs +++ b/src/Sequence/Utils.hs @@ -1,8 +1,9 @@ -{-# LANGUAGE ViewPatterns, FlexibleContexts, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, UndecidableInstances, OverloadedStrings #-} +{-# LANGUAGE ViewPatterns, FlexibleContexts, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, UndecidableInstances, OverloadedStrings, RankNTypes #-} module Sequence.Utils ( withArg, withFocus, withFocus' - , toName + , focusState + , toName, toDesc , Argument(..) , Completion(..) , module Sequence.Utils.Ask @@ -44,6 +45,7 @@ import System.Console.Shell.Backend.Haskeline import Sequence.Utils.Ask import Sequence.Contact.Types +import Sequence.Formula class Argument a st | a -> st where arg :: String -> Sh st (Maybe a) @@ -59,6 +61,9 @@ withFocus f = use gFocus >>= maybe (shellPutErrLn $ "Currently not focusing any withFocus' :: (Entity -> Sh GameState a) -> Sh GameState (Maybe a) withFocus' f = preuse gFocus' >>= maybe (Nothing <$ shellPutErrLn "Currently not focusing any entity") (fmap Just . f) +focusState :: MonadState GameState m => Traversal' GameState a -> StateT a (MaybeT m) b -> m (Maybe b) +focusState lens action = runMaybeT $ uncurry (<$) . over _2 (lens .=) =<< runStateT action =<< MaybeT (preuse lens) + unaligned = view faction' def toName :: MonadState GameState m => EntityIdentifier -> m String @@ -68,6 +73,18 @@ toName ident = do let number' = bool id ('#':) isShadowed $ number fromMaybe number' . fmap (review entityName) . Bimap.lookup ident <$> use gEntityNames +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) + hDamage <- MaybeT . preuse $ gEntities . ix ident . eStats . sTotalDamage + fDamage <- MaybeT . preuse $ gEntities . ix ident . eStats . sFatigue + return $ (maxVit - hDamage, maxVit - fDamage) + case health of + Just dmg -> return $ name ++ " " ++ show dmg + Nothing -> return name + instance Completion EntityIdentifier GameState where completableLabel _ = "" complete _ st prefix = return . filter ((isPrefixOf `on` CI.foldCase) prefix) . map ((evalState ?? st) . toName) . Map.keys $ st ^. gEntities -- cgit v1.2.3