{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Data.Aztecs.World.Archetypes
  ( Archetype (..),
    ArchetypeComponent (..),
    ArchetypeComponents (..),
    getArchetypeComponent,
    ArchetypeState (..),
    ArchetypeId (..),
    Archetypes (..),
    newArchetypes,
    archetype,
    insertArchetype,
    getArchetype,
    insert,
  )
where

import Data.Aztecs.Core
import qualified Data.Aztecs.Storage as S
import Data.Aztecs.World.Components (Component, Components, getRow)
import qualified Data.Aztecs.World.Components as C
import Data.Dynamic (Dynamic, fromDynamic, toDyn)
import Data.Foldable (foldrM)
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe, isJust)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Typeable
import Prelude hiding (read)

data ArchetypeComponent where
  ArchetypeComponent :: (Component c) => Proxy c -> ArchetypeComponent

instance Eq ArchetypeComponent where
  ArchetypeComponent Proxy c
a == :: ArchetypeComponent -> ArchetypeComponent -> Bool
== ArchetypeComponent Proxy c
b = Proxy c -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf Proxy c
a TypeRep -> TypeRep -> Bool
forall a. Eq a => a -> a -> Bool
== Proxy c -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf Proxy c
b

instance Ord ArchetypeComponent where
  ArchetypeComponent Proxy c
a compare :: ArchetypeComponent -> ArchetypeComponent -> Ordering
`compare` ArchetypeComponent Proxy c
b = Proxy c -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf Proxy c
a TypeRep -> TypeRep -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Proxy c -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf Proxy c
b

instance Show ArchetypeComponent where
  show :: ArchetypeComponent -> String
show (ArchetypeComponent Proxy c
p) = TypeRep -> String
forall a. Show a => a -> String
show (Proxy c -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf Proxy c
p)

newtype Archetype = Archetype (Set ArchetypeComponent)
  deriving (Archetype -> Archetype -> Bool
(Archetype -> Archetype -> Bool)
-> (Archetype -> Archetype -> Bool) -> Eq Archetype
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Archetype -> Archetype -> Bool
== :: Archetype -> Archetype -> Bool
$c/= :: Archetype -> Archetype -> Bool
/= :: Archetype -> Archetype -> Bool
Eq, Eq Archetype
Eq Archetype =>
(Archetype -> Archetype -> Ordering)
-> (Archetype -> Archetype -> Bool)
-> (Archetype -> Archetype -> Bool)
-> (Archetype -> Archetype -> Bool)
-> (Archetype -> Archetype -> Bool)
-> (Archetype -> Archetype -> Archetype)
-> (Archetype -> Archetype -> Archetype)
-> Ord Archetype
Archetype -> Archetype -> Bool
Archetype -> Archetype -> Ordering
Archetype -> Archetype -> Archetype
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 :: Archetype -> Archetype -> Ordering
compare :: Archetype -> Archetype -> Ordering
$c< :: Archetype -> Archetype -> Bool
< :: Archetype -> Archetype -> Bool
$c<= :: Archetype -> Archetype -> Bool
<= :: Archetype -> Archetype -> Bool
$c> :: Archetype -> Archetype -> Bool
> :: Archetype -> Archetype -> Bool
$c>= :: Archetype -> Archetype -> Bool
>= :: Archetype -> Archetype -> Bool
$cmax :: Archetype -> Archetype -> Archetype
max :: Archetype -> Archetype -> Archetype
$cmin :: Archetype -> Archetype -> Archetype
min :: Archetype -> Archetype -> Archetype
Ord, 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, Semigroup Archetype
Archetype
Semigroup Archetype =>
Archetype
-> (Archetype -> Archetype -> Archetype)
-> ([Archetype] -> Archetype)
-> Monoid Archetype
[Archetype] -> Archetype
Archetype -> Archetype -> Archetype
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: Archetype
mempty :: Archetype
$cmappend :: Archetype -> Archetype -> Archetype
mappend :: Archetype -> Archetype -> Archetype
$cmconcat :: [Archetype] -> Archetype
mconcat :: [Archetype] -> Archetype
Monoid, NonEmpty Archetype -> Archetype
Archetype -> Archetype -> Archetype
(Archetype -> Archetype -> Archetype)
-> (NonEmpty Archetype -> Archetype)
-> (forall b. Integral b => b -> Archetype -> Archetype)
-> Semigroup Archetype
forall b. Integral b => b -> Archetype -> Archetype
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: Archetype -> Archetype -> Archetype
<> :: Archetype -> Archetype -> Archetype
$csconcat :: NonEmpty Archetype -> Archetype
sconcat :: NonEmpty Archetype -> Archetype
$cstimes :: forall b. Integral b => b -> Archetype -> Archetype
stimes :: forall b. Integral b => b -> Archetype -> Archetype
Semigroup)

