From ec57713b3d4acea066c30cf4285339303860df01 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sat, 12 Nov 2016 22:25:47 +0100 Subject: Timers for use with probabilistic focus and without --- src/Sequence/Contact/Archetypes.hs | 4 ++++ src/Sequence/Contact/Types.hs | 15 ++++++++++++ src/Sequence/Contact/Types/Internal.hs | 8 +++++++ src/Sequence/Types.hs | 44 ++++++++++++++++++++++++++++------ src/Sequence/Utils.hs | 25 ++++++++++++++++++- 5 files changed, 88 insertions(+), 8 deletions(-) (limited to 'src/Sequence') 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 _ = "" + 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 _ = "" complete _ st prefix = return . filter ((isPrefixOf `on` CI.foldCase) prefix) . map ((evalState ?? st) . toName) . Map.keys $ st ^. gEntities -- cgit v1.2.3