{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

module Data.Aztecs.Archetype where

import Data.Aztecs.Core (Component (..), ComponentID, EntityID (..))
import qualified Data.Aztecs.Storage as S
import Data.Bifunctor (Bifunctor (..))
import Data.Dynamic (Dynamic, fromDynamic, toDyn)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import Prelude hiding (all, lookup)

data AnyStorage = AnyStorage
  { AnyStorage -> Dynamic
storageDyn :: Dynamic,
    AnyStorage -> Int -> Dynamic -> Dynamic -> Dynamic
insertDyn :: Int -> Dynamic -> Dynamic -> Dynamic,
    AnyStorage -> Int -> Dynamic -> (Maybe Dynamic, Dynamic)
removeDyn :: Int -> Dynamic -> (Maybe Dynamic, Dynamic),
    AnyStorage -> Int -> Dynamic -> (Maybe AnyStorage, Dynamic)
removeAny :: Int -> Dynamic -> (Maybe AnyStorage, Dynamic)
  }

instance Show AnyStorage where
  show :: AnyStorage -> String
show AnyStorage
s = String
"AnyStorage " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Dynamic -> String
forall a. Show a => a -> String
show (AnyStorage -> Dynamic
storageDyn AnyStorage
s)

anyStorage :: forall s a. (S.Storage s a) => s a -> AnyStorage
anyStorage :: forall (s :: * -> *) a. Storage s a => s a -> AnyStorage
anyStorage s a
s =
  AnyStorage
    { storageDyn :: Dynamic
storageDyn = s a -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn s a
s,
      insertDyn :: Int -> Dynamic -> Dynamic -> Dynamic
insertDyn = \Int
i Dynamic
cDyn Dynamic
sDyn ->
        Dynamic -> Maybe Dynamic -> Dynamic
forall a. a -> Maybe a -> a
fromMaybe Dynamic
sDyn (Maybe Dynamic -> Dynamic) -> Maybe Dynamic -> Dynamic
forall a b. (a -> b) -> a -> b
$ do
          s a
s' <- forall a. Typeable a => Dynamic -> Maybe a
fromDynamic @(s a) Dynamic
sDyn
          a
c <- Dynamic -> Maybe a
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic Dynamic
cDyn
          Dynamic -> Maybe Dynamic
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Dynamic -> Maybe Dynamic)
-> (s a -> Dynamic) -> s a -> Maybe Dynamic
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s a -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn (s a -> Maybe Dynamic) -> s a -> Maybe Dynamic
forall a b. (a -> b) -> a -> b
$ Int -> a -> s a -> s a
forall (s :: * -> *) a. Storage s a => Int -> a -> s a -> s a
S.insert Int
i a
c s a
s',
      removeDyn :: Int -> Dynamic -> (Maybe Dynamic, Dynamic)
removeDyn = \Int
i Dynamic
dyn -> case forall a. Typeable a => Dynamic -> Maybe a
fromDynamic @(s a) Dynamic
dyn of
        Just s a
s' -> let (Maybe a
a, s a
b) = Int -> s a -> (Maybe a, s a)
forall (s :: * -> *) a. Storage s a => Int -> s a -> (Maybe a, s a)
S.remove Int
i s a
s' in ((a -> Dynamic) -> Maybe a -> Maybe Dynamic
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn Maybe a
a, s a -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn s a
b)
        Maybe (s a)
Nothing -> (Maybe Dynamic
forall a. Maybe a
Nothing, Dynamic
dyn),
      removeAny :: Int -> Dynamic -> (Maybe AnyStorage, Dynamic)
removeAny = \Int
i Dynamic
dyn -> case forall a. Typeable a => Dynamic -> Maybe a
fromDynamic @(s a) Dynamic
dyn of
        Just s a
s' -> let (Maybe a
a, s a
b) = Int -> s a -> (Maybe a, s a)
forall (s :: * -> *) a. Storage s a => Int -> s a -> (Maybe a, s a)
S.remove Int
i s a
s' in ((a -> AnyStorage) -> Maybe a -> Maybe AnyStorage
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (s a -> AnyStorage
forall (s :: * -> *) a. Storage s a => s a -> AnyStorage
anyStorage (s a -> AnyStorage) -> (a -> s a) -> a -> AnyStorage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (s :: * -> *) a. Storage s a => Int -> a -> s a
S.singleton @s Int
i) Maybe a
a, s a -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn s a
b)
        Maybe (s a)
Nothing -> (Maybe AnyStorage
forall a. Maybe a
Nothing, Dynamic
dyn)
    }