archetype :: forall c. (Component c) => Archetype
archetype :: forall c. Component c => Archetype
archetype = Set ArchetypeComponent -> Archetype
Archetype (Set ArchetypeComponent -> Archetype)
-> (ArchetypeComponent -> Set ArchetypeComponent)
-> ArchetypeComponent
-> Archetype
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArchetypeComponent -> Set ArchetypeComponent
forall a. a -> Set a
Set.singleton (ArchetypeComponent -> Archetype)
-> ArchetypeComponent -> Archetype
forall a b. (a -> b) -> a -> b
$ Proxy c -> ArchetypeComponent
forall c. Component c => Proxy c -> ArchetypeComponent
ArchetypeComponent (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @c)

newtype ArchetypeId = ArchetypeId Int deriving (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)

newtype ArchetypeComponents = ArchetypeComponents (Map TypeRep Dynamic)
  deriving (Int -> ArchetypeComponents -> ShowS
[ArchetypeComponents] -> ShowS
ArchetypeComponents -> String
(Int -> ArchetypeComponents -> ShowS)
-> (ArchetypeComponents -> String)
-> ([ArchetypeComponents] -> ShowS)
-> Show ArchetypeComponents
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ArchetypeComponents -> ShowS
showsPrec :: Int -> ArchetypeComponents -> ShowS
$cshow :: ArchetypeComponents -> String
show :: ArchetypeComponents -> String
$cshowList :: [ArchetypeComponents] -> ShowS
showList :: [ArchetypeComponents] -> ShowS
Show)

getArchetypeComponent :: forall c. (Component c) => ArchetypeComponents -> Maybe (c, c -> IO ())
getArchetypeComponent :: forall c.
Component c =>
ArchetypeComponents -> Maybe (c, c -> IO ())
getArchetypeComponent (ArchetypeComponents Map TypeRep Dynamic
m) = do
  Dynamic
d <- TypeRep -> Map TypeRep Dynamic -> Maybe Dynamic
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Proxy c -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @c)) Map TypeRep Dynamic
m
  Dynamic -> Maybe (c, c -> IO ())
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic Dynamic
d

insertArchetypeComponent :: forall c. (Component c) => c -> (c -> IO ()) -> ArchetypeComponents -> ArchetypeComponents
insertArchetypeComponent :: forall c.
Component c =>
c -> (c -> IO ()) -> ArchetypeComponents -> ArchetypeComponents
insertArchetypeComponent c
c c -> IO ()
f (ArchetypeComponents Map TypeRep Dynamic
m) = Map TypeRep Dynamic -> ArchetypeComponents
ArchetypeComponents (Map TypeRep Dynamic -> ArchetypeComponents)
-> Map TypeRep Dynamic -> ArchetypeComponents
forall a b. (a -> b) -> a -> b
$ TypeRep -> Dynamic -> Map TypeRep Dynamic -> Map TypeRep Dynamic
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Proxy c -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @c)) ((c, c -> IO ()) -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn (c
c, c -> IO ()
f)) Map TypeRep Dynamic
m

