Timers for use with probabilistic focus and without

5 files changed, 88 insertions, 8 deletions

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