{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}

-- |

-- Module      : Aztecs.ECS.Access

-- Copyright   : (c) Matt Hunzinger, 2025

-- License     : BSD-style (see the LICENSE file in the distribution)

--

-- Maintainer  : matt@hunzinger.me

-- Stability   : provisional

-- Portability : non-portable (GHC extensions)

module Aztecs.ECS.Access
  ( Access,
    AccessT (..),
    spawn,
    insert,
    lookup,
    remove,
    despawn,
    runAccessT,
    runAccessT_,
    system,
    concurrently,
  )
where

import Aztecs.ECS.Component
import Aztecs.ECS.Entity
import Aztecs.ECS.System (SystemT (..), runSystemT)
import qualified Aztecs.ECS.System as S
import Aztecs.ECS.World (World (..))
import qualified Aztecs.ECS.World as W
import Aztecs.ECS.World.Bundle
import Control.Concurrent.STM
import Control.DeepSeq
import Control.Monad.Fix
import Control.Monad.Identity
import Control.Monad.Reader
import Control.Monad.State.Strict
import Prelude hiding (lookup)

-- | @since 0.9

type Access = AccessT Identity

-- | Access into the `World`.

--

-- @since 0.9

newtype AccessT m a = AccessT {forall (m :: * -> *) a. AccessT m a -> StateT World m a
unAccessT :: StateT World m a}
  deriving ((forall a b. (a -> b) -> AccessT m a -> AccessT m b)
-> (forall a b. a -> AccessT m b -> AccessT m a)
-> Functor (AccessT m)
forall a b. a -> AccessT m b -> AccessT m a
forall a b. (a -> b) -> AccessT m a -> AccessT m b
forall (m :: * -> *) a b.
Functor m =>
a -> AccessT m b -> AccessT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> AccessT m a -> AccessT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> AccessT m a -> AccessT m b
fmap :: forall a b. (a -> b) -> AccessT m a -> AccessT m b
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> AccessT m b -> AccessT m a
<$ :: forall a b. a -> AccessT m b -> AccessT m a
Functor, Functor (AccessT m)
Functor (AccessT m) =>
(forall a. a -> AccessT m a)
-> (forall a b. AccessT m (a -> b) -> AccessT m a -> AccessT m b)
-> (forall a b c.
    (a -> b -> c) -> AccessT m a -> AccessT m b -> AccessT m c)
-> (forall a b. AccessT m a -> AccessT m b -> AccessT m b)
-> (forall a b. AccessT m a -> AccessT m b -> AccessT m a)
-> Applicative (AccessT m)
forall a. a -> AccessT m a
forall a b. AccessT m a -> AccessT m b -> AccessT m a
forall a b. AccessT m a -> AccessT m b -> AccessT m b
forall a b. AccessT m (a -> b) -> AccessT m a -> AccessT m b
forall a b c.
(a -> b -> c) -> AccessT m a -> AccessT m b -> AccessT m c
forall (m :: * -> *). Monad m => Functor (AccessT m)
forall (m :: * -> *) a. Monad m => a -> AccessT m a
forall (m :: * -> *) a b.
Monad m =>
AccessT m a -> AccessT m b -> AccessT m a
forall (m :: * -> *) a b.
Monad m =>
AccessT m a -> AccessT m b -> AccessT m b
forall (m :: * -> *) a b.
Monad m =>
AccessT m (a -> b) -> AccessT m a -> AccessT m b
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> AccessT m a -> AccessT m b -> AccessT m c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall (m :: * -> *) a. Monad m => a -> AccessT m a
pure :: forall a. a -> AccessT m a
$c<*> :: forall (m :: * -> *) a b.
Monad m =>
AccessT m (a -> b) -> AccessT m a -> AccessT m b
<*> :: forall a b. AccessT m (a -> b) -> AccessT m a -> AccessT m b
$cliftA2 :: forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> AccessT m a -> AccessT m b -> AccessT m c
liftA2 :: forall a b c.
(a -> b -> c) -> AccessT m a -> AccessT m b -> AccessT m c
$c*> :: forall (m :: * -> *) a b.
Monad m =>
AccessT m a -> AccessT m b -> AccessT m b
*> :: forall a b. AccessT m a -> AccessT m b -> AccessT m b
$c<* :: forall (m :: * -> *) a b.
Monad m =>
AccessT m a -> AccessT m b -> AccessT m a
<* :: forall a b. AccessT m a -> AccessT m b -> AccessT m a
Applicative, Monad (AccessT m)
Monad (AccessT m) =>
(forall a. (a -> AccessT m a) -> AccessT m a)
-> MonadFix (AccessT m)
forall a. (a -> AccessT m a) -> AccessT m a
forall (m :: * -> *).
Monad m =>
(forall a. (a -> m a) -> m a) -> MonadFix m
forall (m :: * -> *). MonadFix m => Monad (AccessT m)
forall (m :: * -> *) a.
MonadFix m =>
(a -> AccessT m a) -> AccessT m a
$cmfix :: forall (m :: * -> *) a.
MonadFix m =>
(a -> AccessT m a) -> AccessT m a
mfix :: forall a. (a -> AccessT m a) -> AccessT m a
MonadFix, Monad (AccessT m)
Monad (AccessT m) =>
(forall a. IO a -> AccessT m a) -> MonadIO (AccessT m)
forall a. IO a -> AccessT m a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
forall (m :: * -> *). MonadIO m => Monad (AccessT m)
forall (m :: * -> *) a. MonadIO m => IO a -> AccessT m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> AccessT m a
liftIO :: forall a. IO a -> AccessT m a
MonadIO)

