{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}

module Aztecs.ECS.World.Archetypes
  ( ArchetypeID (..),
    Node (..),
    Archetypes (..),
    empty,
    insertArchetype,
    lookupArchetypeId,
    findArchetypeIds,
    lookup,
    find,
    map,
    adjustArchetype,
    insert,
    remove,
  )
where

import Aztecs.ECS.Component (Component (..), ComponentID)
import Aztecs.ECS.Entity (EntityID (..))
import Aztecs.ECS.World.Archetype
  ( Archetype (..),
    insertComponent,
    removeStorages,
  )
import qualified Aztecs.ECS.World.Archetype as A
import Aztecs.ECS.World.Storage.Dynamic (fromAscListDyn, toAscListDyn)
import Control.DeepSeq (NFData (..))
import Data.Dynamic (fromDynamic)
import Data.Foldable (foldl')
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (mapMaybe)
import Data.Set (Set)
import qualified Data.Set as Set
import GHC.Generics (Generic)
import Prelude hiding (all, lookup, map)

-- | `Archetype` ID.
newtype ArchetypeID = ArchetypeID {ArchetypeID -> Int
unArchetypeId :: Int}
  deriving newtype (ArchetypeID -> ArchetypeID -> Bool
(ArchetypeID -> ArchetypeID -> Bool)
-> (ArchetypeID -> ArchetypeID -> Bool) -> Eq ArchetypeID
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ArchetypeID -> ArchetypeID -> Bool
== :: ArchetypeID -> ArchetypeID -> Bool
$c/= :: ArchetypeID -> ArchetypeID -> Bool
/= :: ArchetypeID -> ArchetypeID -> Bool
Eq, Eq ArchetypeID
Eq ArchetypeID =>
(ArchetypeID -> ArchetypeID -> Ordering)
-> (ArchetypeID -> ArchetypeID -> Bool)
-> (ArchetypeID -> ArchetypeID -> Bool)
-> (ArchetypeID -> ArchetypeID -> Bool)
-> (ArchetypeID -> ArchetypeID -> Bool)
-> (ArchetypeID -> ArchetypeID -> ArchetypeID)
-> (ArchetypeID -> ArchetypeID -> ArchetypeID)
-> Ord ArchetypeID
ArchetypeID -> ArchetypeID -> Bool
ArchetypeID -> ArchetypeID -> Ordering
ArchetypeID -> ArchetypeID -> ArchetypeID
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ArchetypeID -> ArchetypeID -> Ordering
compare :: ArchetypeID -> ArchetypeID -> Ordering
$c< :: ArchetypeID -> ArchetypeID -> Bool
< :: ArchetypeID -> ArchetypeID -> Bool
$c<= :: ArchetypeID -> ArchetypeID -> Bool
<= :: ArchetypeID -> ArchetypeID -> Bool
$c> :: ArchetypeID -> ArchetypeID -> Bool
> :: ArchetypeID -> ArchetypeID -> Bool
$c>= :: ArchetypeID -> ArchetypeID -> Bool
>= :: ArchetypeID -> ArchetypeID -> Bool
$cmax :: ArchetypeID -> ArchetypeID -> ArchetypeID
max :: ArchetypeID -> ArchetypeID -> ArchetypeID
$cmin :: ArchetypeID -> ArchetypeID -> ArchetypeID
min :: ArchetypeID -> ArchetypeID -> ArchetypeID
Ord, Int -> ArchetypeID -> ShowS
[ArchetypeID] -> ShowS
ArchetypeID -> String
(Int -> ArchetypeID -> ShowS)
-> (ArchetypeID -> String)
-> ([ArchetypeID] -> ShowS)
-> Show ArchetypeID
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ArchetypeID -> ShowS
showsPrec :: Int -> ArchetypeID -> ShowS
$cshow :: ArchetypeID -> String
show :: ArchetypeID -> String
$cshowList :: [ArchetypeID] -> ShowS
showList :: [ArchetypeID] -> ShowS
Show, ArchetypeID -> ()
(ArchetypeID -> ()) -> NFData ArchetypeID
forall a. (a -> ()) -> NFData a
$crnf :: ArchetypeID -> ()
rnf :: ArchetypeID -> ()
NFData)

-- | Node in `Archetypes`.
data Node = Node
  { -- | Unique set of `ComponentID`s of this `Node`.
    Node -> Set ComponentID
nodeComponentIds :: !(Set ComponentID),
    -- | `Archetype` of this `Node`.
    Node -> Archetype
nodeArchetype :: !Archetype,
    -- | Edges to other `Archetype`s by adding a `ComponentID`.
    Node -> Map ComponentID ArchetypeID
nodeAdd :: !(Map ComponentID ArchetypeID),
    -- | Edges to other `Archetype`s by removing a `ComponentID`.
    Node -> Map ComponentID ArchetypeID
nodeRemove :: !(Map ComponentID ArchetypeID)
  }
  deriving (Int -> Node -> ShowS
[Node] -> ShowS
Node -> String
(Int -> Node -> ShowS)
-> (Node -> String) -> ([Node] -> ShowS) -> Show Node
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Node -> ShowS
showsPrec :: Int -> Node -> ShowS
$cshow :: Node -> String
show :: Node -> String
$cshowList :: [Node] -> ShowS
showList :: [Node] -> ShowS
Show, (forall x. Node -> Rep Node x)
-> (forall x. Rep Node x -> Node) -> Generic Node
forall x. Rep Node x -> Node
forall x. Node -> Rep Node x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Node -> Rep Node x
from :: forall x. Node -> Rep Node x
$cto :: forall x. Rep Node x -> Node
to :: forall x. Rep Node x -> Node
Generic, Node -> ()
(Node -> ()) -> NFData Node
forall a. (a -> ()) -> NFData a
$crnf :: Node -> ()
rnf :: Node -> ()
NFData)

-- | `Archetype` graph.
data Archetypes = Archetypes
  { -- | Archetype nodes in the graph.
    Archetypes -> Map ArchetypeID Node
nodes :: !(Map ArchetypeID Node),
    -- | Mapping of unique `ComponentID` sets to `ArchetypeID`s.
    Archetypes -> Map (Set ComponentID) ArchetypeID
archetypeIds :: !(Map (Set ComponentID) ArchetypeID),
    -- | Next unique `ArchetypeID`.
    Archetypes -> ArchetypeID
nextArchetypeId :: !ArchetypeID,
    -- | Mapping of `ComponentID`s to `ArchetypeID`s of `Archetypes` that contain them.
    Archetypes -> Map ComponentID (Set ArchetypeID)
componentIds :: !(Map ComponentID (Set ArchetypeID))
  }
  deriving (Int -> Archetypes -> ShowS
[Archetypes] -> ShowS
Archetypes -> String
(Int -> Archetypes -> ShowS)
-> (Archetypes -> String)
-> ([Archetypes] -> ShowS)
-> Show Archetypes
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Archetypes -> ShowS
showsPrec :: Int -> Archetypes -> ShowS
$cshow :: Archetypes -> String
show :: Archetypes -> String
$cshowList :: [Archetypes] -> ShowS
showList :: [Archetypes] -> ShowS
Show, (forall x. Archetypes -> Rep Archetypes x)
-> (forall x. Rep Archetypes x -> Archetypes) -> Generic Archetypes
forall x. Rep Archetypes x -> Archetypes
forall x. Archetypes -> Rep Archetypes x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Archetypes -> Rep Archetypes x
from :: forall x. Archetypes -> Rep Archetypes x
$cto :: forall x. Rep Archetypes x -> Archetypes
to :: forall x. Rep Archetypes x -> Archetypes
Generic, Archetypes -> ()
(Archetypes -> ()) -> NFData Archetypes
forall a. (a -> ()) -> NFData a
$crnf :: Archetypes -> ()
rnf :: Archetypes -> ()
NFData)

-- | Empty `Archetypes`.
empty :: Archetypes
empty :: Archetypes
empty =
  Archetypes
    { nodes :: Map ArchetypeID Node
nodes = Map ArchetypeID Node
forall a. Monoid a => a
mempty,
      archetypeIds :: Map (Set ComponentID) ArchetypeID
archetypeIds = Map (Set ComponentID) ArchetypeID
forall a. Monoid a => a
mempty,
      nextArchetypeId :: ArchetypeID
nextArchetypeId = Int -> ArchetypeID
ArchetypeID Int
0,
      componentIds :: Map ComponentID (Set ArchetypeID)
componentIds = Map ComponentID (Set ArchetypeID)
forall a. Monoid a => a
mempty
    }

-- | Insert an archetype by its set of `ComponentID`s.
insertArchetype :: Set ComponentID -> Node -> Archetypes -> (ArchetypeID, Archetypes)
insertArchetype :: Set ComponentID -> Node -> Archetypes -> (ArchetypeID, Archetypes)
insertArchetype Set ComponentID
cIds Node
n Archetypes
arches =
  let aId :: ArchetypeID
aId = Archetypes -> ArchetypeID
nextArchetypeId Archetypes
arches
   in ( ArchetypeID
aId,
        Archetypes
arches
          { nodes = Map.insert aId n (nodes arches),
            archetypeIds = Map.insert cIds aId (archetypeIds arches),
            nextArchetypeId = ArchetypeID (unArchetypeId aId + 1),
            componentIds = Map.unionWith (<>) (Map.fromSet (const (Set.singleton aId)) cIds) (componentIds arches)
          }
      )

adjustArchetype :: ArchetypeID -> (Archetype -> Archetype) -> Archetypes -> Archetypes
adjustArchetype :: ArchetypeID -> (Archetype -> Archetype) -> Archetypes -> Archetypes
adjustArchetype ArchetypeID
aId Archetype -> Archetype
f Archetypes
arches = Archetypes
arches {nodes = Map.adjust (\Node
node -> Node
node {nodeArchetype = f (nodeArchetype node)}) aId (nodes arches)}

-- | Find `ArchetypeID`s containing a set of `ComponentID`s.
findArchetypeIds :: Set ComponentID -> Archetypes -> Set ArchetypeID
findArchetypeIds :: Set ComponentID -> Archetypes -> Set ArchetypeID
findArchetypeIds Set ComponentID
cIds Archetypes
arches = case (ComponentID -> Maybe (Set ArchetypeID))
-> [ComponentID] -> [Set ArchetypeID]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\ComponentID
cId -> ComponentID
-> Map ComponentID (Set ArchetypeID) -> Maybe (Set ArchetypeID)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ComponentID
cId (Archetypes -> Map ComponentID (Set ArchetypeID)
componentIds Archetypes
arches)) (Set ComponentID -> [ComponentID]
forall a. Set a -> [a]
Set.elems Set ComponentID
cIds) of
  (Set ArchetypeID
aId : [Set ArchetypeID]
aIds') -> (Set ArchetypeID -> Set ArchetypeID -> Set ArchetypeID)
-> Set ArchetypeID -> [Set ArchetypeID] -> Set ArchetypeID
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Set ArchetypeID -> Set ArchetypeID -> Set ArchetypeID
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection Set ArchetypeID
aId [Set ArchetypeID]
aIds'
  [] -> Set ArchetypeID
forall a. Set a
Set.empty

-- | Lookup `Archetype`s containing a set of `ComponentID`s.
find :: Set ComponentID -> Archetypes -> Map ArchetypeID Node
find :: Set ComponentID -> Archetypes -> Map ArchetypeID Node
find Set ComponentID
cIds Archetypes
arches = (ArchetypeID -> Node) -> Set ArchetypeID -> Map ArchetypeID Node
forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (\ArchetypeID
aId -> Archetypes -> Map ArchetypeID Node
nodes Archetypes
arches Map ArchetypeID Node -> ArchetypeID -> Node
forall k a. Ord k => Map k a -> k -> a
Map.! ArchetypeID
aId) (Set ComponentID -> Archetypes -> Set ArchetypeID
findArchetypeIds Set ComponentID
cIds Archetypes
arches)

-- | Map over `Archetype`s containing a set of `ComponentID`s.
map :: Set ComponentID -> (Archetype -> (a, Archetype)) -> Archetypes -> ([a], Archetypes)
map :: forall a.
Set ComponentID
-> (Archetype -> (a, Archetype)) -> Archetypes -> ([a], Archetypes)
map Set ComponentID
cIds Archetype -> (a, Archetype)
f Archetypes
arches =
  let go :: ([a], Archetypes) -> ArchetypeID -> ([a], Archetypes)
go ([a]
acc, Archetypes
archAcc) ArchetypeID
aId =
        let !node :: Node
node = Archetypes -> Map ArchetypeID Node
nodes Archetypes
archAcc Map ArchetypeID Node -> ArchetypeID -> Node
forall k a. Ord k => Map k a -> k -> a
Map.! ArchetypeID
aId
            !(a
a, Archetype
arch') = Archetype -> (a, Archetype)
f (Node -> Archetype
nodeArchetype Node
node)
            nodes' :: Map ArchetypeID Node
nodes' = ArchetypeID -> Node -> Map ArchetypeID Node -> Map ArchetypeID Node
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ArchetypeID
aId (Node
node {nodeArchetype = arch'}) (Archetypes -> Map ArchetypeID Node
nodes Archetypes
archAcc)
         in (a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
acc, Archetypes
archAcc {nodes = nodes'})
   in (([a], Archetypes) -> ArchetypeID -> ([a], Archetypes))
-> ([a], Archetypes) -> Set ArchetypeID -> ([a], Archetypes)
forall b a. (b -> a -> b) -> b -> Set a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ([a], Archetypes) -> ArchetypeID -> ([a], Archetypes)
go ([], Archetypes
arches) (Set ArchetypeID -> ([a], Archetypes))
-> Set ArchetypeID -> ([a], Archetypes)
forall a b. (a -> b) -> a -> b
$ Set ComponentID -> Archetypes -> Set ArchetypeID
findArchetypeIds Set ComponentID
cIds Archetypes
arches

lookupArchetypeId :: Set ComponentID -> Archetypes -> Maybe ArchetypeID
lookupArchetypeId :: Set ComponentID -> Archetypes -> Maybe ArchetypeID
lookupArchetypeId Set ComponentID
cIds Archetypes
arches = Set ComponentID
-> Map (Set ComponentID) ArchetypeID -> Maybe ArchetypeID
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Set ComponentID
cIds (Archetypes -> Map (Set ComponentID) ArchetypeID
archetypeIds Archetypes
arches)

lookup :: ArchetypeID -> Archetypes -> Maybe Node
lookup :: ArchetypeID -> Archetypes -> Maybe Node
lookup ArchetypeID
aId Archetypes
arches = ArchetypeID -> Map ArchetypeID Node -> Maybe Node
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ArchetypeID
aId (Archetypes -> Map ArchetypeID Node
nodes Archetypes
arches)

-- | Insert a component into an entity with its `ComponentID`.
insert ::
  (Component a) =>
  EntityID ->
  ArchetypeID ->
  ComponentID ->
  a ->
  Archetypes ->
  (Maybe ArchetypeID, Archetypes)
insert :: forall a.
Component a =>
EntityID
-> ArchetypeID
-> ComponentID
-> a
-> Archetypes
-> (Maybe ArchetypeID, Archetypes)
insert EntityID
e ArchetypeID
aId ComponentID
cId a
c Archetypes
arches = case ArchetypeID -> Archetypes -> Maybe Node
lookup ArchetypeID
aId Archetypes
arches of
  Just Node
node ->
    if ComponentID -> Set ComponentID -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member ComponentID
cId (Node -> Set ComponentID
nodeComponentIds Node
node)
      then
        let go :: Node -> Node
go Node
n = Node
n {nodeArchetype = insertComponent e cId c (nodeArchetype n)}
         in (Maybe ArchetypeID
forall a. Maybe a
Nothing, Archetypes
arches {nodes = Map.adjust go aId (nodes arches)})
      else case Set ComponentID -> Archetypes -> Maybe ArchetypeID
lookupArchetypeId (ComponentID -> Set ComponentID -> Set ComponentID
forall a. Ord a => a -> Set a -> Set a
Set.insert ComponentID
cId (Node -> Set ComponentID
nodeComponentIds Node
node)) Archetypes
arches of
        Just ArchetypeID
nextAId ->
          let !(Map ComponentID Dynamic
cs, Archetype
arch') = EntityID -> Archetype -> (Map ComponentID Dynamic, Archetype)
A.remove EntityID
e (Node -> Archetype
nodeArchetype Node
node)
              node' :: Node
node' = Node
node {nodeArchetype = arch'}
              !arches' :: Archetypes
arches' = Archetypes
arches {nodes = Map.insert aId node' (nodes arches)}
              f :: Archetype -> (ComponentID, Dynamic) -> Archetype
f Archetype
archAcc (ComponentID
itemCId, Dynamic
dyn) =
                let storages' :: Map ComponentID DynamicStorage
storages' = (DynamicStorage -> DynamicStorage)
-> ComponentID
-> Map ComponentID DynamicStorage
-> Map ComponentID DynamicStorage
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust DynamicStorage -> DynamicStorage
go ComponentID
itemCId (Archetype -> Map ComponentID DynamicStorage
storages Archetype
archAcc)
                    go :: DynamicStorage -> DynamicStorage
go DynamicStorage
s = [Dynamic] -> DynamicStorage -> DynamicStorage
fromAscListDyn (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 (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) ([Dynamic] -> [Dynamic]) -> [Dynamic] -> [Dynamic]
forall a b. (a -> b) -> a -> b
$ DynamicStorage -> [Dynamic]
toAscListDyn DynamicStorage
s) DynamicStorage
s
                 in Archetype
archAcc {storages = storages'}
              adjustNode :: Node -> Node
adjustNode Node
nextNode =
                let nextArch :: Archetype
nextArch = (Archetype -> (ComponentID, Dynamic) -> Archetype)
-> Archetype -> [(ComponentID, 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 -> (ComponentID, Dynamic) -> Archetype
f (Node -> Archetype
nodeArchetype Node
nextNode) (Map ComponentID Dynamic -> [(ComponentID, Dynamic)]
forall k a. Map k a -> [(k, a)]
Map.toList Map ComponentID Dynamic
cs)
                 in Node
nextNode {nodeArchetype = insertComponent e cId c nextArch}
           in (ArchetypeID -> Maybe ArchetypeID
forall a. a -> Maybe a
Just ArchetypeID
nextAId, Archetypes
arches' {nodes = Map.adjust adjustNode nextAId (nodes arches')})
        Maybe ArchetypeID
Nothing ->
          let !(Map ComponentID DynamicStorage
s, Archetype
arch') = EntityID
-> Archetype -> (Map ComponentID DynamicStorage, Archetype)
removeStorages EntityID
e (Node -> Archetype
nodeArchetype Node
node)
              !n :: Node
n =
                Node
                  { nodeComponentIds :: Set ComponentID
nodeComponentIds = ComponentID -> Set ComponentID -> Set ComponentID
forall a. Ord a => a -> Set a -> Set a
Set.insert ComponentID
cId (Node -> Set ComponentID
nodeComponentIds Node
node),
                    nodeArchetype :: Archetype
nodeArchetype = EntityID -> ComponentID -> a -> Archetype -> Archetype
forall a.
Component a =>
EntityID -> ComponentID -> a -> Archetype -> Archetype
insertComponent EntityID
e ComponentID
cId a
c (Archetype {storages :: Map ComponentID DynamicStorage
storages = Map ComponentID DynamicStorage
s, entities :: Set EntityID
entities = EntityID -> Set EntityID
forall a. a -> Set a
Set.singleton EntityID
e}),
                    nodeAdd :: Map ComponentID ArchetypeID
nodeAdd = Map ComponentID ArchetypeID
forall k a. Map k a
Map.empty,
                    nodeRemove :: Map ComponentID ArchetypeID
nodeRemove = ComponentID -> ArchetypeID -> Map ComponentID ArchetypeID
forall k a. k -> a -> Map k a
Map.singleton ComponentID
cId ArchetypeID
aId
                  }
              cIds :: Set ComponentID
cIds = ComponentID -> Set ComponentID -> Set ComponentID
forall a. Ord a => a -> Set a -> Set a
Set.insert ComponentID
cId (Node -> Set ComponentID
nodeComponentIds Node
node)
              !(ArchetypeID
nextAId, Archetypes
arches') = Set ComponentID -> Node -> Archetypes -> (ArchetypeID, Archetypes)
insertArchetype Set ComponentID
cIds Node
n Archetypes
arches
           in let node' :: Node
node' =
                    Node
node {nodeArchetype = arch', nodeAdd = Map.insert cId nextAId (nodeAdd node)}
                  nodes' :: Map ArchetypeID Node
nodes' = ArchetypeID -> Node -> Map ArchetypeID Node -> Map ArchetypeID Node
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ArchetypeID
aId Node
node' (Archetypes -> Map ArchetypeID Node
nodes Archetypes
arches')
               in (ArchetypeID -> Maybe ArchetypeID
forall a. a -> Maybe a
Just ArchetypeID
nextAId, Archetypes
arches' {nodes = nodes'})
  Maybe Node
Nothing -> (Maybe ArchetypeID
forall a. Maybe a
Nothing, Archetypes
arches)

remove ::
  (Component a) =>
  EntityID ->
  ArchetypeID ->
  ComponentID ->
  Archetypes ->
  (Maybe (a, ArchetypeID), Archetypes)
remove :: forall a.
Component a =>
EntityID
-> ArchetypeID
-> ComponentID
-> Archetypes
-> (Maybe (a, ArchetypeID), Archetypes)
remove EntityID
e ArchetypeID
aId ComponentID
cId Archetypes
arches = case ArchetypeID -> Archetypes -> Maybe Node
lookup ArchetypeID
aId Archetypes
arches of
  Just Node
node -> case Set ComponentID -> Archetypes -> Maybe ArchetypeID
lookupArchetypeId (ComponentID -> Set ComponentID -> Set ComponentID
forall a. Ord a => a -> Set a -> Set a
Set.delete ComponentID
cId (Node -> Set ComponentID
nodeComponentIds Node
node)) Archetypes
arches of
    Just ArchetypeID
nextAId ->
      let !(Map ComponentID Dynamic
cs, Archetype
arch') = EntityID -> Archetype -> (Map ComponentID Dynamic, Archetype)
A.remove EntityID
e (Node -> Archetype
nodeArchetype Node
node)
          !arches' :: Archetypes
arches' = Archetypes
arches {nodes = Map.insert aId node {nodeArchetype = arch'} (nodes arches)}
          (Maybe Dynamic
a, Map ComponentID Dynamic
cs') = (ComponentID -> Dynamic -> Maybe Dynamic)
-> ComponentID
-> Map ComponentID Dynamic
-> (Maybe Dynamic, Map ComponentID Dynamic)
forall k a.
Ord k =>
(k -> a -> Maybe a) -> k -> Map k a -> (Maybe a, Map k a)
Map.updateLookupWithKey (\ComponentID
_ Dynamic
_ -> Maybe Dynamic
forall a. Maybe a
Nothing) ComponentID
cId Map ComponentID Dynamic
cs
          go' :: Archetype -> (ComponentID, Dynamic) -> Archetype
go' Archetype
archAcc (ComponentID
itemCId, Dynamic
dyn) =
            let adjustStorage :: DynamicStorage -> DynamicStorage
adjustStorage DynamicStorage
s = [Dynamic] -> DynamicStorage -> DynamicStorage
fromAscListDyn (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 (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) ([Dynamic] -> [Dynamic]) -> [Dynamic] -> [Dynamic]
forall a b. (a -> b) -> a -> b
$ DynamicStorage -> [Dynamic]
toAscListDyn DynamicStorage
s) DynamicStorage
s
             in Archetype
archAcc {storages = Map.adjust adjustStorage itemCId (storages archAcc)}
          go :: Node -> Node
go Node
nextNode =
            Node
nextNode {nodeArchetype = foldl' go' (nodeArchetype nextNode) (Map.toList cs')}
       in ( (,ArchetypeID
nextAId) (a -> (a, ArchetypeID)) -> Maybe a -> Maybe (a, ArchetypeID)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe Dynamic
a Maybe Dynamic -> (Dynamic -> Maybe a) -> Maybe a
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Dynamic -> Maybe a
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic),
            Archetypes
arches' {nodes = Map.adjust go nextAId (nodes arches')}
          )
    Maybe ArchetypeID
Nothing ->
      let !(Map ComponentID DynamicStorage
cs, Archetype
arch') = EntityID
-> Archetype -> (Map ComponentID DynamicStorage, Archetype)
removeStorages EntityID
e (Node -> Archetype
nodeArchetype Node
node)
          (Maybe DynamicStorage
a, Map ComponentID DynamicStorage
cs') = (ComponentID -> DynamicStorage -> Maybe DynamicStorage)
-> ComponentID
-> Map ComponentID DynamicStorage
-> (Maybe DynamicStorage, Map ComponentID DynamicStorage)
forall k a.
Ord k =>
(k -> a -> Maybe a) -> k -> Map k a -> (Maybe a, Map k a)
Map.updateLookupWithKey (\ComponentID
_ DynamicStorage
_ -> Maybe DynamicStorage
forall a. Maybe a
Nothing) ComponentID
cId Map ComponentID DynamicStorage
cs
          !n :: Node
n =
            Node
              { nodeComponentIds :: Set ComponentID
nodeComponentIds = ComponentID -> Set ComponentID -> Set ComponentID
forall a. Ord a => a -> Set a -> Set a
Set.insert ComponentID
cId (Node -> Set ComponentID
nodeComponentIds Node
node),
                nodeArchetype :: Archetype
nodeArchetype = Archetype {storages :: Map ComponentID DynamicStorage
storages = Map ComponentID DynamicStorage
cs', entities :: Set EntityID
entities = EntityID -> Set EntityID
forall a. a -> Set a
Set.singleton EntityID
e},
                nodeAdd :: Map ComponentID ArchetypeID
nodeAdd = Map ComponentID ArchetypeID
forall k a. Map k a
Map.empty,
                nodeRemove :: Map ComponentID ArchetypeID
nodeRemove = ComponentID -> ArchetypeID -> Map ComponentID ArchetypeID
forall k a. k -> a -> Map k a
Map.singleton ComponentID
cId ArchetypeID
aId
              }
          !(ArchetypeID
nextAId, Archetypes
arches') = Set ComponentID -> Node -> Archetypes -> (ArchetypeID, Archetypes)
insertArchetype (ComponentID -> Set ComponentID -> Set ComponentID
forall a. Ord a => a -> Set a -> Set a
Set.insert ComponentID
cId (Node -> Set ComponentID
nodeComponentIds Node
node)) Node
n Archetypes
arches
          node' :: Node
node' = Node
node {nodeArchetype = arch', nodeAdd = Map.insert cId nextAId (nodeAdd node)}
          removeDyn :: DynamicStorage -> (Maybe Dynamic, DynamicStorage -> DynamicStorage)
removeDyn DynamicStorage
s =
            let (Maybe Dynamic
res, Map EntityID Dynamic
dyns) = (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 -> (Maybe Dynamic, Map EntityID Dynamic))
-> ([Dynamic] -> Map EntityID Dynamic)
-> [Dynamic]
-> (Maybe 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 (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] -> (Maybe Dynamic, Map EntityID Dynamic))
-> [Dynamic] -> (Maybe Dynamic, Map EntityID Dynamic)
forall a b. (a -> b) -> a -> b
$ DynamicStorage -> [Dynamic]
toAscListDyn DynamicStorage
s
             in (Maybe Dynamic
res, [Dynamic] -> DynamicStorage -> DynamicStorage
fromAscListDyn ([Dynamic] -> DynamicStorage -> DynamicStorage)
-> [Dynamic] -> DynamicStorage -> DynamicStorage
forall a b. (a -> b) -> a -> b
$ Map EntityID Dynamic -> [Dynamic]
forall k a. Map k a -> [a]
Map.elems Map EntityID Dynamic
dyns)
       in ( (,ArchetypeID
nextAId) (a -> (a, ArchetypeID)) -> Maybe a -> Maybe (a, ArchetypeID)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe DynamicStorage
a Maybe DynamicStorage -> (DynamicStorage -> Maybe a) -> Maybe a
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\DynamicStorage
a' -> (Maybe Dynamic, DynamicStorage -> DynamicStorage) -> Maybe Dynamic
forall a b. (a, b) -> a
fst (DynamicStorage -> (Maybe Dynamic, DynamicStorage -> DynamicStorage)
removeDyn DynamicStorage
a') Maybe Dynamic -> (Dynamic -> Maybe a) -> Maybe a
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Dynamic -> Maybe a
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic)),
            Archetypes
arches' {nodes = Map.insert aId node' (nodes arches')}
          )
  Maybe Node
Nothing -> (Maybe (a, ArchetypeID)
forall a. Maybe a
Nothing, Archetypes
arches)