{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Data.Aztecs.World
  ( ArchetypeID (..),
    World (..),
    empty,
    spawn,
    spawnWithId,
    spawnWithArchetypeId,
    spawnEmpty,
    insert,
    insertWithId,
    insertArchetype,
    despawn,
  )
where

import Data.Aztecs.Archetype (Archetype (..))
import qualified Data.Aztecs.Archetype as A
import Data.Aztecs.Core (Component (..), ComponentID, Components (..), EntityID (..), emptyComponents, insertComponentId)
import Data.Dynamic (Dynamic)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Typeable (Proxy (..), Typeable, typeOf)

newtype ArchetypeID = ArchetypeID {ArchetypeID -> Int
unArchetypeId :: 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)

-- | World of entities and their components.

data World = World
  { World -> Map ArchetypeID Archetype
archetypes :: Map ArchetypeID Archetype,
    World -> Map (Set ComponentID) ArchetypeID
archetypeIds :: Map (Set ComponentID) ArchetypeID,
    World -> Map ArchetypeID (Set ComponentID)
archetypeComponents :: Map ArchetypeID (Set ComponentID),
    World -> ArchetypeID
nextArchetypeId :: ArchetypeID,
    World -> Components
components :: Components,
    World -> Map EntityID ArchetypeID
entities :: Map EntityID ArchetypeID,
    World -> EntityID
nextEntityId :: EntityID
  }
  deriving (Int -> World -> ShowS
[World] -> ShowS
World -> String
(Int -> World -> ShowS)
-> (World -> String) -> ([World] -> ShowS) -> Show World
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> World -> ShowS
showsPrec :: Int -> World -> ShowS
$cshow :: World -> String
show :: World -> String
$cshowList :: [World] -> ShowS
showList :: [World] -> ShowS
Show)

-- | Empty `World`.

empty :: World
empty :: World
empty =
  World
    { archetypes :: Map ArchetypeID Archetype
archetypes = Map ArchetypeID Archetype
forall a. Monoid a => a
mempty,
      archetypeIds :: Map (Set ComponentID) ArchetypeID
archetypeIds = Map (Set ComponentID) ArchetypeID
forall a. Monoid a => a
mempty,
      archetypeComponents :: Map ArchetypeID (Set ComponentID)
archetypeComponents = Map ArchetypeID (Set ComponentID)
forall a. Monoid a => a
mempty,
      nextArchetypeId :: ArchetypeID
nextArchetypeId = Int -> ArchetypeID
ArchetypeID Int
0,
      components :: Components
components = Components
emptyComponents,
      entities :: Map EntityID ArchetypeID
entities = Map EntityID ArchetypeID
forall a. Monoid a => a
mempty,
      nextEntityId :: EntityID
nextEntityId = Int -> EntityID
EntityID Int
0
    }

-- | Spawn an entity with a component.

spawn :: forall a. (Component a, Typeable (StorageT a)) => a -> World -> (EntityID, World)
spawn :: forall a.
(Component a, Typeable (StorageT a)) =>
a -> World -> (EntityID, World)
spawn a
c World
w = case TypeRep -> Map TypeRep ComponentID -> Maybe ComponentID
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Proxy a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a)) (Components -> Map TypeRep ComponentID
componentIds (World -> Components
components World
w)) of
  Just ComponentID
cId -> ComponentID -> a -> World -> (EntityID, World)
forall a.
(Component a, Typeable (StorageT a)) =>
ComponentID -> a -> World -> (EntityID, World)
spawnWithId ComponentID
cId a
c World
w
  Maybe ComponentID
Nothing ->
    let (ComponentID
cId, Components
cs) = forall c. Component c => Components -> (ComponentID, Components)
insertComponentId @a (World -> Components
components World
w)
     in ComponentID -> a -> World -> (EntityID, World)
forall a.
(Component a, Typeable (StorageT a)) =>
ComponentID -> a -> World -> (EntityID, World)
spawnWithId ComponentID
cId a
c World
w {components = cs}