-- | @since 0.9

instance (Monad m) => Monad (AccessT m) where
  AccessT m a
a >>= :: forall a b. AccessT m a -> (a -> AccessT m b) -> AccessT m b
>>= a -> AccessT m b
f = StateT World m b -> AccessT m b
forall (m :: * -> *) a. StateT World m a -> AccessT m a
AccessT (StateT World m b -> AccessT m b)
-> StateT World m b -> AccessT m b
forall a b. (a -> b) -> a -> b
$ do
    !World
w <- StateT World m World
forall s (m :: * -> *). MonadState s m => m s
get
    (a
a', World
w') <- m (a, World) -> StateT World m (a, World)
forall (m :: * -> *) a. Monad m => m a -> StateT World m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (a, World) -> StateT World m (a, World))
-> m (a, World) -> StateT World m (a, World)
forall a b. (a -> b) -> a -> b
$ AccessT m a -> World -> m (a, World)
forall (m :: * -> *) a.
Functor m =>
AccessT m a -> World -> m (a, World)
runAccessT AccessT m a
a World
w
    World -> StateT World m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (World -> ()
forall a. NFData a => a -> ()
rnf World
w' () -> World -> World
forall a b. a -> b -> b
`seq` World
w')
    AccessT m b -> StateT World m b
forall (m :: * -> *) a. AccessT m a -> StateT World m a
unAccessT (AccessT m b -> StateT World m b)
-> AccessT m b -> StateT World m b
forall a b. (a -> b) -> a -> b
$ a -> AccessT m b
f a
a'

-- | Run an `Access` on a `World`, returning the output and updated `World`.

--

-- @since 0.9

runAccessT :: (Functor m) => AccessT m a -> World -> m (a, World)
runAccessT :: forall (m :: * -> *) a.
Functor m =>
AccessT m a -> World -> m (a, World)
runAccessT AccessT m a
a = StateT World m a -> World -> m (a, World)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (StateT World m a -> World -> m (a, World))
-> StateT World m a -> World -> m (a, World)
forall a b. (a -> b) -> a -> b
$ AccessT m a -> StateT World m a
forall (m :: * -> *) a. AccessT m a -> StateT World m a
unAccessT AccessT m a
a

-- | Run an `Access` on an empty `World`.

--

-- @since 0.9

runAccessT_ :: (Functor m) => AccessT m a -> m a
runAccessT_ :: forall (m :: * -> *) a. Functor m => AccessT m a -> m a
runAccessT_ AccessT m a
a = ((a, World) -> a) -> m (a, World) -> m a
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, World) -> a
forall a b. (a, b) -> a
fst (m (a, World) -> m a) -> (World -> m (a, World)) -> World -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AccessT m a -> World -> m (a, World)
forall (m :: * -> *) a.
Functor m =>
AccessT m a -> World -> m (a, World)
runAccessT AccessT m a
a (World -> m a) -> World -> m a
forall a b. (a -> b) -> a -> b
$ World
W.empty

-- | Spawn an entity with a `Bundle`.

--

-- @since 0.11

spawn :: (Monad m) => Bundle -> AccessT m EntityID
spawn :: forall (m :: * -> *). Monad m => Bundle -> AccessT m EntityID
spawn Bundle
b = StateT World m EntityID -> AccessT m EntityID
forall (m :: * -> *) a. StateT World m a -> AccessT m a
AccessT (StateT World m EntityID -> AccessT m EntityID)
-> StateT World m EntityID -> AccessT m EntityID
forall a b. (a -> b) -> a -> b
$ do
  !World