data ArchetypeState = ArchetypeState Archetype (Map Entity ArchetypeComponents) [ArchetypeId]
  deriving (Int -> ArchetypeState -> ShowS
[ArchetypeState] -> ShowS
ArchetypeState -> String
(Int -> ArchetypeState -> ShowS)
-> (ArchetypeState -> String)
-> ([ArchetypeState] -> ShowS)
-> Show ArchetypeState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ArchetypeState -> ShowS
showsPrec :: Int -> ArchetypeState -> ShowS
$cshow :: ArchetypeState -> String
show :: ArchetypeState -> String
$cshowList :: [ArchetypeState] -> ShowS
showList :: [ArchetypeState] -> ShowS
Show)

data Archetypes
  = Archetypes
      (IntMap ArchetypeState)
      (Map TypeRep [ArchetypeId])
      (Map Archetype ArchetypeId)
      Int
  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)

newArchetypes :: Archetypes
newArchetypes :: Archetypes
newArchetypes = IntMap ArchetypeState
-> Map TypeRep [ArchetypeId]
-> Map Archetype ArchetypeId
-> Int
-> Archetypes
Archetypes IntMap ArchetypeState
forall a. IntMap a
IntMap.empty Map TypeRep [ArchetypeId]
forall k a. Map k a
Map.empty Map Archetype ArchetypeId
forall k a. Map k a
Map.empty Int
0

