mirror of
https://github.com/swarm-game/swarm.git
synced 2024-09-19 03:19:53 +03:00
Add TimeEffect effect for getting current time (#1620)
fixes #1502 Add TimeEffect effect for getting current time.
This commit is contained in:
parent
8f52e53a22
commit
a306d05f61
6
src/Swarm/Effect.hs
Normal file
6
src/Swarm/Effect.hs
Normal file
@ -0,0 +1,6 @@
|
||||
module Swarm.Effect (
|
||||
module X,
|
||||
)
|
||||
where
|
||||
|
||||
import Swarm.Effect.Time as X
|
27
src/Swarm/Effect/Time.hs
Normal file
27
src/Swarm/Effect/Time.hs
Normal file
@ -0,0 +1,27 @@
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module Swarm.Effect.Time where
|
||||
|
||||
import Control.Algebra
|
||||
import Control.Monad.Trans (MonadIO (liftIO))
|
||||
import Data.Kind (Type)
|
||||
import System.Clock (Clock (Monotonic), TimeSpec, getTime)
|
||||
|
||||
-- | Effect for things related to time
|
||||
data Time (m :: Type -> Type) k where
|
||||
GetNow :: Time m TimeSpec
|
||||
|
||||
getNow :: Has Time sig m => m TimeSpec
|
||||
getNow = send GetNow
|
||||
|
||||
newtype TimeIOC m a = TimeIOC {runTimeIO :: m a}
|
||||
deriving newtype (Applicative, Functor, Monad, MonadIO)
|
||||
|
||||
instance (MonadIO m, Algebra sig m) => Algebra (Time :+: sig) (TimeIOC m) where
|
||||
alg hdl sig ctx = case sig of
|
||||
L GetNow -> (<$ ctx) <$> liftIO (System.Clock.getTime System.Clock.Monotonic)
|
||||
R other -> TimeIOC (alg (runTimeIO . hdl) other ctx)
|
@ -59,6 +59,7 @@ import Data.Time (getZonedTime)
|
||||
import Data.Tuple (swap)
|
||||
import Linear (V2 (..), perp, zero)
|
||||
import Prettyprinter (pretty)
|
||||
import Swarm.Effect as Effect (Time, getNow)
|
||||
import Swarm.Game.Achievement.Attainment
|
||||
import Swarm.Game.Achievement.Definitions
|
||||
import Swarm.Game.CESK
|
||||
@ -116,7 +117,7 @@ import Prelude hiding (Applicative (..), lookup)
|
||||
--
|
||||
-- Note that the game may be in 'RobotStep' mode and not finish
|
||||
-- the tick. Use the return value to check whether a full tick happened.
|
||||
gameTick :: (Has (State GameState) sig m, Has (Lift IO) sig m) => m Bool
|
||||
gameTick :: (Has (State GameState) sig m, Has (Lift IO) sig m, Has Effect.Time sig m) => m Bool
|
||||
gameTick = do
|
||||
wakeUpRobotsDoneSleeping
|
||||
active <- use activeRobots
|
||||
@ -164,7 +165,7 @@ gameTick = do
|
||||
-- | Finish a game tick in progress and set the game to 'WorldTick' mode afterwards.
|
||||
--
|
||||
-- Use this function if you need to unpause the game.
|
||||
finishGameTick :: (Has (State GameState) sig m, Has (Lift IO) sig m) => m ()
|
||||
finishGameTick :: (Has (State GameState) sig m, Has (Lift IO) sig m, Has Effect.Time sig m) => m ()
|
||||
finishGameTick =
|
||||
use (temporal . gameStep) >>= \case
|
||||
WorldTick -> pure ()
|
||||
@ -189,7 +190,7 @@ insertBackRobot rn rob = do
|
||||
unless (isActive rob) (sleepForever rn)
|
||||
|
||||
-- Run a set of robots - this is used to run robots before/after the focused one.
|
||||
runRobotIDs :: (Has (State GameState) sig m, Has (Lift IO) sig m) => IS.IntSet -> m ()
|
||||
runRobotIDs :: (Has (State GameState) sig m, Has (Lift IO) sig m, Has Effect.Time sig m) => IS.IntSet -> m ()
|
||||
runRobotIDs robotNames = forM_ (IS.toList robotNames) $ \rn -> do
|
||||
mr <- uses robotMap (IM.lookup rn)
|
||||
forM_ mr (stepOneRobot rn)
|
||||
@ -197,7 +198,7 @@ runRobotIDs robotNames = forM_ (IS.toList robotNames) $ \rn -> do
|
||||
stepOneRobot rn rob = tickRobot rob >>= insertBackRobot rn
|
||||
|
||||
-- This is a helper function to do one robot step or run robots before/after.
|
||||
singleStep :: (Has (State GameState) sig m, Has (Lift IO) sig m) => SingleStep -> RID -> IS.IntSet -> m Bool
|
||||
singleStep :: (Has (State GameState) sig m, Has (Lift IO) sig m, Has Effect.Time sig m) => SingleStep -> RID -> IS.IntSet -> m Bool
|
||||
singleStep ss focRID robotSet = do
|
||||
let (preFoc, focusedActive, postFoc) = IS.splitMember focRID robotSet
|
||||
case ss of
|
||||
@ -291,7 +292,7 @@ data CompletionsWithExceptions = CompletionsWithExceptions
|
||||
-- 3) The iteration needs to be a "fold", so that state is updated
|
||||
-- after each element.
|
||||
hypotheticalWinCheck ::
|
||||
(Has (State GameState) sig m, Has (Lift IO) sig m) =>
|
||||
(Has (State GameState) sig m, Has Effect.Time sig m, Has (Lift IO) sig m) =>
|
||||
EntityMap ->
|
||||
GameState ->
|
||||
WinStatus ->
|
||||
@ -381,7 +382,11 @@ hypotheticalWinCheck em g ws oc = do
|
||||
h = hypotheticalRobot (Out VUnit emptyStore []) 0
|
||||
|
||||
evalPT ::
|
||||
(Has (Lift IO) sig m, Has (Throw Exn) sig m, Has (State GameState) sig m) =>
|
||||
( Has Effect.Time sig m
|
||||
, Has (Throw Exn) sig m
|
||||
, Has (State GameState) sig m
|
||||
, Has (Lift IO) sig m
|
||||
) =>
|
||||
ProcessedTerm ->
|
||||
m Value
|
||||
evalPT t = evaluateCESK (initMachine t empty emptyStore)
|
||||
@ -407,7 +412,11 @@ hypotheticalRobot c =
|
||||
mempty
|
||||
|
||||
evaluateCESK ::
|
||||
(Has (Lift IO) sig m, Has (Throw Exn) sig m, Has (State GameState) sig m) =>
|
||||
( Has Effect.Time sig m
|
||||
, Has (Throw Exn) sig m
|
||||
, Has (State GameState) sig m
|
||||
, Has (Lift IO) sig m
|
||||
) =>
|
||||
CESK ->
|
||||
m Value
|
||||
evaluateCESK cesk = do
|
||||
@ -417,7 +426,8 @@ evaluateCESK cesk = do
|
||||
evalState r . runCESK $ cesk
|
||||
|
||||
runCESK ::
|
||||
( Has (Lift IO) sig m
|
||||
( Has Effect.Time sig m
|
||||
, Has (Lift IO) sig m
|
||||
, Has (Throw Exn) sig m
|
||||
, Has (State GameState) sig m
|
||||
, Has (State Robot) sig m
|
||||
@ -520,7 +530,7 @@ withExceptions s k m = do
|
||||
-- | Run a robot for one tick, which may consist of up to
|
||||
-- 'robotStepsPerTick' CESK machine steps and at most one tangible
|
||||
-- command execution, whichever comes first.
|
||||
tickRobot :: (Has (State GameState) sig m, Has (Lift IO) sig m) => Robot -> m Robot
|
||||
tickRobot :: (Has (State GameState) sig m, Has (Lift IO) sig m, Has Effect.Time sig m) => Robot -> m Robot
|
||||
tickRobot r = do
|
||||
steps <- use $ temporal . robotStepsPerTick
|
||||
tickRobotRec (r & activityCounts . tickStepBudget .~ steps)
|
||||
@ -529,7 +539,7 @@ tickRobot r = do
|
||||
-- robot is actively running and still has steps left, and if so
|
||||
-- runs it for one step, then calls itself recursively to continue
|
||||
-- stepping the robot.
|
||||
tickRobotRec :: (Has (State GameState) sig m, Has (Lift IO) sig m) => Robot -> m Robot
|
||||
tickRobotRec :: (Has (State GameState) sig m, Has (Lift IO) sig m, Has Effect.Time sig m) => Robot -> m Robot
|
||||
tickRobotRec r = do
|
||||
time <- use $ temporal . ticks
|
||||
case wantsToStep time r && (r ^. runningAtomic || r ^. activityCounts . tickStepBudget > 0) of
|
||||
@ -538,7 +548,7 @@ tickRobotRec r = do
|
||||
|
||||
-- | Single-step a robot by decrementing its 'tickStepBudget' counter and
|
||||
-- running its CESK machine for one step.
|
||||
stepRobot :: (Has (State GameState) sig m, Has (Lift IO) sig m) => Robot -> m Robot
|
||||
stepRobot :: (Has (State GameState) sig m, Has (Lift IO) sig m, Has Effect.Time sig m) => Robot -> m Robot
|
||||
stepRobot r = do
|
||||
(r', cesk') <- runState (r & activityCounts . tickStepBudget -~ 1) (stepCESK (r ^. machine))
|
||||
-- sendIO $ appendFile "out.txt" (prettyString cesk' ++ "\n")
|
||||
@ -589,7 +599,7 @@ data SKpair = SKpair Store Cont
|
||||
--
|
||||
-- Compare to "withExceptions".
|
||||
processImmediateFrame ::
|
||||
(Has (State GameState) sig m, Has (State Robot) sig m, Has (Lift IO) sig m) =>
|
||||
(Has (State GameState) sig m, Has (State Robot) sig m, Has (Lift IO) sig m, Has Effect.Time sig m) =>
|
||||
Value ->
|
||||
SKpair ->
|
||||
-- | the unreliable computation
|
||||
@ -614,7 +624,7 @@ updateWorldAndRobots cmd wf rf = do
|
||||
|
||||
-- | The main CESK machine workhorse. Given a robot, look at its CESK
|
||||
-- machine state and figure out a single next step.
|
||||
stepCESK :: (Has (State GameState) sig m, Has (State Robot) sig m, Has (Lift IO) sig m) => CESK -> m CESK
|
||||
stepCESK :: (Has (State GameState) sig m, Has (State Robot) sig m, Has (Lift IO) sig m, Has Effect.Time sig m) => CESK -> m CESK
|
||||
stepCESK cesk = case cesk of
|
||||
------------------------------------------------------------
|
||||
-- Evaluation
|
||||
@ -963,7 +973,7 @@ stepCESK cesk = case cesk of
|
||||
-- | Eexecute a constant, catching any exception thrown and returning
|
||||
-- it via a CESK machine state.
|
||||
evalConst ::
|
||||
(Has (State GameState) sig m, Has (State Robot) sig m, Has (Lift IO) sig m) => Const -> [Value] -> Store -> Cont -> m CESK
|
||||
(Has (State GameState) sig m, Has (State Robot) sig m, Has Effect.Time sig m, Has (Lift IO) sig m) => Const -> [Value] -> Store -> Cont -> m CESK
|
||||
evalConst c vs s k = do
|
||||
res <- runError $ execConst c vs s k
|
||||
case res of
|
||||
@ -1021,7 +1031,7 @@ addSeedBot e (minT, maxT) loc ts =
|
||||
-- | Interpret the execution (or evaluation) of a constant application
|
||||
-- to some values.
|
||||
execConst ::
|
||||
(HasRobotStepState sig m, Has (Lift IO) sig m) =>
|
||||
(HasRobotStepState sig m, Has Effect.Time sig m, Has (Lift IO) sig m) =>
|
||||
Const ->
|
||||
[Value] ->
|
||||
Store ->
|
||||
@ -2550,7 +2560,7 @@ execConst c vs s k = do
|
||||
|
||||
-- The code for grab and harvest is almost identical, hence factored
|
||||
-- out here.
|
||||
doGrab :: (HasRobotStepState sig m, Has (Lift IO) sig m) => GrabbingCmd -> m Entity
|
||||
doGrab :: (HasRobotStepState sig m, Has Effect.Time sig m) => GrabbingCmd -> m Entity
|
||||
doGrab cmd = do
|
||||
let verb = verbGrabbingCmd cmd
|
||||
verbed = verbedGrabbingCmd cmd
|
||||
|
@ -19,11 +19,11 @@ module Swarm.Game.Step.Combustion where
|
||||
import Control.Applicative (Applicative (..))
|
||||
import Control.Carrier.State.Lazy
|
||||
import Control.Effect.Lens
|
||||
import Control.Effect.Lift
|
||||
import Control.Lens as Lens hiding (Const, distrib, from, parts, use, uses, view, (%=), (+=), (.=), (<+=), (<>=))
|
||||
import Control.Monad (forM_, void, when)
|
||||
import Data.Text qualified as T
|
||||
import Linear (zero)
|
||||
import Swarm.Effect as Effect (Time, getNow)
|
||||
import Swarm.Game.CESK (emptyStore, initMachine)
|
||||
import Swarm.Game.Display
|
||||
import Swarm.Game.Entity hiding (empty, lookup, singleton, union)
|
||||
@ -44,7 +44,7 @@ import Swarm.Util hiding (both)
|
||||
import System.Clock (TimeSpec)
|
||||
import Prelude hiding (Applicative (..), lookup)
|
||||
|
||||
igniteCommand :: (HasRobotStepState sig m, Has (Lift IO) sig m) => Const -> Direction -> m ()
|
||||
igniteCommand :: (HasRobotStepState sig m, Has Effect.Time sig m) => Const -> Direction -> m ()
|
||||
igniteCommand c d = do
|
||||
(loc, me) <- lookInDirection d
|
||||
-- Ensure there is an entity here.
|
||||
|
@ -13,7 +13,6 @@ import Control.Applicative (Applicative (..))
|
||||
import Control.Carrier.State.Lazy
|
||||
import Control.Effect.Error
|
||||
import Control.Effect.Lens
|
||||
import Control.Effect.Lift
|
||||
import Control.Monad (forM_, guard, when)
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)
|
||||
@ -41,8 +40,6 @@ import Swarm.Language.Capability
|
||||
import Swarm.Language.Requirement qualified as R
|
||||
import Swarm.Language.Syntax
|
||||
import Swarm.Util hiding (both)
|
||||
import System.Clock (TimeSpec)
|
||||
import System.Clock qualified
|
||||
import System.Random (UniformRange, uniformR)
|
||||
import Prelude hiding (Applicative (..), lookup)
|
||||
|
||||
@ -115,9 +112,6 @@ cmdExn c parts = CmdFailed c (T.unwords parts) Nothing
|
||||
|
||||
-- * Some utility functions
|
||||
|
||||
getNow :: Has (Lift IO) sig m => m TimeSpec
|
||||
getNow = sendIO $ System.Clock.getTime System.Clock.Monotonic
|
||||
|
||||
-- | Set a flag telling the UI that the world needs to be redrawn.
|
||||
flagRedraw :: (Has (State GameState) sig m) => m ()
|
||||
flagRedraw = needsRedraw .= True
|
||||
|
@ -70,6 +70,7 @@ import Data.Time (getZonedTime)
|
||||
import Data.Vector qualified as V
|
||||
import Graphics.Vty qualified as V
|
||||
import Linear
|
||||
import Swarm.Effect (TimeIOC (..))
|
||||
import Swarm.Game.Achievement.Definitions
|
||||
import Swarm.Game.Achievement.Persistence
|
||||
import Swarm.Game.CESK (CESK (Out), Frame (FApp, FExec), cancel, emptyStore, initMachine)
|
||||
@ -751,10 +752,10 @@ runGameTickUI :: EventM Name AppState ()
|
||||
runGameTickUI = runGameTick >> void updateUI
|
||||
|
||||
-- | Modifies the game state using a fused-effect state action.
|
||||
zoomGameState :: (MonadState AppState m, MonadIO m) => Fused.StateC GameState (Fused.LiftC IO) a -> m a
|
||||
zoomGameState :: (MonadState AppState m, MonadIO m) => Fused.StateC GameState (TimeIOC (Fused.LiftC IO)) a -> m a
|
||||
zoomGameState f = do
|
||||
gs <- use gameState
|
||||
(gs', a) <- liftIO (Fused.runM (Fused.runState gs f))
|
||||
(gs', a) <- liftIO (Fused.runM (runTimeIO (Fused.runState gs f)))
|
||||
gameState .= gs'
|
||||
return a
|
||||
|
||||
|
@ -4,6 +4,7 @@
|
||||
-- fused-effect utilities for Swarm.
|
||||
module Swarm.Util.Effect where
|
||||
|
||||
import Control.Algebra
|
||||
import Control.Carrier.Accum.FixedStrict
|
||||
import Control.Carrier.Error.Either (ErrorC (..))
|
||||
import Control.Carrier.Throw.Either (ThrowC (..), runThrow)
|
||||
|
@ -125,6 +125,8 @@ library
|
||||
Swarm.Game.Scenario
|
||||
Swarm.Game.Scenario.Topography.Cell
|
||||
Swarm.Game.Universe
|
||||
Swarm.Effect
|
||||
Swarm.Effect.Time
|
||||
Swarm.Log
|
||||
Swarm.TUI.Launch.Controller
|
||||
Swarm.TUI.Launch.Model
|
||||
|
@ -10,6 +10,7 @@ import Control.Monad (replicateM_)
|
||||
import Control.Monad.Except (runExceptT)
|
||||
import Control.Monad.State (evalStateT, execStateT)
|
||||
import Data.Map qualified as M
|
||||
import Swarm.Effect (runTimeIO)
|
||||
import Swarm.Game.CESK (emptyStore, initMachine)
|
||||
import Swarm.Game.Display (defaultRobotDisplay)
|
||||
import Swarm.Game.Location
|
||||
@ -127,7 +128,7 @@ mkGameState robotMaker numRobots = do
|
||||
|
||||
-- | Runs numGameTicks ticks of the game.
|
||||
runGame :: Int -> GameState -> IO ()
|
||||
runGame numGameTicks = evalStateT (replicateM_ numGameTicks gameTick)
|
||||
runGame numGameTicks = evalStateT (replicateM_ numGameTicks $ runTimeIO gameTick)
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
|
@ -28,6 +28,7 @@ import Data.Text.IO qualified as T
|
||||
import Data.Yaml (ParseException, prettyPrintParseException)
|
||||
import Swarm.Doc.Gen (EditorType (..))
|
||||
import Swarm.Doc.Gen qualified as DocGen
|
||||
import Swarm.Effect (runTimeIO)
|
||||
import Swarm.Game.Achievement.Definitions (GameplayAchievement (..))
|
||||
import Swarm.Game.CESK (emptyStore, getTickNumber, initMachine)
|
||||
import Swarm.Game.Entity (EntityMap, lookupByName)
|
||||
@ -484,7 +485,7 @@ testScenarioSolutions rs ui =
|
||||
b <- gets badErrorsInLogs
|
||||
when (null b) $ case w of
|
||||
WinConditions (Won _) _ -> return ()
|
||||
_ -> gameTick >> playUntilWin
|
||||
_ -> runTimeIO gameTick >> playUntilWin
|
||||
|
||||
noBadErrors :: GameState -> Assertion
|
||||
noBadErrors g = do
|
||||
|
@ -13,6 +13,7 @@ import Control.Monad.State (StateT (..), execState)
|
||||
import Control.Monad.Trans (lift)
|
||||
import Data.Text (Text)
|
||||
import Data.Text qualified as T
|
||||
import Swarm.Effect
|
||||
import Swarm.Game.CESK
|
||||
import Swarm.Game.Exception
|
||||
import Swarm.Game.Robot
|
||||
@ -47,7 +48,7 @@ runCESK :: Int -> CESK -> StateT Robot (StateT GameState IO) (Either Text (Value
|
||||
runCESK _ (Up exn _ []) = Left . flip formatExn exn <$> lift (use $ landscape . entityMap)
|
||||
runCESK !steps cesk = case finalValue cesk of
|
||||
Just (v, _) -> return (Right (v, steps))
|
||||
Nothing -> stepCESK cesk >>= runCESK (steps + 1)
|
||||
Nothing -> runTimeIO (stepCESK cesk) >>= runCESK (steps + 1)
|
||||
|
||||
play :: GameState -> Text -> IO (Either Text (), GameState)
|
||||
play g = either (return . (,g) . Left) playPT . processTerm1
|
||||
@ -68,7 +69,7 @@ playUntilDone rid = do
|
||||
w <- use robotMap
|
||||
case w ^? ix rid . to isActive of
|
||||
Just True -> do
|
||||
void gameTick
|
||||
void $ runTimeIO gameTick
|
||||
playUntilDone rid
|
||||
Just False -> return $ Right ()
|
||||
Nothing -> return $ Left . T.pack $ "The robot with ID " <> show rid <> " is nowhere to be found!"
|
||||
|
Loading…
Reference in New Issue
Block a user