w <- StateT World m World
forall s (m :: * -> *). MonadState s m => m s
get
  let !(EntityID
e, World
w') = Bundle -> World -> (EntityID, World)
W.spawn Bundle
b World
w
  World -> StateT World m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put World
w'
  EntityID -> StateT World m EntityID
forall a. a -> StateT World m a
forall (m :: * -> *) a. Monad m => a -> m a
return EntityID
e

-- | Insert a `Bundle` into an entity.

--

-- @since 0.11

insert :: (Monad m) => EntityID -> Bundle -> AccessT m ()
insert :: forall (m :: * -> *). Monad m => EntityID -> Bundle -> AccessT m ()
insert EntityID
e Bundle
c = StateT World m () -> AccessT m ()
forall (m :: * -> *) a. StateT World m a -> AccessT m a
AccessT (StateT World m () -> AccessT m ())
-> StateT World m () -> AccessT m ()
forall a b. (a -> b) -> a -> b
$ do
  !World
w <- StateT World m World
forall s (m :: * -> *). MonadState s m => m s
get
  let !w' :: World
w' = EntityID -> Bundle -> World -> World
W.insert EntityID
e Bundle
c World
w
  World -> StateT World m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put World
w'

-- | Lookup a component by `EntityID`.

--

-- @since 0.11

lookup :: (Monad m, Component a) => EntityID -> AccessT m (Maybe a)
lookup :: forall (m :: * -> *) a.
(Monad m, Component a) =>
EntityID -> AccessT m (Maybe a)
lookup EntityID
e = StateT World m (Maybe a) -> AccessT m (Maybe a)
forall (m :: * -> *) a. StateT World m a -> AccessT m a
AccessT (StateT World m (Maybe a) -> AccessT m (Maybe a))
-> StateT World m (Maybe a) -> AccessT m (Maybe a)
forall a b. (a -> b) -> a -> b
$ do
  !World
w <- StateT World m World
forall s (m :: * -> *). MonadState s m => m s
get
  Maybe a -> StateT World m (Maybe a)
forall a. a -> StateT World m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> StateT World m (Maybe a))
-> Maybe a -> StateT World m (Maybe a)
forall a b. (a -> b) -> a -> b
$ EntityID -> World -> Maybe a
forall a. Component a => EntityID -> World -> Maybe a
W.lookup EntityID
e World
w

-- | Remove a component by `EntityID`.

--

-- @since 0.11

remove :: (Monad m, Component a) => EntityID -> AccessT m (Maybe a)
remove :: forall (m :: * -> *) a.
(Monad m, Component a) =>
EntityID -> AccessT m (Maybe a)
remove EntityID
e = StateT World m (Maybe a) -> AccessT m (Maybe a)
forall (m :: * -> *) a. StateT World m a -> AccessT m a
AccessT (StateT World m (Maybe a) -> AccessT m (Maybe a))
-> StateT World m (Maybe a) -> AccessT m (Maybe a)
forall a b. (a -> b) -> a -> b
$ do
  !World
