Timers for use with probabilistic focus and without

6 files changed, 194 insertions, 36 deletions

diff --git a/src/Main.hs b/src/Main.hs
index 54ec08a..db49e14 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -36,6 +36,7 @@ import Data.Maybe
 import Data.Bool
 import Data.Monoid (All(..))
 import Data.Ord
+import Data.Ratio
 
 import Data.Foldable (toList)
 
@@ -84,7 +85,7 @@ main = do
                                     , helpCommand "help"
                                     , cmd "entities" listEntities "List all entities"
                                     , cmd "tip" focusTip "Focus the entity at the top of the queue"
-                                    , cmd "ptip" pFocusTip "Focus a random entity"
+                                    , cmd "pTip" pFocusTip "Focus a random entity"
                                     , cmd "focus" setFocus "Focus a specific entity"
                                     , cmd "blur" blur "Focus no entity"
                                     , cmd "remove" remove "Remove the focused entity from the queue"
@@ -98,6 +99,9 @@ main = do
                                     , cmd "test" rollTest "Roll a test using the stats of the currently focused entity"
                                     , cmd "combat" entitySeqVal "Roll sequence value for the current focus and enter combat"
                                     , cmd "combat'" factionSeqVal "Roll sequence values for all members of a faction and have them enter combat"
+                                    , cmd "timer" entityTimer "Set a timer associated with the current entity"
+                                    , cmd "pTimer" pEntityTimer "Set a timer associated with the current entity. Scale remaining time dynamically with the number of combatants"
+                                    , cmd "untimer" clearEntityTimer "Remove the timer associated with the current entity"
                                     , cmd "uncombat" clearEntitySeqVal "Drop the focused entity out of combat"
                                     , cmd "uncombat'" clearFactionSeqVal "Drop all members of a faction out of combat"
                                     , cmd "spend" spendSeq "Spend some of the current focus´ AP"
@@ -117,13 +121,19 @@ main = do
 stateOutline :: Sh GameState String
 stateOutline = do
   st <- get