insertArchetype :: Archetype -> Components -> Archetypes -> IO (ArchetypeId, Archetypes)
insertArchetype :: Archetype
-> Components -> Archetypes -> IO (ArchetypeId, Archetypes)
insertArchetype (Archetype Set ArchetypeComponent
a) Components
w (Archetypes IntMap ArchetypeState
es Map TypeRep [ArchetypeId]
ids Map Archetype ArchetypeId
as Int
i) = case Archetype -> Map Archetype ArchetypeId -> Maybe ArchetypeId
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Set ArchetypeComponent -> Archetype
Archetype Set ArchetypeComponent
a) Map Archetype ArchetypeId
as of
  Just (ArchetypeId Int
i') -> (ArchetypeId, Archetypes) -> IO (ArchetypeId, Archetypes)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> ArchetypeId
ArchetypeId Int
i, IntMap ArchetypeState
-> Map TypeRep [ArchetypeId]
-> Map Archetype ArchetypeId
-> Int
-> Archetypes
Archetypes IntMap ArchetypeState
es Map TypeRep [ArchetypeId]
ids Map Archetype ArchetypeId
as Int
i')
  Maybe ArchetypeId
Nothing -> do
    ([(Entity, ArchetypeComponents)]
es', Map TypeRep [ArchetypeId]
ids') <-
      (ArchetypeComponent
 -> ([(Entity, ArchetypeComponents)], Map TypeRep [ArchetypeId])
 -> IO ([(Entity, ArchetypeComponents)], Map TypeRep [ArchetypeId]))
-> ([(Entity, ArchetypeComponents)], Map TypeRep [ArchetypeId])
-> [ArchetypeComponent]
-> IO ([(Entity, ArchetypeComponents)], Map TypeRep [ArchetypeId])
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM
        ( \(ArchetypeComponent Proxy c
p) ([(Entity, ArchetypeComponents)]
eAcc, Map TypeRep [ArchetypeId]
acc) -> do
            [(EntityComponent c, c -> IO ())]
cs <- IO [(EntityComponent c, c -> IO ())]
-> Maybe (IO [(EntityComponent c, c -> IO ())])
-> IO [(EntityComponent c, c -> IO ())]
forall a. a -> Maybe a -> a
fromMaybe ([(EntityComponent c, c -> IO ())]
-> IO [(EntityComponent c, c -> IO ())]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) (Maybe (IO [(EntityComponent c, c -> IO ())])
 -> IO [(EntityComponent c, c -> IO ())])
-> Maybe (IO [(EntityComponent c, c -> IO ())])
-> IO [(EntityComponent c, c -> IO ())]
forall a b. (a -> b) -> a -> b
$ (Storage c -> IO [(EntityComponent c, c -> IO ())])
-> Maybe (Storage c)
-> Maybe (IO [(EntityComponent c, c -> IO ())])
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Storage c
s -> Storage c -> IO [(EntityComponent c, c -> IO ())]
forall a. Storage a -> IO [(EntityComponent a, a -> IO ())]
S.toList' Storage c
s) (Proxy c -> Components -> Maybe (Storage c)
forall c. Component c => Proxy c -> Components -> Maybe (Storage c)
getRow Proxy c
p Components
w)
            let eAcc' :: [(Entity, ArchetypeComponents)]
eAcc' = ((EntityComponent c, c -> IO ()) -> (Entity, ArchetypeComponents))
-> [(EntityComponent c, c -> IO ())]
-> [(Entity, ArchetypeComponents)]
forall a b. (a -> b) -> [a] -> [b]
map (\(EntityComponent Entity
e c
c, c -> IO ()
f) -> (Entity
e, c -> (c -> IO ()) -> ArchetypeComponents -> ArchetypeComponents
forall c.
Component c =>
c -> (c -> IO ()) -> ArchetypeComponents -> ArchetypeComponents
insertArchetypeComponent c
c c -> IO ()
f (Map TypeRep Dynamic -> ArchetypeComponents
ArchetypeComponents Map TypeRep Dynamic
forall a. Monoid a => a
mempty))) [(EntityComponent c, c -> IO ())]
cs
            ([(Entity, ArchetypeComponents)], Map TypeRep [ArchetypeId])
-> IO ([(Entity, ArchetypeComponents)], Map TypeRep [ArchetypeId])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Entity, ArchetypeComponents)]
eAcc' [(Entity, ArchetypeComponents)]
-> [(Entity, ArchetypeComponents)]
-> [(Entity, ArchetypeComponents)]
forall a. [a] -> [a] -> [a]
++ [(Entity, ArchetypeComponents)]
eAcc, ([ArchetypeId] -> [ArchetypeId] -> [ArchetypeId])
-> Map TypeRep [ArchetypeId]
-> Map TypeRep [ArchetypeId]
-> Map TypeRep [ArchetypeId]
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith [ArchetypeId] -> [ArchetypeId] -> [ArchetypeId]
forall a. Semigroup a => a -> a -> a
(<>) (TypeRep -> [ArchetypeId] -> Map TypeRep [ArchetypeId]
forall k a. k -> a -> Map k a
Map.singleton (Proxy c -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf Proxy c
p) [Int -> ArchetypeId
ArchetypeId Int
i]) Map TypeRep [ArchetypeId]
acc)
        )
        ([], Map TypeRep [ArchetypeId]
ids)
        (Set ArchetypeComponent -> [ArchetypeComponent]
forall a. Set a -> [a]
Set.toList Set ArchetypeComponent
a)
    (ArchetypeId, Archetypes) -> IO (ArchetypeId, Archetypes)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> ArchetypeId
ArchetypeId Int
i, IntMap ArchetypeState
-> Map TypeRep [ArchetypeId]
-> Map Archetype ArchetypeId
-> Int
-> Archetypes
Archetypes (Int
-> ArchetypeState -> IntMap ArchetypeState -> IntMap ArchetypeState
forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
i (Archetype
-> Map Entity ArchetypeComponents
-> [ArchetypeId]
-> ArchetypeState
ArchetypeState (Set ArchetypeComponent -> Archetype
Archetype Set ArchetypeComponent
a) ([(Entity, ArchetypeComponents)] -> Map Entity ArchetypeComponents
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Entity, ArchetypeComponents)]
es') []) IntMap ArchetypeState
es) Map TypeRep [ArchetypeId]
ids' Map Archetype ArchetypeId
as (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))