-- | Spawn an empty entity.

spawnEmpty :: World -> (EntityID, World)
spawnEmpty :: World -> (EntityID, World)
spawnEmpty World
w = let e :: EntityID
e = World -> EntityID
nextEntityId World
w in (EntityID
e, World
w {nextEntityId = EntityID (unEntityId e + 1)})

-- | Spawn an entity with a component and its `ComponentID`.

spawnWithId ::
  forall a.
  (Component a, Typeable (StorageT a)) =>
  ComponentID ->
  a ->
  World ->
  (EntityID, World)
spawnWithId :: forall a.
(Component a, Typeable (StorageT a)) =>
ComponentID -> a -> World -> (EntityID, World)
spawnWithId ComponentID
cId a
c World
w =
  let (EntityID
e, World
w') = World -> (EntityID, World)
spawnEmpty World
w
   in case Set ComponentID
-> Map (Set ComponentID) ArchetypeID -> Maybe ArchetypeID
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (ComponentID -> Set ComponentID
forall a. a -> Set a
Set.singleton ComponentID
cId) (World -> Map (Set ComponentID) ArchetypeID
archetypeIds World
w) of
        Just ArchetypeID
aId -> (EntityID
e, EntityID -> ArchetypeID -> ComponentID -> a -> World -> World
forall a.
(Component a, Typeable (StorageT a)) =>
EntityID -> ArchetypeID -> ComponentID -> a -> World -> World
spawnWithArchetypeId' EntityID
e ArchetypeID
aId ComponentID
cId a
c World
w')
        Maybe ArchetypeID
Nothing ->
          ( EntityID
e,
            (ArchetypeID, World) -> World
forall a b. (a, b) -> b
snd ((ArchetypeID, World) -> World) -> (ArchetypeID, World) -> World
forall a b. (a -> b) -> a -> b
$
              Set ComponentID -> Archetype -> World -> (ArchetypeID, World)
insertArchetype
                (ComponentID -> Set ComponentID
forall a. a -> Set a
Set.singleton ComponentID
cId)
                (EntityID -> ComponentID -> a -> Archetype -> Archetype
forall a.
Component a =>
EntityID -> ComponentID -> a -> Archetype -> Archetype
A.insert EntityID
e ComponentID
cId a
c Archetype
A.empty)
                World
w' {entities = Map.insert e (nextArchetypeId w) (entities w)}
          )

-- | Spawn an entity with a component and its `ComponentID` directly into an archetype.

spawnWithArchetypeId ::
  forall a.
  (Component a, Typeable (StorageT a)) =>
  a ->
  ComponentID ->
  ArchetypeID ->
  World ->
  (EntityID, World)
spawnWithArchetypeId :: forall a.
(Component a, Typeable (StorageT a)) =>
a -> ComponentID -> ArchetypeID -> World -> (EntityID, World)
spawnWithArchetypeId a
c ComponentID
cId ArchetypeID
aId World
w =
  let (EntityID
e, World
w') = World -> (EntityID, World)
spawnEmpty World
w
   in (EntityID
e, EntityID -> ArchetypeID -> ComponentID -> a -> World -> World
forall a.
(Component a, Typeable (StorageT a)) =>
EntityID -> ArchetypeID -> ComponentID -> a -> World -> World
spawnWithArchetypeId' EntityID
e ArchetypeID
aId ComponentID
cId a
c World
w')

spawnWithArchetypeId' ::
  forall a.
  (Component a, Typeable (StorageT a)) =>
  EntityID ->
  ArchetypeID ->
  ComponentID ->
  a ->
  World ->
  World
spawnWithArchetypeId' :: forall a.
(Component a, Typeable (StorageT a)) =>
EntityID -> ArchetypeID -> ComponentID -> a -> World -> World
spawnWithArchetypeId' EntityID
e ArchetypeID
aId ComponentID
cId a
c World
w =
  let f :: Archetype -> Archetype
f = EntityID -> ComponentID -> a -> Archetype -> Archetype
forall a.
Component a =>
EntityID -> ComponentID -> a -> Archetype -> Archetype
A.insert EntityID
e ComponentID
cId a
c
   in World
w
        { archetypes = Map.adjust f aId (archetypes w),
          entities = Map.insert e aId (entities w)
        }

-- | Insert an archetype by its set of `ComponentID`s.

insertArchetype :: Set ComponentID -> Archetype -> World -> (ArchetypeID, World)
insertArchetype :: Set ComponentID -> Archetype -> World -> (ArchetypeID, World)
insertArchetype Set ComponentID
cIds Archetype
a World
w =
  let aId :: ArchetypeID
aId = World -> ArchetypeID
nextArchetypeId World
w
   in ( ArchetypeID
aId,
        World
w
          { archetypes = Map.insert aId a (archetypes w),
            archetypeIds = Map.insert cIds aId (archetypeIds w),
            archetypeComponents = Map.insert aId cIds (archetypeComponents w),
            nextArchetypeId = ArchetypeID (unArchetypeId aId + 1)
          }
      )

insert :: forall a. (Component a, Typeable (StorageT a)) => EntityID -> a -> World -> World
insert :: forall a.
(Component a, Typeable (StorageT a)) =>
EntityID -> a -> World -> World
insert EntityID
e a
c World
w =
  let (ComponentID
cId, Components
components') = forall c. Component c => Components -> (ComponentID, Components)
insertComponentId @a (World -> Components
components World
w)
   in EntityID -> ComponentID -> a -> World -> World
forall a.
(Component a, Typeable (StorageT a)) =>
EntityID -> ComponentID -> a -> World -> World
insertWithId EntityID
e ComponentID
cId a
c World
w {components = components'}

insertWithId :: (Component a, Typeable (StorageT a)) => EntityID -> ComponentID -> a -> World -> World
insertWithId :: forall a.
(Component a, Typeable (StorageT a)) =>
EntityID -> ComponentID -> a -> World -> World
insertWithId EntityID
e ComponentID
cId a
c World
w = case EntityID -> Map EntityID ArchetypeID -> Maybe ArchetypeID
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup EntityID
e (World -> Map EntityID ArchetypeID
entities World
w) of
  Just ArchetypeID
aId -> case ArchetypeID
-> Map ArchetypeID (Set ComponentID) -> Maybe (Set ComponentID)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ArchetypeID
aId (World -> Map ArchetypeID (Set ComponentID)
archetypeComponents World
w) of
    Just Set ComponentID
cIds ->
      if ComponentID -> Set ComponentID -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member ComponentID
cId Set ComponentID
cIds
        then World
w {archetypes = Map.adjust (A.insert e cId c) aId (archetypes w)}
        else
          let arch :: Archetype
arch = World -> Map ArchetypeID Archetype
archetypes World
w Map ArchetypeID Archetype -> ArchetypeID -> Archetype
forall k a. Ord k => Map k a -> k -> a
Map.! ArchetypeID
aId
           in case Set ComponentID
-> Map (Set ComponentID) ArchetypeID -> Maybe ArchetypeID
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (ComponentID -> Set ComponentID -> Set ComponentID
forall a. Ord a => a -> Set a -> Set a
Set.insert ComponentID
cId Set ComponentID
cIds) (World -> Map (Set ComponentID) ArchetypeID
archetypeIds World
w) of
                Just ArchetypeID
nextAId ->
                  let (Map ComponentID Dynamic
cs, Archetype
arch') = EntityID -> Archetype -> (Map ComponentID Dynamic, Archetype)
A.remove EntityID
e Archetype
arch
                      w' :: World
w' = World
w {archetypes = Map.insert aId arch' (archetypes w)}
                      f :: (ComponentID, Dynamic) -> Archetype -> Archetype
f (ComponentID
itemCId, Dynamic
dyn) Archetype
archAcc =
                        Archetype
archAcc
                          { A.storages =
                              Map.adjust
                                (\AnyStorage
s -> AnyStorage
s {A.storageDyn = A.insertDyn s (unEntityId e) dyn (A.storageDyn s)})
                                itemCId
                                (A.storages archAcc)
                          }
                   in World
w'
                        { archetypes =
                            Map.adjust
                              (\Archetype
nextArch -> ((ComponentID, Dynamic) -> Archetype -> Archetype)
-> Archetype -> [(ComponentID, Dynamic)] -> Archetype
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (ComponentID, Dynamic) -> Archetype -> Archetype
f Archetype
nextArch (Map ComponentID Dynamic -> [(ComponentID, Dynamic)]
forall k a. Map k a -> [(k, a)]
Map.toList Map ComponentID Dynamic
cs))
                              nextAId
                              (archetypes w')
                        }
                Maybe ArchetypeID
Nothing ->
                  let (Map ComponentID AnyStorage
s, Archetype
arch') = EntityID -> Archetype -> (Map ComponentID AnyStorage, Archetype)
A.removeStorages EntityID
e Archetype
arch
                      w' :: World
w' = World
w {archetypes = Map.insert aId arch' (archetypes w)}
                      newArch :: Archetype
newArch = Archetype {storages :: Map ComponentID AnyStorage
A.storages = Map ComponentID AnyStorage
s}
                      newArch' :: Archetype
newArch' = EntityID -> ComponentID -> a -> Archetype -> Archetype
forall a.
Component a =>
EntityID -> ComponentID -> a -> Archetype -> Archetype
A.insert EntityID
e ComponentID
cId a
c Archetype
newArch
                   in (ArchetypeID, World) -> World
forall a b. (a, b) -> b
snd ((ArchetypeID, World) -> World) -> (ArchetypeID, World) -> World
forall a b. (a -> b) -> a -> b
$ Set ComponentID -> Archetype -> World -> (ArchetypeID, World)
insertArchetype (ComponentID -> Set ComponentID -> Set ComponentID
forall a. Ord a => a -> Set a -> Set a
Set.insert ComponentID
cId Set ComponentID
cIds) Archetype
newArch' World
w'
    Maybe (Set ComponentID)
Nothing -> World
w
  Maybe ArchetypeID
Nothing -> World
w

despawn :: EntityID -> World -> (Map ComponentID Dynamic, World)
despawn :: EntityID -> World -> (Map ComponentID Dynamic, World)
despawn EntityID
e World
w =
  let res :: Maybe (ArchetypeID, Archetype)
res = do
        ArchetypeID
aId <- EntityID -> Map EntityID ArchetypeID -> Maybe ArchetypeID
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup EntityID
e (World -> Map EntityID ArchetypeID
entities World
w)
        Archetype
arch <- ArchetypeID -> Map ArchetypeID Archetype -> Maybe Archetype
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ArchetypeID
aId (World -> Map ArchetypeID Archetype
archetypes World
w)
        (ArchetypeID, Archetype) -> Maybe (ArchetypeID, Archetype)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (ArchetypeID
aId, Archetype
arch)
   in case Maybe (ArchetypeID, Archetype)
res of
        Just (ArchetypeID
aId, Archetype
arch) ->
          let (Map ComponentID Dynamic
dynAcc, Archetype
arch') = EntityID -> Archetype -> (Map ComponentID Dynamic, Archetype)
A.remove EntityID
e Archetype
arch
           in ( Map ComponentID Dynamic
dynAcc,
                World
w
                  { archetypes = Map.insert aId arch' (archetypes w),
                    entities = Map.delete e (entities w)
                  }
              )
        Maybe (ArchetypeID, Archetype)
Nothing -> (Map ComponentID Dynamic
forall k a. Map k a
Map.empty, World
w)