{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

-- |

-- Module      : Aztecs.ECS.World.Archetype

-- 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.World.Archetype
  ( Archetype (..),
    empty,
    singleton,
    lookupComponent,
    lookupComponents,
    lookupComponentsAsc,
    lookupComponentsAscMaybe,
    lookupStorage,
    member,
    remove,
    removeStorages,
    insertComponent,
    insertComponents,
    insertAscList,
    map,
    mapM,
    zipMap,
    zipMapM,
  )
where

import Aztecs.ECS.Component
import Aztecs.ECS.Entity
import qualified Aztecs.ECS.World.Storage as S
import Aztecs.ECS.World.Storage.Dynamic
import qualified Aztecs.ECS.World.Storage.Dynamic as S
import Control.DeepSeq
import Control.Monad.Writer
  ( MonadTrans (..),
    MonadWriter (..),
    WriterT (..),
    runWriter,
  )
import Data.Dynamic
import Data.Foldable
import Data.IntMap (IntMap)
import qualified Data.IntMap.Strict as IntMap
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe
import Data.Set (Set)
import qualified Data.Set as Set
import GHC.Generics
import Prelude hiding (map, mapM, zipWith)

-- | Archetype of entities and components.

-- An archetype is guranteed to contain one of each stored component per entity.

--

-- @since 0.9

data Archetype = Archetype
  { -- | Component storages.

    --

    -- @since 0.9

    Archetype -> IntMap DynamicStorage
storages :: !(IntMap DynamicStorage),
    -- | Entities stored in this archetype.

    --

    -- @since 0.9

    Archetype -> Set EntityID
entities :: !(Set EntityID)
  }
  deriving (Int -> Archetype -> ShowS
[Archetype] -> ShowS
Archetype -> String
(Int -> Archetype -> ShowS)
-> (Archetype -> String)
-> ([Archetype] -> ShowS)
-> Show Archetype
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Archetype -> ShowS
showsPrec :: Int -> Archetype -> ShowS
$cshow :: Archetype -> String
show :: Archetype -> String
$cshowList :: [Archetype] -> ShowS
showList :: [Archetype] -> ShowS
Show, (forall x. Archetype -> Rep Archetype x)
-> (forall x. Rep Archetype x -> Archetype) -> Generic Archetype
forall x. Rep Archetype x -> Archetype
forall x. Archetype -> Rep Archetype x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Archetype -> Rep Archetype x
from :: forall x. Archetype -> Rep Archetype x
$cto :: forall x. Rep Archetype x -> Archetype
to :: forall x. Rep Archetype x -> Archetype
Generic)

instance Semigroup Archetype where
  Archetype
a <> :: Archetype -> Archetype -> Archetype
<> Archetype
b = Archetype {storages :: IntMap DynamicStorage
storages = Archetype -> IntMap DynamicStorage
storages Archetype
a IntMap DynamicStorage
-> IntMap DynamicStorage -> IntMap DynamicStorage
forall a. Semigroup a => a -> a -> a
<> Archetype -> IntMap DynamicStorage
storages Archetype
b, entities :: Set EntityID
entities = Archetype -> Set EntityID
entities Archetype
a Set EntityID -> Set EntityID -> Set EntityID
forall a. Semigroup a => a -> a -> a
<> Archetype -> Set EntityID
entities Archetype
b}

instance Monoid Archetype where
  mempty :: Archetype
mempty = Archetype
empty

instance NFData Archetype where
  rnf :: Archetype -> ()
rnf = Set EntityID -> ()
forall a. NFData a => a -> ()
rnf (Set EntityID -> ())
-> (Archetype -> Set EntityID) -> Archetype -> ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Archetype -> Set EntityID
entities

-- | Empty archetype.

--

-- @since 0.9

empty :: Archetype
empty :: Archetype
empty = Archetype {storages :: IntMap DynamicStorage
storages = IntMap DynamicStorage
forall a. IntMap a
IntMap.empty, entities :: Set EntityID
entities = Set EntityID
forall a. Set a
Set.empty}

-- | Archetype with a single entity.

--

-- @since 0.9

singleton :: EntityID -> Archetype
singleton :: EntityID -> Archetype
singleton EntityID
e = Archetype {storages :: IntMap DynamicStorage
storages = IntMap DynamicStorage
forall a. IntMap a
IntMap.empty, entities :: Set EntityID
entities = EntityID -> Set EntityID
forall a. a -> Set a
Set.singleton EntityID
e}

-- | Lookup a component `Storage` by its `ComponentID`.

--

-- @since 0.9

{-# INLINE lookupStorage #-}
lookupStorage :: (Component a) => ComponentID -> Archetype -> Maybe (StorageT a)
lookupStorage :: forall a.
Component a =>
ComponentID -> Archetype -> Maybe (StorageT a)
lookupStorage ComponentID
cId Archetype
w = do
  DynamicStorage
dynS <- Int -> IntMap DynamicStorage -> Maybe DynamicStorage
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup (ComponentID -> Int
unComponentId ComponentID
cId) (IntMap DynamicStorage -> Maybe DynamicStorage)
-> IntMap DynamicStorage -> Maybe DynamicStorage
forall a b. (a -> b) -> a -> b
$ Archetype -> IntMap DynamicStorage
storages Archetype
w
  Dynamic -> Maybe (StorageT a)
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic (Dynamic -> Maybe (StorageT a)) -> Dynamic -> Maybe (StorageT a)
forall a b. (a -> b) -> a -> b
$ DynamicStorage -> Dynamic
storageDyn DynamicStorage
dynS

-- | Lookup a component by its `EntityID` and `ComponentID`.

--

-- @since 0.9

{-# INLINE lookupComponent #-}
lookupComponent :: (Component a) => EntityID -> ComponentID -> Archetype -> Maybe a
lookupComponent :: forall a.
Component a =>
EntityID -> ComponentID -> Archetype -> Maybe a
lookupComponent EntityID
e ComponentID
cId Archetype
w = ComponentID -> Archetype -> Map EntityID a
forall a. Component a => ComponentID -> Archetype -> Map EntityID a
lookupComponents ComponentID
cId Archetype
w Map EntityID a -> EntityID -> Maybe a
forall k a. Ord k => Map k a -> k -> Maybe a
Map.!? EntityID
e

-- | Lookup all components by their `ComponentID`.

--

-- @since 0.9

{-# INLINE lookupComponents #-}
lookupComponents :: (Component a) => ComponentID -> Archetype -> Map EntityID a
lookupComponents :: forall a. Component a => ComponentID -> Archetype -> Map EntityID a
lookupComponents ComponentID
cId Archetype
arch = case ComponentID -> Archetype -> Maybe [a]
forall a. Component a => ComponentID -> Archetype -> Maybe [a]
lookupComponentsAscMaybe ComponentID
cId Archetype
arch of
  Just [a]
as -> [(EntityID, a)] -> Map EntityID a
forall k a. Eq k => [(k, a)] -> Map k a
Map.fromAscList ([(EntityID, a)] -> Map EntityID a)
-> [(EntityID, a)] -> Map EntityID a
forall a b. (a -> b) -> a -> b
$ [EntityID] -> [a] -> [(EntityID, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Set EntityID -> [EntityID]
forall a. Set a -> [a]
Set.toList (Set EntityID -> [EntityID]) -> Set EntityID -> [EntityID]
forall a b. (a -> b) -> a -> b
$ Archetype -> Set EntityID
entities Archetype
arch) [a]
as
  Maybe [a]
Nothing -> Map EntityID a
forall k a. Map k a
Map.empty

-- | Lookup all components by their `ComponentID`, in ascending order by their `EntityID`.

--

-- @since 0.9

{-# INLINE lookupComponentsAsc #-}
lookupComponentsAsc :: (Component a) => ComponentID -> Archetype -> [a]
lookupComponentsAsc :: forall a. Component a => ComponentID -> Archetype -> [a]
lookupComponentsAsc ComponentID
cId = [a] -> Maybe [a] -> [a]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [a] -> [a]) -> (Archetype -> Maybe [a]) -> Archetype -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ComponentID -> Archetype -> Maybe [a]
forall a. Component a => ComponentID -> Archetype -> Maybe [a]
lookupComponentsAscMaybe ComponentID
cId

-- | Lookup all components by their `ComponentID`, in ascending order by their `EntityID`.

--

-- @since 0.9

{-# INLINE lookupComponentsAscMaybe #-}
lookupComponentsAscMaybe :: forall a. (Component a) => ComponentID -> Archetype -> Maybe [a]
lookupComponentsAscMaybe :: forall a. Component a => ComponentID -> Archetype -> Maybe [a]
lookupComponentsAscMaybe ComponentID
cId Archetype
arch = StorageT a -> [a]
forall a s. Storage a s => s -> [a]
S.toAscList (StorageT a -> [a]) -> Maybe (StorageT a) -> Maybe [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
Component a =>
ComponentID -> Archetype -> Maybe (StorageT a)
lookupStorage @a ComponentID
cId Archetype
arch

-- | Insert a component into the archetype.

-- This assumes the archetype contains one of each stored component per entity.

--

-- @since 0.9

insertComponent ::
  forall a. (Component a) => EntityID -> ComponentID -> a -> Archetype -> Archetype
insertComponent :: forall a.
Component a =>
EntityID -> ComponentID -> a -> Archetype -> Archetype
insertComponent EntityID
e ComponentID
cId a
c Archetype
arch =
  let !storage :: StorageT a
storage =
        forall a s. Storage a s => [a] -> s
S.fromAscList @a @(StorageT a) ([a] -> StorageT a)
-> (Map EntityID a -> [a]) -> Map EntityID a -> StorageT a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map EntityID a -> [a]
forall k a. Map k a -> [a]
Map.elems (Map EntityID a -> [a])
-> (Map EntityID a -> Map EntityID a) -> Map EntityID a -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityID -> a -> Map EntityID a -> Map EntityID a
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert EntityID
e a
c (Map EntityID a -> StorageT a) -> Map EntityID a -> StorageT a
forall a b. (a -> b) -> a -> b
$ ComponentID -> Archetype -> Map EntityID a
forall a. Component a => ComponentID -> Archetype -> Map EntityID a
lookupComponents ComponentID
cId Archetype
arch
   in Archetype
arch {storages = IntMap.insert (unComponentId cId) (dynStorage @a storage) (storages arch)}

-- | @True@ if this archetype contains an entity with the provided `ComponentID`.

--

-- @since 0.9

{-# INLINE member #-}
member :: ComponentID -> Archetype -> Bool
member :: ComponentID -> Archetype -> Bool
member ComponentID
cId = Int -> IntMap DynamicStorage -> Bool
forall a. Int -> IntMap a -> Bool
IntMap.member (ComponentID -> Int
unComponentId ComponentID
cId) (IntMap DynamicStorage -> Bool)
-> (Archetype -> IntMap DynamicStorage) -> Archetype -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Archetype -> IntMap DynamicStorage
storages

-- | Map a list of components with a function and a component storage.

--

-- @since 0.11

{-# INLINE map #-}
map ::
  forall a. (Component a) => (a -> a) -> ComponentID -> Archetype -> ([a], Archetype)
map :: forall a.
Component a =>
(a -> a) -> ComponentID -> Archetype -> ([a], Archetype)
map a -> a
f ComponentID
cId Archetype
arch =
  let go :: Maybe DynamicStorage -> WriterT [a] Identity (Maybe DynamicStorage)
go Maybe DynamicStorage
maybeDyn = case Maybe DynamicStorage
maybeDyn of
        Just DynamicStorage
dyn -> case Dynamic -> Maybe (StorageT a)
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic (Dynamic -> Maybe (StorageT a)) -> Dynamic -> Maybe (StorageT a)
forall a b. (a -> b) -> a -> b
$ DynamicStorage -> Dynamic
storageDyn DynamicStorage
dyn of
          Just StorageT a
s -> do
            let !([a]
as, StorageT a
s') = forall a s. Storage a s => (a -> a) -> s -> ([a], s)
S.map @a @(StorageT a) a -> a
f StorageT a
s
            [a] -> WriterT [a] Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [a]
as
            return $ DynamicStorage -> Maybe DynamicStorage
forall a. a -> Maybe a
Just (DynamicStorage -> Maybe DynamicStorage)
-> DynamicStorage -> Maybe DynamicStorage
forall a b. (a -> b) -> a -> b
$ DynamicStorage
dyn {storageDyn = toDyn s'}
          Maybe (StorageT a)
Nothing -> Maybe DynamicStorage -> WriterT [a] Identity (Maybe DynamicStorage)
forall a. a -> WriterT [a] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe DynamicStorage
maybeDyn
        Maybe DynamicStorage
Nothing -> Maybe DynamicStorage -> WriterT [a] Identity (Maybe DynamicStorage)
forall a. a -> WriterT [a] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe DynamicStorage
forall a. Maybe a
Nothing
      !(IntMap DynamicStorage
storages', [a]
cs) = Writer [a] (IntMap DynamicStorage) -> (IntMap DynamicStorage, [a])
forall w a. Writer w a -> (a, w)
runWriter (Writer [a] (IntMap DynamicStorage)
 -> (IntMap DynamicStorage, [a]))
-> Writer [a] (IntMap DynamicStorage)
-> (IntMap DynamicStorage, [a])
forall a b. (a -> b) -> a -> b
$ (Maybe DynamicStorage
 -> WriterT [a] Identity (Maybe DynamicStorage))
-> Int
-> IntMap DynamicStorage
-> Writer [a] (IntMap DynamicStorage)
forall (f :: * -> *) a.
Functor f =>
(Maybe a -> f (Maybe a)) -> Int -> IntMap a -> f (IntMap a)
IntMap.alterF Maybe DynamicStorage -> WriterT [a] Identity (Maybe DynamicStorage)
go (ComponentID -> Int
unComponentId ComponentID
cId) (IntMap DynamicStorage -> Writer [a] (IntMap DynamicStorage))
-> IntMap DynamicStorage -> Writer [a] (IntMap DynamicStorage)
forall a b. (a -> b) -> a -> b
$ Archetype -> IntMap DynamicStorage
storages Archetype
arch
   in ([a]
cs, Archetype
arch {storages = storages'})

-- | Map a list of components with a monadic function.

--

-- @since 0.11

{-# INLINE mapM #-}
mapM ::
  forall m a.
  (Monad m, Component a) =>
  (a -> m a) ->
  ComponentID ->
  Archetype ->
  m ([a], Archetype)
mapM :: forall (m :: * -> *) a.
(Monad m, Component a) =>
(a -> m a) -> ComponentID -> Archetype -> m ([a], Archetype)
mapM a -> m a
f ComponentID
cId Archetype
arch = do
  let go :: Maybe DynamicStorage -> WriterT [a] m (Maybe DynamicStorage)
go Maybe DynamicStorage
maybeDyn = case Maybe DynamicStorage
maybeDyn of
        Just DynamicStorage
dyn -> case Dynamic -> Maybe (StorageT a)
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic (Dynamic -> Maybe (StorageT a)) -> Dynamic -> Maybe (StorageT a)
forall a b. (a -> b) -> a -> b
$ DynamicStorage -> Dynamic
storageDyn DynamicStorage
dyn of
          Just StorageT a
s -> do
            ([a]
as, StorageT a
s') <- m ([a], StorageT a) -> WriterT [a] m ([a], StorageT a)
forall (m :: * -> *) a. Monad m => m a -> WriterT [a] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m ([a], StorageT a) -> WriterT [a] m ([a], StorageT a))
-> m ([a], StorageT a) -> WriterT [a] m ([a], StorageT a)
forall a b. (a -> b) -> a -> b
$ forall a s (m :: * -> *).
(Storage a s, Monad m) =>
(a -> m a) -> s -> m ([a], s)
S.mapM @a @(StorageT a) a -> m a
f StorageT a
s
            [a] -> WriterT [a] m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [a]
as
            return $ DynamicStorage -> Maybe DynamicStorage
forall a. a -> Maybe a
Just (DynamicStorage -> Maybe DynamicStorage)
-> DynamicStorage -> Maybe DynamicStorage
forall a b. (a -> b) -> a -> b
$ DynamicStorage
dyn {storageDyn = toDyn s'}
          Maybe (StorageT a)
Nothing -> Maybe DynamicStorage -> WriterT [a] m (Maybe DynamicStorage)
forall a. a -> WriterT [a] m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe DynamicStorage
maybeDyn
        Maybe DynamicStorage
Nothing -> Maybe DynamicStorage -> WriterT [a] m (Maybe DynamicStorage)
forall a. a -> WriterT [a] m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe DynamicStorage
forall a. Maybe a
Nothing
  (IntMap DynamicStorage
storages', [a]
cs) <- WriterT [a] m (IntMap DynamicStorage)
-> m (IntMap DynamicStorage, [a])
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (WriterT [a] m (IntMap DynamicStorage)
 -> m (IntMap DynamicStorage, [a]))
-> WriterT [a] m (IntMap DynamicStorage)
-> m (IntMap DynamicStorage, [a])
forall a b. (a -> b) -> a -> b
$ (Maybe DynamicStorage -> WriterT [a] m (Maybe DynamicStorage))
-> Int
-> IntMap DynamicStorage
-> WriterT [a] m (IntMap DynamicStorage)
forall (f :: * -> *) a.
Functor f =>
(Maybe a -> f (Maybe a)) -> Int -> IntMap a -> f (IntMap a)
IntMap.alterF Maybe DynamicStorage -> WriterT [a] m (Maybe DynamicStorage)
go (ComponentID -> Int
unComponentId ComponentID
cId) (IntMap DynamicStorage -> WriterT [a] m (IntMap DynamicStorage))
-> IntMap DynamicStorage -> WriterT [a] m (IntMap DynamicStorage)
forall a b. (a -> b) -> a -> b
$ Archetype -> IntMap DynamicStorage
storages Archetype
arch
  ([a], Archetype) -> m ([a], Archetype)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([a]
cs, Archetype
arch {storages = storages'})

-- | Zip a list of components with a function.

--

-- @since 0.9

{-# INLINE zipMap #-}
zipMap ::
  forall a b c.
  (Component c) =>
  [a] ->
  (a -> c -> (b, c)) ->
  ComponentID ->
  Archetype ->
  ([(b, c)], Archetype)
zipMap :: forall a b c.
Component c =>
[a]
-> (a -> c -> (b, c))
-> ComponentID
-> Archetype
-> ([(b, c)], Archetype)
zipMap [a]
as a -> c -> (b, c)
f ComponentID
cId Archetype
arch =
  let go :: Maybe DynamicStorage
-> WriterT [(b, c)] Identity (Maybe DynamicStorage)
go Maybe DynamicStorage
maybeDyn = case Maybe DynamicStorage
maybeDyn of
        Just DynamicStorage
dyn -> case Dynamic -> Maybe (StorageT c)
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic (Dynamic -> Maybe (StorageT c)) -> Dynamic -> Maybe (StorageT c)
forall a b. (a -> b) -> a -> b
$ DynamicStorage -> Dynamic
storageDyn DynamicStorage
dyn of
          Just StorageT c
s -> do
            let ([(b, c)]
acs, StorageT c
s') = forall a s b c.
Storage a s =>
(b -> a -> (c, a)) -> [b] -> s -> ([(c, a)], s)
S.zipWith @c @(StorageT c) a -> c -> (b, c)
f [a]
as StorageT c
s
            [(b, c)] -> WriterT [(b, c)] Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [(b, c)]
acs
            return $ DynamicStorage -> Maybe DynamicStorage
forall a. a -> Maybe a
Just (DynamicStorage -> Maybe DynamicStorage)
-> DynamicStorage -> Maybe DynamicStorage
forall a b. (a -> b) -> a -> b
$ DynamicStorage
dyn {storageDyn = toDyn s'}
          Maybe (StorageT c)
Nothing -> Maybe DynamicStorage
-> WriterT [(b, c)] Identity (Maybe DynamicStorage)
forall a. a -> WriterT [(b, c)] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe DynamicStorage
maybeDyn
        Maybe DynamicStorage
Nothing -> Maybe DynamicStorage
-> WriterT [(b, c)] Identity (Maybe DynamicStorage)
forall a. a -> WriterT [(b, c)] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe DynamicStorage
forall a. Maybe a
Nothing
      (IntMap DynamicStorage
storages', [(b, c)]
cs) = Writer [(b, c)] (IntMap DynamicStorage)
-> (IntMap DynamicStorage, [(b, c)])
forall w a. Writer w a -> (a, w)
runWriter (Writer [(b, c)] (IntMap DynamicStorage)
 -> (IntMap DynamicStorage, [(b, c)]))
-> Writer [(b, c)] (IntMap DynamicStorage)
-> (IntMap DynamicStorage, [(b, c)])
forall a b. (a -> b) -> a -> b
$ (Maybe DynamicStorage
 -> WriterT [(b, c)] Identity (Maybe DynamicStorage))
-> Int
-> IntMap DynamicStorage
-> Writer [(b, c)] (IntMap DynamicStorage)
forall (f :: * -> *) a.
Functor f =>
(Maybe a -> f (Maybe a)) -> Int -> IntMap a -> f (IntMap a)
IntMap.alterF Maybe DynamicStorage
-> WriterT [(b, c)] Identity (Maybe DynamicStorage)
go (ComponentID -> Int
unComponentId ComponentID
cId) (IntMap DynamicStorage -> Writer [(b, c)] (IntMap DynamicStorage))
-> IntMap DynamicStorage -> Writer [(b, c)] (IntMap DynamicStorage)
forall a b. (a -> b) -> a -> b
$ Archetype -> IntMap DynamicStorage
storages Archetype
arch
   in ([(b, c)]
cs, Archetype
arch {storages = storages'})

-- | Zip a list of components with a monadic function .

--

-- @since 0.9

zipMapM ::
  forall m a b c.
  (Applicative m, Component c) =>
  [a] ->
  (a -> c -> m (b, c)) ->
  ComponentID ->
  Archetype ->
  m ([(b, c)], Archetype)
zipMapM :: forall (m :: * -> *) a b c.
(Applicative m, Component c) =>
[a]
-> (a -> c -> m (b, c))
-> ComponentID
-> Archetype
-> m ([(b, c)], Archetype)
zipMapM [a]
as a -> c -> m (b, c)
f ComponentID
cId Archetype
arch = do
  let go :: Maybe DynamicStorage -> WriterT [(b, c)] m (Maybe DynamicStorage)
go Maybe DynamicStorage
maybeDyn = case Maybe DynamicStorage
maybeDyn of
        Just DynamicStorage
dyn -> case Dynamic -> Maybe (StorageT c)
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic (Dynamic -> Maybe (StorageT c)) -> Dynamic -> Maybe (StorageT c)
forall a b. (a -> b) -> a -> b
$ DynamicStorage -> Dynamic
storageDyn DynamicStorage
dyn of
          Just StorageT c
s ->
            m (Maybe DynamicStorage, [(b, c)])
-> WriterT [(b, c)] m (Maybe DynamicStorage)
forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
WriterT (m (Maybe DynamicStorage, [(b, c)])
 -> WriterT [(b, c)] m (Maybe DynamicStorage))
-> m (Maybe DynamicStorage, [(b, c)])
-> WriterT [(b, c)] m (Maybe DynamicStorage)
forall a b. (a -> b) -> a -> b
$
              (([(b, c)], StorageT c) -> (Maybe DynamicStorage, [(b, c)]))
-> m ([(b, c)], StorageT c) -> m (Maybe DynamicStorage, [(b, c)])
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
                (\([(b, c)]
cs, StorageT c
s') -> (DynamicStorage -> Maybe DynamicStorage
forall a. a -> Maybe a
Just DynamicStorage
dyn {storageDyn = toDyn s'}, [(b, c)]
cs))
                (forall a s (m :: * -> *) b c.
(Storage a s, Applicative m) =>
(b -> a -> m (c, a)) -> [b] -> s -> m ([(c, a)], s)
S.zipWithM @c @(StorageT c) a -> c -> m (b, c)
f [a]
as StorageT c
s)
          Maybe (StorageT c)
Nothing -> Maybe DynamicStorage -> WriterT [(b, c)] m (Maybe DynamicStorage)
forall a. a -> WriterT [(b, c)] m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe DynamicStorage
maybeDyn
        Maybe DynamicStorage
Nothing -> Maybe DynamicStorage -> WriterT [(b, c)] m (Maybe DynamicStorage)
forall a. a -> WriterT [(b, c)] m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe DynamicStorage
forall a. Maybe a
Nothing
  (IntMap DynamicStorage, [(b, c)])
res <- WriterT [(b, c)] m (IntMap DynamicStorage)
-> m (IntMap DynamicStorage, [(b, c)])
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (WriterT [(b, c)] m (IntMap DynamicStorage)
 -> m (IntMap DynamicStorage, [(b, c)]))
-> WriterT [(b, c)] m (IntMap DynamicStorage)
-> m (IntMap DynamicStorage, [(b, c)])
forall a b. (a -> b) -> a -> b
$ (Maybe DynamicStorage -> WriterT [(b, c)] m (Maybe DynamicStorage))
-> Int
-> IntMap DynamicStorage
-> WriterT [(b, c)] m (IntMap DynamicStorage)
forall (f :: * -> *) a.
Functor f =>
(Maybe a -> f (Maybe a)) -> Int -> IntMap a -> f (IntMap a)
IntMap.alterF Maybe DynamicStorage -> WriterT [(b, c)] m (Maybe DynamicStorage)
go (ComponentID -> Int
unComponentId ComponentID
cId) (IntMap DynamicStorage
 -> WriterT [(b, c)] m (IntMap DynamicStorage))
-> IntMap DynamicStorage
-> WriterT [(b, c)] m (IntMap DynamicStorage)
forall a b. (a -> b) -> a -> b
$ Archetype -> IntMap DynamicStorage
storages Archetype
arch
  return ((IntMap DynamicStorage, [(b, c)]) -> [(b, c)]
forall a b. (a, b) -> b
snd (IntMap DynamicStorage, [(b, c)])
res, Archetype
arch {storages = fst res})

-- | Insert a list of components into the archetype, sorted in ascending order by their `EntityID`.

--

-- @since 0.9

{-# INLINE insertAscList #-}
insertAscList :: forall a. (Component a) => ComponentID -> [a] -> Archetype -> Archetype
insertAscList :: forall a.
Component a =>
ComponentID -> [a] -> Archetype -> Archetype
insertAscList ComponentID
cId [a]
as Archetype
arch =
  let !storage :: DynamicStorage
storage = forall a s. Storage a s => s -> DynamicStorage
dynStorage @a (StorageT a -> DynamicStorage) -> StorageT a -> DynamicStorage
forall a b. (a -> b) -> a -> b
$ forall a s. Storage a s => [a] -> s
S.fromAscList @a @(StorageT a) [a]
as
   in Archetype
arch {storages = IntMap.insert (unComponentId cId) storage $ storages arch}

-- | Remove an entity from an archetype, returning its components.

--

-- @since 0.9

remove :: EntityID -> Archetype -> (IntMap Dynamic, Archetype)
remove :: EntityID -> Archetype -> (IntMap Dynamic, Archetype)
remove EntityID
e Archetype
arch =
  let go :: (IntMap Dynamic, Archetype)
-> (Int, DynamicStorage) -> (IntMap Dynamic, Archetype)
go (IntMap Dynamic
dynAcc, Archetype
archAcc) (Int
cId, DynamicStorage
dynS) =
        let cs :: Map EntityID Dynamic
cs = [(EntityID, Dynamic)] -> Map EntityID Dynamic
forall k a. Eq k => [(k, a)] -> Map k a
Map.fromAscList ([(EntityID, Dynamic)] -> Map EntityID Dynamic)
-> ([Dynamic] -> [(EntityID, Dynamic)])
-> [Dynamic]
-> Map EntityID Dynamic
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [EntityID] -> [Dynamic] -> [(EntityID, Dynamic)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Set EntityID -> [EntityID]
forall a. Set a -> [a]
Set.toList (Set EntityID -> [EntityID]) -> Set EntityID -> [EntityID]
forall a b. (a -> b) -> a -> b
$ Archetype -> Set EntityID
entities Archetype
arch) ([Dynamic] -> Map EntityID Dynamic)
-> [Dynamic] -> Map EntityID Dynamic
forall a b. (a -> b) -> a -> b
$ DynamicStorage -> [Dynamic]
toAscListDyn DynamicStorage
dynS
            !(Maybe Dynamic
dynA, Map EntityID Dynamic
cs') = (EntityID -> Dynamic -> Maybe Dynamic)
-> EntityID
-> Map EntityID Dynamic
-> (Maybe Dynamic, Map EntityID Dynamic)
forall k a.
Ord k =>
(k -> a -> Maybe a) -> k -> Map k a -> (Maybe a, Map k a)
Map.updateLookupWithKey (\EntityID
_ Dynamic
_ -> Maybe Dynamic
forall a. Maybe a
Nothing) EntityID
e Map EntityID Dynamic
cs
            dynS' :: DynamicStorage
dynS' = [Dynamic] -> DynamicStorage -> DynamicStorage
S.fromAscListDyn (Map EntityID Dynamic -> [Dynamic]
forall k a. Map k a -> [a]
Map.elems Map EntityID Dynamic
cs') DynamicStorage
dynS
            !dynAcc' :: IntMap Dynamic
dynAcc' = case Maybe Dynamic
dynA of
              Just Dynamic
d -> Int -> Dynamic -> IntMap Dynamic -> IntMap Dynamic
forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
cId Dynamic
d IntMap Dynamic
dynAcc
              Maybe Dynamic
Nothing -> IntMap Dynamic
dynAcc
         in (IntMap Dynamic
dynAcc', Archetype
archAcc {storages = IntMap.insert cId dynS' $ storages archAcc})
      arch' :: Archetype
arch' = Archetype
arch {entities = Set.delete e $ entities arch}
   in ((IntMap Dynamic, Archetype)
 -> (Int, DynamicStorage) -> (IntMap Dynamic, Archetype))
-> (IntMap Dynamic, Archetype)
-> [(Int, DynamicStorage)]
-> (IntMap Dynamic, Archetype)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (IntMap Dynamic, Archetype)
-> (Int, DynamicStorage) -> (IntMap Dynamic, Archetype)
go (IntMap Dynamic
forall a. IntMap a
IntMap.empty, Archetype
arch') ([(Int, DynamicStorage)] -> (IntMap Dynamic, Archetype))
-> (IntMap DynamicStorage -> [(Int, DynamicStorage)])
-> IntMap DynamicStorage
-> (IntMap Dynamic, Archetype)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntMap DynamicStorage -> [(Int, DynamicStorage)]
forall a. IntMap a -> [(Int, a)]
IntMap.toList (IntMap DynamicStorage -> (IntMap Dynamic, Archetype))
-> IntMap DynamicStorage -> (IntMap Dynamic, Archetype)
forall a b. (a -> b) -> a -> b
$ Archetype -> IntMap DynamicStorage
storages Archetype
arch'

-- | Remove an entity from an archetype, returning its component storages.

--

-- @since 0.9

removeStorages :: EntityID -> Archetype -> (IntMap DynamicStorage, Archetype)
removeStorages :: EntityID -> Archetype -> (IntMap DynamicStorage, Archetype)
removeStorages EntityID
e Archetype
arch =
  let go :: (IntMap DynamicStorage, Archetype)
-> (Int, DynamicStorage) -> (IntMap DynamicStorage, Archetype)
go (IntMap DynamicStorage
dynAcc, Archetype
archAcc) (Int
cId, DynamicStorage
dynS) =
        let cs :: Map EntityID Dynamic
cs = [(EntityID, Dynamic)] -> Map EntityID Dynamic
forall k a. Eq k => [(k, a)] -> Map k a
Map.fromAscList ([(EntityID, Dynamic)] -> Map EntityID Dynamic)
-> ([Dynamic] -> [(EntityID, Dynamic)])
-> [Dynamic]
-> Map EntityID Dynamic
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [EntityID] -> [Dynamic] -> [(EntityID, Dynamic)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Set EntityID -> [EntityID]
forall a. Set a -> [a]
Set.toList (Set EntityID -> [EntityID]) -> Set EntityID -> [EntityID]
forall a b. (a -> b) -> a -> b
$ Archetype -> Set EntityID
entities Archetype
arch) ([Dynamic] -> Map EntityID Dynamic)
-> [Dynamic] -> Map EntityID Dynamic
forall a b. (a -> b) -> a -> b
$ DynamicStorage -> [Dynamic]
toAscListDyn DynamicStorage
dynS
            !(Maybe Dynamic
dynA, Map EntityID Dynamic
cs') = (EntityID -> Dynamic -> Maybe Dynamic)
-> EntityID
-> Map EntityID Dynamic
-> (Maybe Dynamic, Map EntityID Dynamic)
forall k a.
Ord k =>
(k -> a -> Maybe a) -> k -> Map k a -> (Maybe a, Map k a)
Map.updateLookupWithKey (\EntityID
_ Dynamic
_ -> Maybe Dynamic
forall a. Maybe a
Nothing) EntityID
e Map EntityID Dynamic
cs
            dynS' :: DynamicStorage
dynS' = [Dynamic] -> DynamicStorage -> DynamicStorage
S.fromAscListDyn (Map EntityID Dynamic -> [Dynamic]
forall k a. Map k a -> [a]
Map.elems Map EntityID Dynamic
cs') DynamicStorage
dynS
            !dynAcc' :: IntMap DynamicStorage
dynAcc' = case Maybe Dynamic
dynA of
              Just Dynamic
d -> Int
-> DynamicStorage -> IntMap DynamicStorage -> IntMap DynamicStorage
forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
cId (Dynamic -> DynamicStorage -> DynamicStorage
S.singletonDyn Dynamic
d DynamicStorage
dynS') IntMap DynamicStorage
dynAcc
              Maybe Dynamic
Nothing -> IntMap DynamicStorage
dynAcc
         in (IntMap DynamicStorage
dynAcc', Archetype
archAcc {storages = IntMap.insert cId dynS' $ storages archAcc})
      arch' :: Archetype
arch' = Archetype
arch {entities = Set.delete e $ entities arch}
   in ((IntMap DynamicStorage, Archetype)
 -> (Int, DynamicStorage) -> (IntMap DynamicStorage, Archetype))
-> (IntMap DynamicStorage, Archetype)
-> [(Int, DynamicStorage)]
-> (IntMap DynamicStorage, Archetype)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (IntMap DynamicStorage, Archetype)
-> (Int, DynamicStorage) -> (IntMap DynamicStorage, Archetype)
go (IntMap DynamicStorage
forall a. IntMap a
IntMap.empty, Archetype
arch') ([(Int, DynamicStorage)] -> (IntMap DynamicStorage, Archetype))
-> (IntMap DynamicStorage -> [(Int, DynamicStorage)])
-> IntMap DynamicStorage
-> (IntMap DynamicStorage, Archetype)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntMap DynamicStorage -> [(Int, DynamicStorage)]
forall a. IntMap a -> [(Int, a)]
IntMap.toList (IntMap DynamicStorage -> (IntMap DynamicStorage, Archetype))
-> IntMap DynamicStorage -> (IntMap DynamicStorage, Archetype)
forall a b. (a -> b) -> a -> b
$ Archetype -> IntMap DynamicStorage
storages Archetype
arch'

-- | Insert a map of component storages and their `EntityID` into the archetype.

--

-- @since 0.9

insertComponents :: EntityID -> IntMap Dynamic -> Archetype -> Archetype
insertComponents :: EntityID -> IntMap Dynamic -> Archetype -> Archetype
insertComponents EntityID
e IntMap Dynamic
cs Archetype
arch =
  let f :: Archetype -> (Int, Dynamic) -> Archetype
f Archetype
archAcc (Int
itemCId, Dynamic
dyn) =
        let storages' :: IntMap DynamicStorage
storages' = (DynamicStorage -> DynamicStorage)
-> Int -> IntMap DynamicStorage -> IntMap DynamicStorage
forall a. (a -> a) -> Int -> IntMap a -> IntMap a
IntMap.adjust DynamicStorage -> DynamicStorage
go Int
itemCId (Archetype -> IntMap DynamicStorage
storages Archetype
archAcc)
            es :: [EntityID]
es = Set EntityID -> [EntityID]
forall a. Set a -> [a]
Set.toList (Set EntityID -> [EntityID]) -> Set EntityID -> [EntityID]
forall a b. (a -> b) -> a -> b
$ Archetype -> Set EntityID
entities Archetype
archAcc
            go :: DynamicStorage -> DynamicStorage
go DynamicStorage
s =
              let ecs :: [Dynamic]
ecs = Map EntityID Dynamic -> [Dynamic]
forall k a. Map k a -> [a]
Map.elems (Map EntityID Dynamic -> [Dynamic])
-> ([Dynamic] -> Map EntityID Dynamic) -> [Dynamic] -> [Dynamic]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityID -> Dynamic -> Map EntityID Dynamic -> Map EntityID Dynamic
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert EntityID
e Dynamic
dyn (Map EntityID Dynamic -> Map EntityID Dynamic)
-> ([Dynamic] -> Map EntityID Dynamic)
-> [Dynamic]
-> Map EntityID Dynamic
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(EntityID, Dynamic)] -> Map EntityID Dynamic
forall k a. Eq k => [(k, a)] -> Map k a
Map.fromAscList ([(EntityID, Dynamic)] -> Map EntityID Dynamic)
-> ([Dynamic] -> [(EntityID, Dynamic)])
-> [Dynamic]
-> Map EntityID Dynamic
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [EntityID] -> [Dynamic] -> [(EntityID, Dynamic)]
forall a b. [a] -> [b] -> [(a, b)]
zip [EntityID]
es ([Dynamic] -> [Dynamic]) -> [Dynamic] -> [Dynamic]
forall a b. (a -> b) -> a -> b
$ DynamicStorage -> [Dynamic]
toAscListDyn DynamicStorage
s
               in [Dynamic] -> DynamicStorage -> DynamicStorage
fromAscListDyn [Dynamic]
ecs DynamicStorage
s
         in Archetype
archAcc {storages = storages', entities = Set.insert e $ entities archAcc}
   in (Archetype -> (Int, Dynamic) -> Archetype)
-> Archetype -> [(Int, Dynamic)] -> Archetype
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Archetype -> (Int, Dynamic) -> Archetype
f Archetype
arch (IntMap Dynamic -> [(Int, Dynamic)]
forall a. IntMap a -> [(Int, a)]
IntMap.toList IntMap Dynamic
cs)