getArchetype :: ArchetypeId -> Archetypes -> Maybe ArchetypeState
getArchetype :: ArchetypeId -> Archetypes -> Maybe ArchetypeState
getArchetype (ArchetypeId Int
i) (Archetypes IntMap ArchetypeState
es Map TypeRep [ArchetypeId]
_ Map Archetype ArchetypeId
_ Int
_) = Int -> IntMap ArchetypeState -> Maybe ArchetypeState
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
i IntMap ArchetypeState
es

insert :: forall c. (Component c) => Entity -> Components -> Archetypes -> Archetypes
insert :: forall c.
Component c =>
Entity -> Components -> Archetypes -> Archetypes
insert Entity
e Components
cs (Archetypes IntMap ArchetypeState
es Map TypeRep [ArchetypeId]
ids Map Archetype ArchetypeId
as Int
j) = case TypeRep -> Map TypeRep [ArchetypeId] -> Maybe [ArchetypeId]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Proxy c -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @c)) Map TypeRep [ArchetypeId]
ids of
  Just ([ArchetypeId]
ids') ->
    let insertInArchetype :: Int -> IntMap ArchetypeState -> IntMap ArchetypeState
        insertInArchetype :: Int -> IntMap ArchetypeState -> IntMap ArchetypeState
insertInArchetype Int
archetypeId IntMap ArchetypeState
acc =
          (Maybe ArchetypeState -> Maybe ArchetypeState)
-> Int -> IntMap ArchetypeState -> IntMap ArchetypeState
forall a. (Maybe a -> Maybe a) -> Int -> IntMap a -> IntMap a
IntMap.alter (Int -> Maybe ArchetypeState -> Maybe ArchetypeState
updateArchetypeState Int
archetypeId) Int
archetypeId IntMap ArchetypeState
acc

        updateArchetypeState :: Int -> Maybe ArchetypeState -> Maybe ArchetypeState
        updateArchetypeState :: Int -> Maybe ArchetypeState -> Maybe ArchetypeState
updateArchetypeState Int
_ Maybe ArchetypeState
state = case Maybe ArchetypeState
state of
          Just (ArchetypeState Archetype
arch Map Entity ArchetypeComponents
esAcc [ArchetypeId]
deps) ->
            let isMatch :: Bool
isMatch =
                  (ArchetypeComponent -> Bool) -> [ArchetypeComponent] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all
                    (\(ArchetypeComponent Proxy c
p) -> Maybe (Storage c) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (Storage c) -> Bool) -> Maybe (Storage c) -> Bool
forall a b. (a -> b) -> a -> b
$ Proxy c -> Components -> Maybe (Storage c)
forall c. Component c => Proxy c -> Components -> Maybe (Storage c)
C.getRow Proxy c
p Components
cs)
                    (Set ArchetypeComponent -> [ArchetypeComponent]
forall a. Set a -> [a]
Set.toList (Set ArchetypeComponent -> [ArchetypeComponent])
-> Set ArchetypeComponent -> [ArchetypeComponent]
forall a b. (a -> b) -> a -> b
$ Archetype -> Set ArchetypeComponent
unwrapArchetype Archetype
arch)
             in if Bool
isMatch
                  then
                    ArchetypeState -> Maybe ArchetypeState
forall a. a -> Maybe a
Just (ArchetypeState -> Maybe ArchetypeState)
-> ArchetypeState -> Maybe ArchetypeState
forall a b. (a -> b) -> a -> b
$ Archetype
-> Map Entity ArchetypeComponents
-> [ArchetypeId]
-> ArchetypeState
ArchetypeState Archetype
arch (Entity -> ArchetypeComponents -> Map Entity ArchetypeComponents
forall k a. k -> a -> Map k a
Map.singleton Entity
e (Map TypeRep Dynamic -> ArchetypeComponents
ArchetypeComponents Map TypeRep Dynamic
forall a. Monoid a => a
mempty) Map Entity ArchetypeComponents
-> Map Entity ArchetypeComponents -> Map Entity ArchetypeComponents
forall a. Semigroup a => a -> a -> a
<> Map Entity ArchetypeComponents
esAcc) [ArchetypeId]
deps
                  else Maybe ArchetypeState
