Timers for use with probabilistic focus and without

1 files changed, 106 insertions, 28 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