newtype Archetype = Archetype {Archetype -> Map ComponentID AnyStorage
storages :: Map ComponentID AnyStorage}
  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)

empty :: Archetype
empty :: Archetype
empty = Archetype {storages :: Map ComponentID AnyStorage
storages = Map ComponentID AnyStorage
forall k a. Map k a
Map.empty}

lookupStorage :: (Component a) => ComponentID -> Archetype -> Maybe (StorageT a a)
lookupStorage :: forall a.
Component a =>
ComponentID -> Archetype -> Maybe (StorageT a a)
lookupStorage ComponentID
cId Archetype
w = do
  AnyStorage
dynS <- ComponentID -> Map ComponentID AnyStorage -> Maybe AnyStorage
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ComponentID
cId (Archetype -> Map ComponentID AnyStorage
storages Archetype
w)
  Dynamic -> Maybe (StorageT a a)
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic (AnyStorage -> Dynamic
storageDyn AnyStorage
dynS)

insert :: forall a. (Component a) => EntityID -> ComponentID -> a -> Archetype -> Archetype
insert :: forall a.
Component a =>
EntityID -> ComponentID -> a -> Archetype -> Archetype
insert EntityID
e ComponentID
cId a
c Archetype
arch =
  let storage :: StorageT a a
storage = case ComponentID -> Archetype -> Maybe (StorageT a a)
forall a.
Component a =>
ComponentID -> Archetype -> Maybe (StorageT a a)
lookupStorage ComponentID
cId Archetype
arch of
        Just StorageT a a
s -> Int -> a -> StorageT a a -> StorageT a a
forall (s :: * -> *) a. Storage s a => Int -> a -> s a -> s a
S.insert (EntityID -> Int
unEntityId EntityID
e) a
c StorageT a a
s
        Maybe (StorageT a a)
Nothing -> forall (s :: * -> *) a. Storage s a => Int -> a -> s a
S.singleton @(StorageT a) @a (EntityID -> Int
unEntityId EntityID
e) a
c
   in Archetype
arch {storages = Map.insert cId (anyStorage storage) (storages arch)}

all :: (Component a) => ComponentID -> Archetype -> [(EntityID, a)]
all :: forall a.
Component a =>
ComponentID -> Archetype -> [(EntityID, a)]
all ComponentID
cId Archetype
arch = [(EntityID, a)] -> Maybe [(EntityID, a)] -> [(EntityID, a)]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [(EntityID, a)] -> [(EntityID, a)])
-> Maybe [(EntityID, a)] -> [(EntityID, a)]
forall a b. (a -> b) -> a -> b
$ do
  StorageT a a
s <- ComponentID -> Archetype -> Maybe (StorageT a a)
forall a.
Component a =>
ComponentID -> Archetype -> Maybe (StorageT a a)
lookupStorage ComponentID
cId Archetype
arch
  [(EntityID, a)] -> Maybe [(EntityID, a)]
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(EntityID, a)] -> Maybe [(EntityID, a)])
-> ([(Int, a)] -> [(EntityID, a)])
-> [(Int, a)]
-> Maybe [(EntityID, a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, a) -> (EntityID, a)) -> [(Int, a)] -> [(EntityID, a)]
forall a b. (a -> b) -> [a] -> [b]
map ((Int -> EntityID) -> (Int, a) -> (EntityID, a)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Int -> EntityID
EntityID) ([(Int, a)] -> Maybe [(EntityID, a)])
-> [(Int, a)] -> Maybe [(EntityID, a)]
forall a b. (a -> b) -> a -> b
$ StorageT a a -> [(Int, a)]
forall (s :: * -> *) a. Storage s a => s a -> [(Int, a)]
S.all StorageT a a
s