state
          Maybe ArchetypeState
Nothing -> Maybe ArchetypeState
state

        updateDependencies :: Int -> IntMap ArchetypeState -> IntMap ArchetypeState
        updateDependencies :: Int -> IntMap ArchetypeState -> IntMap ArchetypeState
updateDependencies Int
archetypeId IntMap ArchetypeState
acc = case Int -> IntMap ArchetypeState -> Maybe ArchetypeState
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
archetypeId IntMap ArchetypeState
acc of
          Just (ArchetypeState Archetype
_ Map Entity ArchetypeComponents
_ [ArchetypeId]
deps) -> (Int -> IntMap ArchetypeState -> IntMap ArchetypeState)
-> IntMap ArchetypeState -> [Int] -> IntMap ArchetypeState
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Int -> IntMap ArchetypeState -> IntMap ArchetypeState
updateDependencies (Int -> IntMap ArchetypeState -> IntMap ArchetypeState
insertInArchetype Int
archetypeId IntMap ArchetypeState
acc) ((ArchetypeId -> Int) -> [ArchetypeId] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ArchetypeId -> Int
getArchetypeId [ArchetypeId]
deps)
          Maybe ArchetypeState
Nothing -> IntMap ArchetypeState
acc
        es' :: IntMap ArchetypeState