-  case st of
-    st | null (st ^. priorityQueue) -> return ""
-       | otherwise                  -> unlines <$> mapM table (st ^. gRounds')
+  time <- use gTimer
+
+  unlines <$> sequence ( ( if not (null $ st ^. timers) || not (null $ st ^. gRounds')
+                           then [ return $ "Round timer: " ++ show time ]
+                           else []
+                         )
+                         ++ ( if not (null $ st ^. timers) then [ tTable ] else [] )
+                         ++ ( if not (null $ st ^. gRounds') then map table (st ^. gRounds') else [] )
+                       )
   where
     table :: Int -> Sh GameState String
     table round = do
-      factions <- map (view faction') <$> use inhabitedFactions
+      factions <- map (view faction') <$> use combatFactions
       st <- get
       let
         roundStr 0 = "Current Round"
@@ -147,6 +157,27 @@ stateOutline = do
           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
       tableString <$> pure (repeat def) <*> pure unicodeBoldHeaderS <*> pure (titlesH $ roundStr round : factions) <*> rowGs
+    tTable :: Sh GameState String
+    tTable = do
+      factions <- map (view faction') <$> use combatFactions'
+      st <- get
+      let
+        time = st ^. gTimer
+        protoRows = groupBy ((==) `on` fst) $ st ^. timers
+        faction id = fromJust $ view eFaction <$> Map.lookup id (st ^. gEntities)
+
+        rowGs :: Sh GameState [RowGroup]
+        rowGs = runListT $ do
+          rowGroup'@((t, _):_) <- ListT $ return protoRows
+          let
+            rowGroup = map snd rowGroup'
+            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 . ([show . round $ t ^. absTime - fromIntegral time] :) <$> mapM factionColumn [0..(length factions - 1)]
+      tableString <$> pure (repeat def) <*> pure unicodeBoldHeaderS <*> pure (titlesH $ ("Time left") : factions) <*> rowGs
 
 focusNotes :: GameState -> String
 focusNotes st
@@ -191,24 +222,52 @@ stateMaintenance = do
     gFocus' . eSeqVal .= Nothing
     -- gFocus .= Nothing
   void $ do
+    newCount <- fromIntegral . length <$> use priorityQueue
+    lastCount <- fromIntegral <$> use gLastCount
+    time <- use gTimer
+    when (newCount /= lastCount) $ do
+      let
+        scale :: Entity -> Sh GameState Entity
+        scale entity = (execStateT ?? entity) $ do
+          eTimer . _Just %= scaleTimer time (newCount % (max 1 lastCount))
+      gEntities <~ (mapM scale =<< use gEntities)
+  gLastCount <~ length <$> use priorityQueue
+  void $ do
     round <- use gRound
     let
       finished sVal = fromMaybe False (previews (seqVal . _Just) (<= 0) sVal) || view (seqRound . _Wrapped) sVal /= round
-    allFinished <- getAll . foldMapOf (gEntities . each . eStats . sSequence . _Just) (All . finished) <$> get
+    allFinished <- getAll . foldMapOf (gEntities . each . eSeqVal . _Just) (All . finished) <$> get
     when allFinished $ do
       let
         advanceRound' :: EntityIdentifier -> Entity -> Sh GameState Entity
         advanceRound' ident entity = fmap (fromMaybe entity . (\(m, s) -> s <$ m)) . (runStateT ?? entity) . runMaybeT $ do
-          cRound <- MaybeT . preuse $ eStats . sSequence . _Just . seqRound . _Wrapped
+          cRound <- MaybeT . preuse $ eSeqVal . _Just . seqRound . _Wrapped
           guard $ cRound < 0
-          cVal <- MaybeT . preuse $ eStats . sSequence . _Just . seqVal . _Just
+          cVal <- MaybeT . preuse $ eSeqVal . _Just . seqVal . _Just
           name <- lift . lift $ toName ident
-          nVal' <- MaybeT . preuse $ eStats . sSeqVal
-          nVal <- MaybeT . focusState eStats $ evalFormula' [name] nVal'
-          eStats . sSequence . _Just . seqVal . _Just += nVal
-          eStats . sSequence . _Just . seqRound . _Wrapped += 1
+          (newEntity, nVal) <- lift . lift $ rollSeqVal entity name
+          put $ set eSeqVal nVal newEntity 
+          when (cVal < 0) $ -- Carry over negative values from previous rounds
+            eSeqVal . _Just . seqVal . _Just += cVal
+          eSeqVal . _Just . seqRound . _Wrapped += 1
+        advanceTimer :: Entity -> Sh GameState Entity
+        advanceTimer entity = (execStateT ?? entity) $ do
+          rTime <- lift $ use gTimer
+          eTimer . _Just . absTime -= fromIntegral rTime
       gRounds -= 1
-      gEntities <~ (imapM advanceRound' =<< use gEntities)
+      gEntities <~ (mapM advanceTimer =<< imapM advanceRound' =<< use gEntities)
+      gTimer .= 0
+
+rollSeqVal :: Entity -> String -> Sh GameState (Entity, Maybe SeqVal)
+rollSeqVal entity name = do
+  let sVal = fromMaybe (val ignored ["Sequenzwert"] False) $ preview (eStats . sSeqVal) entity
+  (newEntity, sNum) <- evalFormula [name] entity sVal
+  round <- use gRound
+  let val = Just $ def
+            & set (seqRound . _Wrapped) round
+            & set seqVal (Just sNum)
+            & set seqEpsilon (entity ^. eStats . sSeqEpsilon)
+  return (newEntity, val)
 
 -- Query state
 listFactions, listEntities :: Sh GameState ()
@@ -220,18 +279,39 @@ focusTip, blur, pFocusTip :: Sh GameState ()
 focusTip = gFocus <~ preuse tip
 blur     = gFocus .= Nothing
 pFocusTip = do
+  nextTimer <- preuse $ timers . folding listToMaybe
+  time <- fromIntegral <$> use gTimer
   round <- use gRound
   let
     eWeight :: Maybe SeqVal -> Int
     eWeight sVal
       | preview (_Just . seqRound . _Wrapped) sVal == Just round
-      , (preview (_Just . seqVal . _Just) -> Just n) <- sVal = n
+      , (preview (_Just . seqVal . _Just) -> Just n) <- sVal = max 0 n
       | otherwise = 0
   entities <- map (over _2 . view $ eSeqVal . to eWeight) . Map.toList <$> use gEntities
-  case entities of
-    [] -> gFocus .= Nothing
-    _  -> gFocus <~ Just <$> liftIO (enact $ makeEventProb entities)
-
+  case nextTimer of
+    nextTimer
+      | Just timer <- nextTimer
+      , fst $ over _1 (\t -> t ^. absTime <= time) timer
+                      -> gFocus .= Just (snd timer)
+      | null entities -> gFocus .= Nothing
+      | otherwise     -> gFocus <~ Just <$> liftIO (enact $ makeEventProb entities)
+
+entityTimer, pEntityTimer :: Completable TimerLength -> Sh GameState ()
+entityTimer = entityTimer' Constant
+pEntityTimer = entityTimer' Scaled
+entityTimer' toTimer = withArg $ \(TimerLength origin n) -> do
+  time <- use gTimer
+  entities <- length <$> use priorityQueue
+  let
+    timer = case origin of
+      Absolute -> n
+      Now -> time + n
+  gFocus' . eTimer .= Just (scaleTimer time (max 1 $ fromIntegral entities) . toTimer $ fromIntegral timer)
+
+clearEntityTimer :: Sh GameState ()
+clearEntityTimer = gFocus' . eTimer .= Nothing
+  
 -- Manual focus
 setFocus :: Completable EntityIdentifier -> Sh GameState ()
 setFocus = withArg $ \ident -> gFocus ?= ident
@@ -346,21 +426,18 @@ clearFactionSeqVal = withArg $ \qFaction -> use gEntities >>= mapM_ (clearEntity
 entitySeqVal', clearEntitySeqVal' :: EntityIdentifier -> Sh GameState ()
 entitySeqVal' ident = void . runMaybeT $ do
   entity <- MaybeT $ preuse (gEntities . ix ident)
-  let sVal = fromMaybe (val ignored ["Sequenzwert"] False) $ preview (eStats . sSeqVal) entity
   name <- toName ident
-  round <- use gRound
-  (newEntity, sNum) <- evalFormula [name] entity sVal
-  let val = Just $ def
-            & set (seqRound . _Wrapped) round
-            & set seqVal (Just sNum)
-            & set seqEpsilon (entity ^. eStats . sSeqEpsilon)
+  (newEntity, val) <- lift $ rollSeqVal entity name
   gEntities . at ident .= Just (newEntity & set eSeqVal val)
-  gLog <>= pure (ident, "Sequence: " ++ show sNum)
+  gLog <>= pure (ident, "Sequence: " ++ show (fromJust $ view seqVal =<< val))
 clearEntitySeqVal' ident = gEntities . ix ident . eSeqVal .= Nothing
 
 spendSeq :: Int -> String -> Sh GameState ()
 spendSeq n logStr = withFocus $ \focusId -> do
-  gEntities . ix focusId . eStats . sSequence . _Just . seqVal . _Just -= n
+  gFocus' . eSeqVal . _Just . seqVal . _Just -= n
+  hasSeq <- isJust <$> preuse (gFocus' . eSeqVal . _Just . seqVal . _Just)
+  when hasSeq $
+    gTimer += n
   gLog <>= pure (focusId, logStr)
 
 delay :: Sh GameState ()
@@ -478,4 +555,5 @@ printVal = withArg $ \formula -> withFocus $ \focusId -> do
           (fromRational prob :: Double)
           barLength (replicate (round $ fromInteger barLength * normalize prob) '#')
         lengths = map (length . show . fst) vals
-        normalize p = p / maximum (map snd vals)
+        -- normalize p = p / maximum (map snd vals)
+        normalize = id
diff --git a/src/Sequence/Contact/Archetypes.hs b/src/Sequence/Contact/Archetypes.hs
index 1973b97..f8d4c9d 100644
--- a/src/Sequence/Contact/Archetypes.hs
+++ b/src/Sequence/Contact/Archetypes.hs
@@ -119,6 +119,7 @@ prop = Prop
        , _sFatigueShock = def
 
        , _sSequence = Nothing
+       , _sTimer = Nothing
 
        , _sExtraSkills = []
        , _sModifiers = []
@@ -230,6 +231,7 @@ human = Humanoid
         , _sFatigue = 0
 
         , _sSequence = Nothing
+        , _sTimer = Nothing
 
         , _sPainShock = def
                         & set seReBar (vitBar 0.75)
@@ -351,6 +353,7 @@ dog = Quadruped
       , _sFatigue = 0
 
       , _sSequence = Nothing
+      , _sTimer = Nothing
 
       , _sPainShock = def
       , _sFatigueShock = def
@@ -440,6 +443,7 @@ dolphin = Dolphin
           , _sFatigue = 0
 
           , _sSequence = Nothing
+          , _sTimer = Nothing
 
           , _sPainShock = def
           , _sFatigueShock = def
diff --git a/src/Sequence/Contact/Types.hs b/src/Sequence/Contact/Types.hs
index 5f8808d..c69a698 100644
--- a/src/Sequence/Contact/Types.hs
+++ b/src/Sequence/Contact/Types.hs
@@ -123,6 +123,20 @@ instance Default SeqVal where
                }
 
 makeLenses ''ShockEffect
+
+absTime :: Lens' Timer Rational
+absTime = lens get set
+  where
+    get (Constant n) = n
+    get (Scaled n) = n
+    set (Constant _) n = Constant n
+    set (Scaled _) n = Scaled n
+
+instance Eq Timer where
+  (==) = (==) `on` view absTime
+
+instance Ord Timer where
+  compare = comparing $ view absTime
   
 instance Default ShockEffect where
   def = ShockEffect { _seApplied = False
@@ -148,6 +162,7 @@ instance Default Stats where
         , _sFatigue = 0
 
         , _sSequence = Nothing
+        , _sTimer = Nothing
         
         , _sPainShock = def
         , _sFatigueShock = def
diff --git a/src/Sequence/Contact/Types/Internal.hs b/src/Sequence/Contact/Types/Internal.hs
index 7938a06..11116e9 100644
--- a/src/Sequence/Contact/Types/Internal.hs
+++ b/src/Sequence/Contact/Types/Internal.hs
@@ -83,6 +83,10 @@ data SeqVal = SeqVal
               }
   deriving (Show, Eq, Ord)
 
+data Timer = Scaled Rational
+           | Constant Rational
+  deriving (Show)
+
 data ShockEffect = ShockEffect
                    { _seApplied :: Bool
                    , _seVal
@@ -107,6 +111,7 @@ data Stats = Prop
              , _sFatigueShock :: ShockEffect
 
              , _sSequence :: Maybe SeqVal
+             , _sTimer :: Maybe Timer
 
              , _sExtraSkills :: Map (CI String) (FormulaM Stats Test)
              , _sModifiers :: Set Modifier
@@ -171,6 +176,7 @@ data Stats = Prop
              , _sFatigue :: Int
 
              , _sSequence :: Maybe SeqVal
+             , _sTimer :: Maybe Timer
 
              , _sPainShock :: ShockEffect
              , _sFatigueShock :: ShockEffect
@@ -213,6 +219,7 @@ data Stats = Prop
              , _sFatigue :: Int
 
              , _sSequence :: Maybe SeqVal
+             , _sTimer :: Maybe Timer
 
              , _sPainShock :: ShockEffect
              , _sFatigueShock :: ShockEffect
@@ -255,6 +262,7 @@ data Stats = Prop
              , _sFatigue :: Int
 
              , _sSequence :: Maybe SeqVal
+             , _sTimer :: Maybe Timer
 
              , _sPainShock :: ShockEffect
              , _sFatigueShock :: ShockEffect
diff --git a/src/Sequence/Types.hs b/src/Sequence/Types.hs
index b5f6b4b..f2c08ac 100644
--- a/src/Sequence/Types.hs
+++ b/src/Sequence/Types.hs
@@ -1,12 +1,12 @@
-{-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, TypeSynonymInstances, ViewPatterns, OverloadedStrings, TemplateHaskell, GeneralizedNewtypeDeriving, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, TypeSynonymInstances, ViewPatterns, OverloadedStrings, TemplateHaskell, GeneralizedNewtypeDeriving, TypeOperators, UndecidableInstances, RankNTypes #-}
 
 module Sequence.Types
-  ( GameState, gEntities, gEntityNames, gFocus, gNextId', gLog
+  ( GameState, gEntities, gEntityNames, gFocus, gNextId', gLog, gTimer, gLastCount
   , Faction, faction, faction'
   , Entity(..), eFaction, eSeqVal, eStats, eNotes
   , EntityName(..), entityName
   , EntityIdentifier(..), entityId, entityId'
-  , inhabitedFactions, priorityQueue, tip, insertEntity, gFocus', gRounds, gRounds', gRound
+  , inhabitedFactions, combatFactions, combatFactions', priorityQueue, timers, tip, insertEntity, gFocus', gRounds, gRounds', gRound, eTimer
   ) where
 
 import Control.Lens
@@ -81,6 +81,9 @@ instance Default Entity where
 eSeqVal :: Lens' Entity (Maybe SeqVal)
 eSeqVal = eStats . sSequence
 
+eTimer :: Lens' Entity (Maybe Timer)
+eTimer = eStats . sTimer
+
 instance Stats :<: Entity where
   ctx' = eStats
 
@@ -102,24 +105,36 @@ entityId' = _Show . entityId
 
 data GameState = GameState
                  { _gEntities    :: Map EntityIdentifier Entity
+                 , _gLastCount   :: Int
                  , _gEntityNames :: Bimap EntityIdentifier EntityName
                  , _gFocus       :: Maybe EntityIdentifier
                  , _gNextId      :: EntityIdentifier
                  , _gLog         :: Seq (EntityIdentifier, String)
+                 , _gTimer       :: Int
                  }
 makeLenses ''GameState
 
 instance Default GameState where
   def = GameState
         { _gEntities = def
+        , _gLastCount = 0
         , _gEntityNames = Bimap.empty
         , _gFocus = Nothing
         , _gNextId = toEnum 0
         , _gLog = Seq.empty
+        , _gTimer = 0
         }
 
-inhabitedFactions :: Getter GameState [Faction]
-inhabitedFactions = to $ nub . sort . Map.elems . fmap (view eFaction) . view gEntities
+inhabitedFactions, combatFactions, combatFactions' :: Getter GameState [Faction]
+inhabitedFactions = factionList $ \_ _ -> True
+combatFactions = factionList $ \f st -> let
+  cFactions = map (view eFaction . fromJust . flip Map.lookup (st ^. gEntities) . snd) $ st ^. priorityQueue
+  in f `elem` cFactions
+combatFactions' = factionList $ \f st -> let
+  cFactions = map (view eFaction . fromJust . flip Map.lookup (st ^. gEntities) . snd) $ st ^. timers
+  in f `elem` cFactions
+factionList :: (Faction -> GameState -> Bool) -> Getter GameState [Faction]
+factionList pred = to $ \st -> filter (flip pred st) . nub . sort . Map.elems . fmap (view eFaction) . view gEntities $ st
 
 priorityQueue :: Getter GameState [(SeqVal, EntityIdentifier)]
 priorityQueue = to priorityQueue'
@@ -128,8 +143,23 @@ priorityQueue = to priorityQueue'
     filter (Nothing, _) = mempty
     filter (Just val, id) = pure (val, id)
 
+timers :: Getter GameState [(Timer, EntityIdentifier)]
+timers = to timers'
+  where
+    timers' state = sortBy (comparing fst) . concat . map filter . map (over _1 $ view eTimer) . map swap $ entities
+      where
+        entities = Map.toAscList $ view gEntities state
+        time = fromIntegral $ view gTimer state
+        filter (Nothing, _) = mempty
+        filter (Just v, id) = pure (v, id)
+
 tip :: Fold GameState EntityIdentifier
-tip = priorityQueue . folding (fmap snd . listToMaybe)
+tip = folding $ runReaderT tip'
+  where
+    tip' :: ReaderT GameState First EntityIdentifier
+    tip' = do
+      join . fmap (lift . First) . preview $ timers . folding (fmap snd . listToMaybe)
+      join . fmap (lift . First) . preview $ priorityQueue . folding (fmap snd . listToMaybe)
 
 gFocus' :: Traversal' GameState Entity
 gFocus' modifyFocus st = (flip runReader st) . (maybe (asks pure) return =<<) . runMaybeT $ do
@@ -158,7 +188,7 @@ insertEntity entity = execState $ do
   gNextId %= succ
 
 gRounds :: Traversal' GameState Int
-gRounds = gEntities . each . eStats . sSequence . _Just . seqRound . _Wrapped
+gRounds = gEntities . each . eSeqVal . _Just . seqRound . _Wrapped
 
 gRounds' :: Getter GameState [Int]
 gRounds' = to $ nub . sort . toListOf gRounds
diff --git a/src/Sequence/Utils.hs b/src/Sequence/Utils.hs
index fbf3c7d..bb29b86 100644
--- a/src/Sequence/Utils.hs
+++ b/src/Sequence/Utils.hs
@@ -1,10 +1,12 @@
 {-# LANGUAGE ViewPatterns, FlexibleContexts, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, UndecidableInstances, OverloadedStrings, OverloadedLists, RankNTypes #-}
 
 module Sequence.Utils
-  ( withArg, withFocus, withFocus'
+  ( TimerLength(..), TimerOrigin(..)
+  , withArg, withFocus, withFocus'
   , focusState
   , toName, toDesc
   , outputLogged
+  , scaleTimer
   , Argument(..)
   , Completion(..)
   , module Sequence.Utils.Ask
@@ -50,6 +52,10 @@ import Sequence.Formula
 
 import Text.Regex (mkRegex, subRegex)
 
+data TimerLength = TimerLength TimerOrigin Int
+
+data TimerOrigin = Absolute | Now
+
 class Argument a st | a -> st where
   arg :: String -> Sh st (Maybe a)
 
@@ -93,6 +99,23 @@ outputLogged id str = gLog <>= pure (id, clean str) >> shellPutStrLn str
   where
     clean str = subRegex (mkRegex "(\x9B|\x1B\\[)[0-?]*[ -/]*[@-~]") str "" -- remove ANSI escapes
 
+scaleTimer :: Int -> Rational -> Timer -> Timer
+scaleTimer _ _ t@(Constant _) = t
+scaleTimer (fromIntegral -> now) factor (Scaled r) = Scaled $ ((max 0 $ r - now) * factor) + now
+
+instance Completion TimerLength GameState where
+  completableLabel _ = "<timer offset>"
+  complete _ st prefix = return []
+
+instance Argument TimerLength GameState where
+  arg str
+    | ('+':cs) <- str
+    , (Just n) <- readMaybe cs
+    , n >= 0 = return . Just $ TimerLength Now n
+    | (Just n) <- readMaybe str
+    , n >= 0 = return . Just $ TimerLength Absolute n
+    | otherwise = return Nothing
+
 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