lookup :: forall a. (Component a) => EntityID -> ComponentID -> Archetype -> Maybe a
lookup :: forall a.
Component a =>
EntityID -> ComponentID -> Archetype -> Maybe a
lookup EntityID
e ComponentID
cId Archetype
w = ComponentID -> Archetype -> Maybe (StorageT a a)
forall a.
Component a =>
ComponentID -> Archetype -> Maybe (StorageT a a)
lookupStorage ComponentID
cId Archetype
w Maybe (StorageT a a) -> (StorageT a a -> 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
>>= Int -> StorageT a a -> Maybe a
forall (s :: * -> *) a. Storage s a => Int -> s a -> Maybe a
S.lookup (EntityID -> Int
unEntityId EntityID
e)

insertAscList :: forall a. (Component a) => ComponentID -> [(EntityID, a)] -> Archetype -> Archetype
insertAscList :: forall a.
Component a =>
ComponentID -> [(EntityID, a)] -> Archetype -> Archetype
insertAscList ComponentID
cId [(EntityID, a)]
as Archetype
arch = Archetype
arch {storages = Map.insert cId (anyStorage $ S.fromAscList @(StorageT a) (map (first unEntityId) as)) (storages arch)}

remove :: EntityID -> Archetype -> (Map ComponentID Dynamic, Archetype)
remove :: EntityID -> Archetype -> (Map ComponentID Dynamic, Archetype)
remove EntityID
e Archetype
arch =
  ((ComponentID, AnyStorage)
 -> (Map ComponentID Dynamic, Archetype)
 -> (Map ComponentID Dynamic, Archetype))
-> (Map ComponentID Dynamic, Archetype)
-> [(ComponentID, AnyStorage)]
-> (Map 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
cId, AnyStorage
s) (Map ComponentID Dynamic
dynAcc, Archetype
archAcc) ->
        let (Maybe Dynamic
dynA, Dynamic
dynS) = AnyStorage -> Int -> Dynamic -> (Maybe Dynamic, Dynamic)
removeDyn AnyStorage
s (EntityID -> Int
unEntityId EntityID
e) (AnyStorage -> Dynamic
storageDyn AnyStorage
s)
            dynAcc' :: Map ComponentID Dynamic
dynAcc' = case Maybe Dynamic
dynA of
              Just Dynamic
d -> ComponentID
-> Dynamic -> Map ComponentID Dynamic -> Map ComponentID Dynamic
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ComponentID
cId Dynamic
d Map ComponentID Dynamic
dynAcc
              Maybe Dynamic
Nothing -> Map ComponentID Dynamic
dynAcc
         in ( Map ComponentID Dynamic
dynAcc',
              Archetype
archAcc {storages = Map.insert cId (s {storageDyn = dynS}) (storages archAcc)}
            )
    )
    (Map ComponentID Dynamic
forall k a. Map k a
Map.empty, Archetype
arch)
    (Map ComponentID AnyStorage -> [(ComponentID, AnyStorage)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map ComponentID AnyStorage -> [(ComponentID, AnyStorage)])
-> Map ComponentID AnyStorage -> [(ComponentID, AnyStorage)]
forall a b. (a -> b) -> a -> b
$ Archetype -> Map ComponentID AnyStorage
storages Archetype
arch)

removeStorages :: EntityID -> Archetype -> (Map ComponentID AnyStorage, Archetype)
removeStorages :: EntityID -> Archetype -> (Map ComponentID AnyStorage, Archetype)
removeStorages EntityID
e Archetype
arch =
  ((ComponentID, AnyStorage)
 -> (Map ComponentID AnyStorage, Archetype)
 -> (Map ComponentID AnyStorage, Archetype))
-> (Map ComponentID AnyStorage, Archetype)
-> [(ComponentID, AnyStorage)]
-> (Map ComponentID AnyStorage, 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
cId, AnyStorage
s) (Map ComponentID AnyStorage
dynAcc, Archetype
archAcc) ->
        let (Maybe AnyStorage
dynA, Dynamic
dynS) = AnyStorage -> Int -> Dynamic -> (Maybe AnyStorage, Dynamic)
removeAny AnyStorage
s (EntityID -> Int
unEntityId EntityID
e) (AnyStorage -> Dynamic
storageDyn AnyStorage
s)
            dynAcc' :: Map ComponentID AnyStorage
dynAcc' = case Maybe AnyStorage
dynA of
              Just AnyStorage
d -> ComponentID
-> AnyStorage
-> Map ComponentID AnyStorage
-> Map ComponentID AnyStorage
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ComponentID
cId AnyStorage
d Map ComponentID AnyStorage
dynAcc
              Maybe AnyStorage
Nothing -> Map ComponentID AnyStorage
dynAcc
         in ( Map ComponentID AnyStorage
dynAcc',
              Archetype
archAcc {storages = Map.insert cId (s {storageDyn = dynS}) (storages archAcc)}
            )
    )
    (Map ComponentID AnyStorage
forall k a. Map k a
Map.empty, Archetype
arch)
    (Map ComponentID AnyStorage -> [(ComponentID, AnyStorage)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map ComponentID AnyStorage -> [(ComponentID, AnyStorage)])
-> Map ComponentID AnyStorage -> [(ComponentID, AnyStorage)]
forall a b. (a -> b) -> a -> b
$ Archetype -> Map ComponentID AnyStorage
storages Archetype
arch)