es' = (Int -> IntMap ArchetypeState -> IntMap ArchetypeState)
-> IntMap ArchetypeState -> [Int] -> IntMap ArchetypeState
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Int -> IntMap ArchetypeState -> IntMap ArchetypeState
updateDependencies IntMap ArchetypeState
es ((ArchetypeId -> Int) -> [ArchetypeId] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ArchetypeId -> Int
getArchetypeId [ArchetypeId]
ids')
     in Archetypes -> Archetypes
merge (Archetypes -> Archetypes) -> Archetypes -> Archetypes
forall a b. (a -> b) -> a -> b
$ IntMap ArchetypeState
-> Map TypeRep [ArchetypeId]
-> Map Archetype ArchetypeId
-> Int
-> Archetypes
Archetypes IntMap ArchetypeState
es' Map TypeRep [ArchetypeId]
ids Map Archetype ArchetypeId
as Int
j
  Maybe [ArchetypeId]
Nothing -> IntMap ArchetypeState
-> Map TypeRep [ArchetypeId]
-> Map Archetype ArchetypeId
-> Int
-> Archetypes
Archetypes IntMap ArchetypeState
es Map TypeRep [ArchetypeId]
ids Map Archetype ArchetypeId
as Int
j

merge :: Archetypes -> Archetypes
merge :: Archetypes -> Archetypes
merge archetypes :: Archetypes
archetypes@(Archetypes IntMap ArchetypeState
es Map TypeRep [ArchetypeId]
_ Map Archetype ArchetypeId
_ Int
_) =
  (Archetypes -> (Int, ArchetypeState) -> Archetypes)
-> Archetypes -> [(Int, ArchetypeState)] -> Archetypes
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Archetypes -> (Int, ArchetypeState) -> Archetypes
processArchetype Archetypes
archetypes (IntMap ArchetypeState -> [(Int, ArchetypeState)]
forall a. IntMap a -> [(Int, a)]
IntMap.toList IntMap ArchetypeState
es)
  where
    processArchetype :: Archetypes -> (Int, ArchetypeState) -> Archetypes
    processArchetype :: Archetypes -> (Int, ArchetypeState) -> Archetypes
processArchetype Archetypes
acc (Int
parentId, ArchetypeState Archetype
parentArch Map Entity ArchetypeComponents
_ [ArchetypeId]
_) =
      (Archetypes -> (Int, ArchetypeState) -> Archetypes)
-> Archetypes -> [(Int, ArchetypeState)] -> Archetypes
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (Int
-> Archetype -> Archetypes -> (Int, ArchetypeState) -> Archetypes
updateDependency Int
parentId Archetype
parentArch) Archetypes
acc (IntMap ArchetypeState -> [(Int, ArchetypeState)]
forall a. IntMap a -> [(Int, a)]
IntMap.toList IntMap ArchetypeState
es)

    updateDependency :: Int -> Archetype -> Archetypes -> (Int, ArchetypeState) -> Archetypes
    updateDependency :: Int
-> Archetype -> Archetypes -> (Int, ArchetypeState) -> Archetypes
updateDependency Int
parentId Archetype
parentArch Archetypes
acc (Int
childId, ArchetypeState Archetype
childArch Map Entity ArchetypeComponents
_ [ArchetypeId]
_) =
      let parentComponents :: Set ArchetypeComponent
parentComponents = Archetype -> Set ArchetypeComponent
unwrapArchetype Archetype
parentArch
          childComponents :: Set ArchetypeComponent
childComponents = Archetype -> Set ArchetypeComponent
unwrapArchetype Archetype
childArch
       in if Int
childId Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
parentId Bool -> Bool -> Bool
&& Set ArchetypeComponent -> Set ArchetypeComponent -> Bool
forall a. Ord a => Set a -> Set a -> Bool
Set.isSubsetOf Set ArchetypeComponent
childComponents Set ArchetypeComponent
parentComponents
            then ArchetypeId -> ArchetypeId -> Archetypes -> Archetypes
mergeWithDeps (Int -> ArchetypeId
ArchetypeId Int
parentId) (Int -> ArchetypeId
ArchetypeId Int
childId) Archetypes
acc
            else Archetypes
acc

mergeWithDeps :: ArchetypeId -> ArchetypeId -> Archetypes -> Archetypes
mergeWithDeps :: ArchetypeId -> ArchetypeId -> Archetypes -> Archetypes
mergeWithDeps ArchetypeId
parentId ArchetypeId
childId (Archetypes IntMap ArchetypeState
es Map TypeRep [ArchetypeId]
ids Map Archetype ArchetypeId
as Int
nextId) =
  case (Int -> IntMap ArchetypeState -> Maybe ArchetypeState
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup (ArchetypeId -> Int
getArchetypeId ArchetypeId
parentId) IntMap ArchetypeState
es, Int -> IntMap ArchetypeState -> Maybe ArchetypeState
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup (ArchetypeId -> Int
getArchetypeId ArchetypeId
childId) IntMap ArchetypeState
es) of
    (Just (ArchetypeState Archetype
parentArch Map Entity ArchetypeComponents
parentEntities [ArchetypeId]
parentDeps), Just (ArchetypeState Archetype
childArch Map Entity ArchetypeComponents
childEntities [ArchetypeId]
childDeps)) ->
      let parentComponents :: Set ArchetypeComponent
parentComponents = Archetype -> Set ArchetypeComponent
unwrapArchetype Archetype
parentArch
          childComponents :: Set ArchetypeComponent
childComponents = Archetype -> Set ArchetypeComponent
unwrapArchetype Archetype
childArch

          adjustedChildComponents :: Set ArchetypeComponent
adjustedChildComponents = Set ArchetypeComponent
-> Set ArchetypeComponent -> Set ArchetypeComponent
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection Set ArchetypeComponent
parentComponents Set ArchetypeComponent
childComponents
          adjustedChildArch :: Archetype
adjustedChildArch = Set ArchetypeComponent -> Archetype
Archetype Set ArchetypeComponent
adjustedChildComponents

          (ArchetypeId
childId', IntMap ArchetypeState
updatedEs, Map Archetype ArchetypeId
updatedAs, Int
newNextId) =
            if Set ArchetypeComponent
adjustedChildComponents Set ArchetypeComponent -> Set ArchetypeComponent -> Bool
forall a. Eq a => a -> a -> Bool
== Set ArchetypeComponent
childComponents
              then (ArchetypeId
childId, IntMap ArchetypeState
es, Map Archetype ArchetypeId
as, Int
nextId)
              else case Archetype -> Map Archetype ArchetypeId -> Maybe ArchetypeId
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Archetype
adjustedChildArch Map Archetype ArchetypeId
as of
                Just ArchetypeId
existingId -> (ArchetypeId
existingId, IntMap ArchetypeState
es, Map Archetype ArchetypeId
as, Int
nextId)
                Maybe ArchetypeId
Nothing ->
                  let newChildId :: ArchetypeId
newChildId = Int -> ArchetypeId
ArchetypeId Int
nextId
                      newState :: ArchetypeState
newState = Archetype
-> Map Entity ArchetypeComponents
-> [ArchetypeId]
-> ArchetypeState
ArchetypeState Archetype
adjustedChildArch Map Entity ArchetypeComponents
childEntities [ArchetypeId]
childDeps
                   in ( ArchetypeId
newChildId,
                        Int
-> ArchetypeState -> IntMap ArchetypeState -> IntMap ArchetypeState
forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
nextId ArchetypeState
newState IntMap ArchetypeState
es,
                        Archetype
-> ArchetypeId
-> Map Archetype ArchetypeId
-> Map Archetype ArchetypeId
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Archetype
adjustedChildArch ArchetypeId
newChildId Map Archetype ArchetypeId
as,
                        Int
nextId Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
                      )

          updatedParentDeps :: [ArchetypeId]
updatedParentDeps = ArchetypeId
childId' ArchetypeId -> [ArchetypeId] -> [ArchetypeId]
forall a. a -> [a] -> [a]
: [ArchetypeId]
parentDeps
          updatedParentState :: ArchetypeState
updatedParentState = Archetype
-> Map Entity ArchetypeComponents
-> [ArchetypeId]
-> ArchetypeState
ArchetypeState Archetype
parentArch Map Entity ArchetypeComponents
parentEntities [ArchetypeId]
updatedParentDeps
          finalEs :: IntMap ArchetypeState
finalEs = Int
-> ArchetypeState -> IntMap ArchetypeState -> IntMap ArchetypeState
forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert (ArchetypeId -> Int
getArchetypeId ArchetypeId
parentId) ArchetypeState
updatedParentState IntMap ArchetypeState
updatedEs
       in IntMap ArchetypeState
-> Map TypeRep [ArchetypeId]
-> Map Archetype ArchetypeId
-> Int
-> Archetypes
Archetypes IntMap ArchetypeState
finalEs Map TypeRep [ArchetypeId]
ids Map Archetype ArchetypeId
updatedAs Int
newNextId
    (Maybe ArchetypeState, Maybe ArchetypeState)
_ -> IntMap ArchetypeState
-> Map TypeRep [ArchetypeId]
-> Map Archetype ArchetypeId
-> Int
-> Archetypes
Archetypes IntMap ArchetypeState
es Map TypeRep [ArchetypeId]
ids Map Archetype ArchetypeId
as Int
nextId

getArchetypeId :: ArchetypeId -> Int
getArchetypeId :: ArchetypeId -> Int
getArchetypeId (ArchetypeId Int
x) = Int
x

unwrapArchetype :: Archetype -> Set ArchetypeComponent
unwrapArchetype :: Archetype -> Set ArchetypeComponent
unwrapArchetype (Archetype Set ArchetypeComponent
set) = Set ArchetypeComponent
set