From ec57713b3d4acea066c30cf4285339303860df01 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <pngwjpgh@users.noreply.github.com>
Date: Sat, 12 Nov 2016 22:25:47 +0100
Subject: Timers for use with probabilistic focus and without
---
src/Main.hs | 134 ++++++++++++++++++++++++++-------
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 +++++-
6 files changed, 194 insertions(+), 36 deletions(-)
(limited to 'src')
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
@@ -190,25 +221,53 @@ stateMaintenance = do
(_, _, True) -> lift . shellPutStrLn $ name ++ " is destroyed"
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
--
cgit v1.2.3