Death & Unconsciousness

4 files changed, 86 insertions, 26 deletions

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