Death & Unconsciousness

3 files changed, 27 insertions, 4 deletions

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 _ = "<entity>"
   complete _ st prefix = return . filter ((isPrefixOf `on` CI.foldCase) prefix) . map ((evalState ?? st) . toName) . Map.keys $ st ^. gEntities