w <- StateT World m World
forall s (m :: * -> *). MonadState s m => m s
get
  let !(Maybe a
a, World
w') = EntityID -> World -> (Maybe a, World)
forall a. Component a => EntityID -> World -> (Maybe a, World)
W.remove EntityID
e World
w
  World -> StateT World m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put World
w'
  Maybe a -> StateT World m (Maybe a)
forall a. a -> StateT World m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
a

-- | Despawn an entity by `EntityID`.

--

-- @since 0.11

despawn :: (Monad m) => EntityID -> AccessT m ()
despawn :: forall (m :: * -> *). Monad m => EntityID -> AccessT m ()
despawn EntityID
e = StateT World m () -> AccessT m ()
forall (m :: * -> *) a. StateT World m a -> AccessT m a
AccessT (StateT World m () -> AccessT m ())
-> StateT World m () -> AccessT m ()
forall a b. (a -> b) -> a -> b
$ do
  !World
w <- StateT World m World
forall s (m :: * -> *). MonadState s m => m s
get
  let !(IntMap Dynamic
_, World
w') = EntityID -> World -> (IntMap Dynamic, World)
W.despawn EntityID
e World
w
  World -> StateT World m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put World
w'

-- | Run a `System`.

--

-- @since 0.11

system :: (Monad m) => SystemT m a -> AccessT m a
system :: forall (m :: * -> *) a. Monad m => SystemT m a -> AccessT m a
system SystemT m a
s = StateT World m a -> AccessT m a
forall (m :: * -> *) a. StateT World m a -> AccessT m a
AccessT (StateT World m a -> AccessT m a)
-> StateT World m a -> AccessT m a
forall a b. (a -> b) -> a -> b
$ do
  !World
w <- StateT World m World
forall s (m :: * -> *). MonadState s m => m s
get
  let go :: (b -> b) -> m b
go b -> b
f = do
        b
es <- m b
forall s (m :: * -> *). MonadState s m => m s
get
        let es' :: b
es' = b -> b
f b
es
        b -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put b
es'
        b -> m b
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return b
es'
  (a
a, Entities
es) <- m (a, Entities) -> StateT World m (a, Entities)
forall (m :: * -> *) a. Monad m => m a -> StateT World m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (a, Entities) -> StateT World m (a, Entities))
-> m (a, Entities) -> StateT World m (a, Entities)
forall a b. (a -> b) -> a -> b
$ StateT Entities m a -> Entities -> m (a, Entities)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (SystemT m a
-> ((Entities -> Entities) -> StateT Entities m Entities)
-> StateT Entities m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad (t m), Monad m) =>
SystemT m a -> ((Entities -> Entities) -> t m Entities) -> t m a
runSystemT SystemT m a
s (Entities -> Entities) -> StateT Entities m Entities
forall {m :: * -> *} {b}. MonadState b m => (b -> b) -> m b
go) (World -> Entities
entities World
w)
  World -> StateT World m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put World
w {entities = es}
  a -> StateT World m a
forall a. a -> StateT World m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

-- | Run a `System` concurrently.

--

-- @since 0.11

concurrently :: SystemT IO a -> AccessT IO a
concurrently :: forall a. SystemT IO a -> AccessT IO a
concurrently SystemT IO a
s = StateT World IO a -> AccessT IO a
forall (m :: * -> *) a. StateT World m a -> AccessT m a
AccessT (StateT World IO a -> AccessT IO a)
-> StateT World IO a -> AccessT IO a
forall a b. (a -> b) -> a -> b
$ do
  !World
w <- StateT World IO World
forall s (m :: * -> *). MonadState s m => m s
get
  TVar Entities
esVar <- IO (TVar Entities) -> StateT World IO (TVar Entities)
forall (m :: * -> *) a. Monad m => m a -> StateT World m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (TVar Entities) -> StateT World IO (TVar Entities))
-> (Entities -> IO (TVar Entities))
-> Entities
-> StateT World IO (TVar Entities)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entities -> IO (TVar Entities)
forall a. a -> IO (TVar a)
newTVarIO (Entities -> StateT World IO (TVar Entities))
-> Entities -> StateT World IO (TVar Entities)
forall a b. (a -> b) -> a -> b
$ World -> Entities
entities World
w
  let go :: (Entities -> Entities) -> IO Entities
go Entities -> Entities
f = STM Entities -> IO Entities
forall a. STM a -> IO a
atomically (STM Entities -> IO Entities) -> STM Entities -> IO Entities
forall a b. (a -> b) -> a -> b
$ do
        Entities
es <- TVar Entities -> STM Entities
forall a. TVar a -> STM a
readTVar TVar Entities
esVar
        let es' :: Entities
es' = Entities -> Entities
f Entities
es
        TVar Entities -> Entities -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Entities
esVar Entities
es'
        Entities -> STM Entities
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Entities
es'
  a
a <- IO a -> StateT World IO a
forall a. IO a -> StateT World IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> StateT World IO a) -> IO a -> StateT World IO a
forall a b. (a -> b) -> a -> b
$ SystemT IO a -> ((Entities -> Entities) -> IO Entities) -> IO a
forall a.
SystemT IO a -> ((Entities -> Entities) -> IO Entities) -> IO a
S.concurrently SystemT IO a
s (Entities -> Entities) -> IO Entities
go
  Entities
es <- IO Entities -> StateT World IO Entities
forall (m :: * -> *) a. Monad m => m a -> StateT World m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO Entities -> StateT World IO Entities)
-> IO Entities -> StateT World IO Entities
forall a b. (a -> b) -> a -> b
$ TVar Entities -> IO Entities
forall a. TVar a -> IO a
readTVarIO TVar Entities
esVar
  World -> StateT World IO ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put World
w {entities = es}
  a -> StateT World IO a
forall a. a -> StateT World IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a