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/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 _ = "" + 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