diff --git a/apecs-physics/src/Apecs/Physics/Body.hs b/apecs-physics/src/Apecs/Physics/Body.hs index b585b52..075cfe8 100644 --- a/apecs-physics/src/Apecs/Physics/Body.hs +++ b/apecs-physics/src/Apecs/Physics/Body.hs @@ -22,6 +22,7 @@ import Control.Monad.IO.Class (MonadIO) import qualified Data.IntMap as M import qualified Data.IntSet as S import Data.IORef +import qualified Data.IntSet as IS import qualified Data.Vector.Unboxed as U import Foreign.ForeignPtr (withForeignPtr) import Foreign.Ptr @@ -87,6 +88,7 @@ instance MonadIO m => ExplDestroy m (Space Body) where instance MonadIO m => ExplMembers m (Space Body) where explMembers (Space bMap _ _ _ _) = liftIO $ U.fromList . M.keys <$> readIORef bMap + explMemberSet (Space bMap _ _ _ _) = liftIO $ M.keysSet <$> readIORef bMap instance MonadIO m => ExplGet m (Space Body) where explExists (Space bMap _ _ _ _) ety = liftIO $ M.member ety <$> readIORef bMap diff --git a/apecs-physics/src/Apecs/Physics/Constraint.hs b/apecs-physics/src/Apecs/Physics/Constraint.hs index 2994adc..a99d0b6 100644 --- a/apecs-physics/src/Apecs/Physics/Constraint.hs +++ b/apecs-physics/src/Apecs/Physics/Constraint.hs @@ -24,6 +24,7 @@ import Control.Monad.IO.Class (MonadIO) import qualified Data.IntMap as M import qualified Data.IntSet as S import Data.IORef +import qualified Data.IntSet as IS import qualified Data.Vector.Unboxed as U import Foreign.ForeignPtr (withForeignPtr) import Foreign.Ptr @@ -178,6 +179,7 @@ instance MonadIO m => ExplDestroy m (Space Constraint) where instance MonadIO m => ExplMembers m (Space Constraint) where explMembers (Space _ _ cMap _ _) = liftIO $ U.fromList . M.keys <$> readIORef cMap + explMemberSet (Space _ _ cMap _ _) = liftIO $ M.keysSet <$> readIORef cMap instance MonadIO m => ExplGet m (Space Constraint) where explExists (Space _ _ cMap _ _) ety = liftIO $ M.member ety <$> readIORef cMap diff --git a/apecs-physics/src/Apecs/Physics/Shape.hs b/apecs-physics/src/Apecs/Physics/Shape.hs index 24e7d9e..6fc874a 100644 --- a/apecs-physics/src/Apecs/Physics/Shape.hs +++ b/apecs-physics/src/Apecs/Physics/Shape.hs @@ -19,6 +19,7 @@ import Data.Bits import qualified Data.IntMap as M import qualified Data.IntSet as S import Data.IORef +import qualified Data.IntSet as IS import Data.Monoid ((<>)) import qualified Data.Vector.Storable as V import qualified Data.Vector.Unboxed as U @@ -62,6 +63,7 @@ instance (MonadIO m, Has w m Physics) => Has w m Shape where instance MonadIO m => ExplMembers m (Space Shape) where explMembers (Space _ sMap _ _ _) = liftIO $ U.fromList . M.keys <$> readIORef sMap + explMemberSet (Space _ sMap _ _ _) = liftIO $ M.keysSet <$> readIORef sMap instance MonadIO m => ExplDestroy m (Space Shape) where explDestroy (Space bMap sMap _ _ spc) sEty = liftIO $ do diff --git a/apecs-stm/src/Apecs/STM.hs b/apecs-stm/src/Apecs/STM.hs index bcbce7e..20716ec 100644 --- a/apecs-stm/src/Apecs/STM.hs +++ b/apecs-stm/src/Apecs/STM.hs @@ -32,6 +32,7 @@ import Data.Maybe import Data.Monoid (Sum (..)) import Data.Semigroup import Data.Typeable (Typeable, typeRep) +import qualified Data.IntSet as IS import qualified Data.Vector.Unboxed as U import Language.Haskell.TH import qualified ListT as L @@ -69,6 +70,8 @@ instance ExplDestroy STM (Map c) where instance ExplMembers STM (Map c) where {-# INLINE explMembers #-} explMembers (Map m) = U.unfoldrM L.uncons $ fst <$> M.listT m + {-# INLINE explMemberSet #-} + explMemberSet (Map m) = IS.fromList . U.toList <$> explMembers (Map m) instance ExplInit IO (Map c) where {-# INLINE explInit #-} @@ -87,6 +90,8 @@ instance ExplDestroy IO (Map c) where instance ExplMembers IO (Map c) where {-# INLINE explMembers #-} explMembers m = S.atomically $ explMembers m + {-# INLINE explMemberSet #-} + explMemberSet m = S.atomically $ explMemberSet m newtype Unique c = Unique (TVar (Maybe (Int, c))) type instance Elem (Unique c) = c @@ -118,6 +123,10 @@ instance ExplMembers STM (Unique c) where explMembers (Unique ref) = flip fmap (readTVar ref) $ \case Nothing -> mempty Just (ety, _) -> U.singleton ety + {-# INLINE explMemberSet #-} + explMemberSet (Unique ref) = flip fmap (readTVar ref) $ \case + Nothing -> mempty + Just (ety, _) -> IS.singleton ety instance ExplInit IO (Unique c) where {-# INLINE explInit #-} @@ -136,6 +145,8 @@ instance ExplDestroy IO (Unique c) where instance ExplMembers IO (Unique c) where {-# INLINE explMembers #-} explMembers m = S.atomically $ explMembers m + {-# INLINE explMemberSet #-} + explMemberSet m = S.atomically $ explMemberSet m newtype Global c = Global (TVar c) type instance Elem (Global c) = c diff --git a/apecs/src/Apecs/Components.hs b/apecs/src/Apecs/Components.hs index b1aa1ae..73808b0 100644 --- a/apecs/src/Apecs/Components.hs +++ b/apecs/src/Apecs/Components.hs @@ -14,6 +14,8 @@ module Apecs.Components where import Data.Functor.Identity +import qualified Data.IntSet as IS +import qualified Data.Vector.Unboxed as U import Apecs.Core import qualified Apecs.THTuples as T @@ -40,6 +42,8 @@ instance ExplSet m s => ExplSet m (Identity s) where instance ExplMembers m s => ExplMembers m (Identity s) where {-# INLINE explMembers #-} explMembers (Identity s) = explMembers s + {-# INLINE explMemberSet #-} + explMemberSet (Identity s) = explMemberSet s instance ExplDestroy m s => ExplDestroy m (Identity s) where {-# INLINE explDestroy #-} explDestroy (Identity s) = explDestroy s @@ -136,6 +140,12 @@ instance (ExplDestroy m sa, ExplDestroy m sb) explDestroy (EitherStore sa sb) ety = explDestroy sa ety >> explDestroy sb ety +instance (ExplMembers m sa, ExplMembers m sb) => ExplMembers m (EitherStore sa sb) where + {-# INLINE explMemberSet #-} + explMemberSet (EitherStore sa sb) = IS.union <$> explMemberSet sa <*> explMemberSet sb + {-# INLINE explMembers #-} + explMembers s = U.fromList . IS.toList <$> explMemberSet s + -- Unit instances () instance Monad m => Has w m () where {-# INLINE getStore #-} @@ -183,6 +193,8 @@ instance ExplGet m s => ExplGet m (FilterStore s) where instance ExplMembers m s => ExplMembers m (FilterStore s) where {-# INLINE explMembers #-} explMembers (FilterStore s) = explMembers s + {-# INLINE explMemberSet #-} + explMemberSet (FilterStore s) = explMemberSet s -- | Pseudostore used to produce components of type 'Entity'. -- Always returns @True@ for @explExists@, and echoes back the entity argument for @explGet@. diff --git a/apecs/src/Apecs/Core.hs b/apecs/src/Apecs/Core.hs index 5b38d0a..540f644 100644 --- a/apecs/src/Apecs/Core.hs +++ b/apecs/src/Apecs/Core.hs @@ -13,6 +13,7 @@ module Apecs.Core where import Control.Monad.Trans.Reader +import qualified Data.IntSet as IS import qualified Data.Vector.Unboxed as U -- | An Entity is just an integer, used to index into a component store. @@ -72,6 +73,10 @@ class Monad m => ExplMembers m s where -- | Returns an unboxed vector of member indices explMembers :: s -> m (U.Vector Int) + -- | Returns an IntSet of member indices + explMemberSet :: s -> m IS.IntSet + explMemberSet s = IS.fromList . U.toList <$> explMembers s + type Get w m c = (Has w m c, ExplGet m (Storage c)) type Set w m c = (Has w m c, ExplSet m (Storage c)) type Members w m c = (Has w m c, ExplMembers m (Storage c)) diff --git a/apecs/src/Apecs/Experimental/Children.hs b/apecs/src/Apecs/Experimental/Children.hs index b583f18..6972d09 100644 --- a/apecs/src/Apecs/Experimental/Children.hs +++ b/apecs/src/Apecs/Experimental/Children.hs @@ -136,6 +136,9 @@ instance (MonadIO m, ExplMembers m s) => ExplMembers m (Children s) where {-# INLINE explMembers #-} explMembers :: Children s -> m (U.Vector Int) explMembers (Children _ _ s) = explMembers s + {-# INLINE explMemberSet #-} + explMemberSet :: Children s -> m IntSet + explMemberSet (Children _ _ s) = explMemberSet s instance (MonadIO m, ExplGet m s, Typeable (Elem s)) => ExplGet m (Children s) where {-# INLINE explGet #-} @@ -220,6 +223,9 @@ instance ExplMembers m s => ExplMembers m (ChildValueStore s) where {-# INLINE explMembers #-} explMembers :: ChildValueStore s -> m (U.Vector Int) explMembers (ChildValueStore (Children _ _ s)) = explMembers s + {-# INLINE explMemberSet #-} + explMemberSet :: ChildValueStore s -> m IntSet + explMemberSet (ChildValueStore (Children _ _ s)) = explMemberSet s instance ExplGet m s => ExplGet m (ChildValueStore s) where {-# INLINE explExists #-} @@ -264,6 +270,10 @@ instance MonadIO m => ExplMembers m (ChildListStore s) where explMembers :: ChildListStore s -> m (U.Vector Int) explMembers (ChildListStore (Children parentToChildren _ _)) = do liftIO $ U.fromList . M.keys <$> IORef.readIORef parentToChildren + {-# INLINE explMemberSet #-} + explMemberSet :: ChildListStore s -> m IntSet + explMemberSet (ChildListStore (Children parentToChildren _ _)) = + liftIO $ M.keysSet <$> IORef.readIORef parentToChildren instance (MonadIO m, Typeable (Elem s)) => ExplGet m (ChildListStore s) where {-# INLINE explExists #-} diff --git a/apecs/src/Apecs/Experimental/Components.hs b/apecs/src/Apecs/Experimental/Components.hs index d593c64..bce405e 100644 --- a/apecs/src/Apecs/Experimental/Components.hs +++ b/apecs/src/Apecs/Experimental/Components.hs @@ -13,6 +13,7 @@ module Apecs.Experimental.Components , Head (..) ) where +import qualified Data.IntSet as IS import qualified Data.Vector.Unboxed as U import Apecs.Core @@ -52,3 +53,6 @@ instance (ExplGet m s) => ExplGet m (HeadStore s) where instance (ExplMembers m s) => ExplMembers m (HeadStore s) where explMembers (HeadStore s) = U.take 1 <$> explMembers s + explMemberSet (HeadStore s) = do + members <- explMembers s + pure $ if U.null members then mempty else IS.singleton (U.head members) diff --git a/apecs/src/Apecs/Experimental/Reactive.hs b/apecs/src/Apecs/Experimental/Reactive.hs index d0c410c..fcaaa9f 100644 --- a/apecs/src/Apecs/Experimental/Reactive.hs +++ b/apecs/src/Apecs/Experimental/Reactive.hs @@ -96,6 +96,8 @@ instance ExplGet m s => ExplGet m (Reactive r s) where instance ExplMembers m s => ExplMembers m (Reactive r s) where {-# INLINE explMembers #-} explMembers (Reactive _ s) = explMembers s + {-# INLINE explMemberSet #-} + explMemberSet (Reactive _ s) = explMemberSet s -- | Prints a message to stdout every time a component is updated. data Printer c = Printer diff --git a/apecs/src/Apecs/Experimental/Stores.hs b/apecs/src/Apecs/Experimental/Stores.hs index 0290267..ca46da2 100644 --- a/apecs/src/Apecs/Experimental/Stores.hs +++ b/apecs/src/Apecs/Experimental/Stores.hs @@ -84,6 +84,7 @@ instance , Elem (s (Stack c)) ~ Stack c ) => ExplMembers m (Pushdown s c) where explMembers (Pushdown s) = explMembers s + explMemberSet (Pushdown s) = explMemberSet s instance (Storage c ~ Pushdown s c, Component c) => Component (Stack c) where type Storage (Stack c) = StackStore (Storage c) @@ -120,3 +121,4 @@ instance , ExplMembers m (s (Stack c)) ) => ExplMembers m (StackStore (Pushdown s c)) where explMembers (StackStore (Pushdown s)) = explMembers s + explMemberSet (StackStore (Pushdown s)) = explMemberSet s diff --git a/apecs/src/Apecs/Stores.hs b/apecs/src/Apecs/Stores.hs index 43266ad..3ed55af 100644 --- a/apecs/src/Apecs/Stores.hs +++ b/apecs/src/Apecs/Stores.hs @@ -23,6 +23,7 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Class (lift) import Data.Bits (shiftL, (.&.)) import qualified Data.IntMap.Strict as M +import qualified Data.IntSet as IS import Data.IORef import Data.Proxy import Data.Typeable (Typeable, typeRep) @@ -66,6 +67,8 @@ instance MonadIO m => ExplDestroy m (Map c) where instance MonadIO m => ExplMembers m (Map c) where {-# INLINE explMembers #-} explMembers (Map ref) = liftIO$ U.fromList . M.keys <$> readIORef ref + {-# INLINE explMemberSet #-} + explMemberSet (Map ref) = liftIO$ M.keysSet <$> readIORef ref -- | A Unique contains zero or one component. -- Writing to it overwrites both the previous component and its owner. @@ -101,6 +104,10 @@ instance MonadIO m => ExplMembers m (Unique c) where explMembers (Unique ref) = liftIO$ flip fmap (readIORef ref) $ \case Nothing -> mempty Just (ety, _) -> U.singleton ety + {-# INLINE explMemberSet #-} + explMemberSet (Unique ref) = liftIO$ flip fmap (readIORef ref) $ \case + Nothing -> mempty + Just (ety, _) -> IS.singleton ety -- | A 'Global' contains exactly one component. -- The initial value is 'mempty' from the component's 'Monoid' instance. @@ -226,6 +233,8 @@ instance ExplGet m s => ExplGet m (ReadOnly s) where instance ExplMembers m s => ExplMembers m (ReadOnly s) where {-# INLINE explMembers #-} explMembers (ReadOnly s) = explMembers s + {-# INLINE explMemberSet #-} + explMemberSet (ReadOnly s) = explMemberSet s setReadOnly :: forall w m s c. ( Has w m c diff --git a/apecs/src/Apecs/TH.hs b/apecs/src/Apecs/TH.hs index 5bfe364..4d04718 100644 --- a/apecs/src/Apecs/TH.hs +++ b/apecs/src/Apecs/TH.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} @@ -8,7 +9,11 @@ module Apecs.TH , makeWorldAndComponents , makeMapComponents , makeMapComponentsFor - , makeInstanceTuples + , hasStoreInstance + , makeInstanceFold + , mkFoldT + , mkTupleT + , mkEitherT ) where import Control.Monad (filterM) @@ -54,31 +59,73 @@ makeWorldNoEC worldName cTypes = do getStore = let field $pat = $(varE x) in asks field |] - -- Destructible type synonym - destructible_decl <- makeInstanceTuples (worldName ++ "Destructible") ''ExplDestroy cTypes + -- World-wide collections for particular types + let skip = ["Global", "ReadOnly"] + let m = ConT ''IO + destructible <- filterM (hasStoreInstance skip ''ExplDestroy m) cTypes + destructible_decl <- makeInstanceFold mkTupleT (worldName ++ "Destructible") destructible - pure $ data_decl : destructible_decl ++ concat (init_world : instances) + enumerable <- filterM (hasStoreInstance skip ''ExplMembers m) cTypes + enumerable_decl <- makeInstanceFold mkEitherT (worldName ++ "Enumerable") enumerable + + pure $ data_decl : destructible_decl : enumerable_decl : concat (init_world : instances) where enumerate :: [a] -> [(Int,a)] enumerate = zip [0..] -makeInstanceTuples :: String -> Name -> [Name] -> Q [Dec] -makeInstanceTuples synName cls cTypes = do - let destructible ty - | nameBase ty == "EntityCounter" = pure False - | otherwise = isInstance cls [ConT ''IO, AppT (ConT ''Storage) (ConT ty)] - destroyableTypes <- filterM destructible cTypes - let getType ty = ConT ty - decl <- tySynD (mkName synName) [] (pure $ mkTupleT $ getType <$> destroyableTypes) - return [decl] - mkTupleT :: [Type] -> Type mkTupleT [] = ConT ''() mkTupleT [t] = t mkTupleT ts | len <= 8 = foldl AppT (TupleT len) ts | otherwise = foldl AppT (TupleT 8) (take 7 ts ++ [mkTupleT (drop 7 ts)]) - where len = length ts + where + len = length ts + +mkEitherT :: [Type] -> Type +mkEitherT = mkFoldT ''Either ''() + +mkFoldT :: Name -> Name -> [Type] -> Type +mkFoldT _con nil [] = ConT nil +mkFoldT _con _nil [t] = t +mkFoldT con nil (t : ts) = AppT (AppT (ConT con) t) (mkFoldT con nil ts) + +makeInstanceFold :: ([Type] -> Type) -> String -> [Name] -> Q Dec +makeInstanceFold foldT synName cTypes = + tySynD (mkName synName) [] . pure $ + foldT $ map ConT cTypes + +-- | Resolve storage type and check for an instance like @ExplThis m (Map Position)@ +-- +-- Can be used to pre-filter component lists for 'makeInstanceFold'. +hasStoreInstance + :: [String] -- ^ Skip those stores + -> Name -- ^ Class name (ExplThis) + -> Type -- ^ @m@ var like @ConT ''IO@ + -> Name -- ^ component type name + -> Q Bool +hasStoreInstance skip cls mType cType = do + storageT <- resolveStorageType cType + case storageT of + Just (AppT (ConT store) _stored) + | nameBase store `elem` skip -> pure False + Just resolved -> isInstance cls [mType, resolved] + Nothing -> pure False + +-- | Resolve the @Storage@ type family for a component type. +-- +-- On GHC < 9.2, @isInstance@ does not reduce type family applications, +-- so we need to resolve @Storage ty@ before passing it to @isInstance@. +resolveStorageType :: Name -> Q (Maybe Type) +resolveStorageType ty = do + insts <- reifyInstances ''Storage [ConT ty] + pure $ case insts of +#if MIN_VERSION_template_haskell(2,15,0) + [TySynInstD (TySynEqn _ _ rhs)] -> Just rhs +#else + [TySynInstD _ (TySynEqn _ rhs)] -> Just rhs +#endif + _ -> Nothing -- | Creates 'Component' instances with 'Map' stores makeMapComponents :: [Name] -> Q [Dec] diff --git a/apecs/src/Apecs/Util.hs b/apecs/src/Apecs/Util.hs index 79a8d58..61d079c 100644 --- a/apecs/src/Apecs/Util.hs +++ b/apecs/src/Apecs/Util.hs @@ -14,6 +14,7 @@ module Apecs.Util ( -- * EntityCounter EntityCounter(..), nextEntity, newEntity, newEntity_, + Maybify, ) where import Control.Applicative (liftA2) @@ -66,3 +67,34 @@ newEntity_ component = do -- | Explicitly invoke the garbage collector runGC :: MonadIO m => SystemT w m () runGC = liftIO performMajorGC + +-- | Wrap tuple elements in Maybe. +-- +-- This allows to safely `get` component packs generated by @makeInstanceFold mkTupleT@. +type family Maybify t where + Maybify (Maybe a) = Maybe a + + Maybify () = () + + Maybify (a, b) = + (Maybify a, Maybify b) + + Maybify (a, b, c) = + (Maybify a, Maybify b, Maybify c) + + Maybify (a, b, c, d) = + (Maybify a, Maybify b, Maybify c, Maybify d) + + Maybify (a, b, c, d, e) = + (Maybify a, Maybify b, Maybify c, Maybify d, Maybify e) + + Maybify (a, b, c, d, e, f) = + (Maybify a, Maybify b, Maybify c, Maybify d, Maybify e, Maybify f) + + Maybify (a, b, c, d, e, f, g) = + (Maybify a, Maybify b, Maybify c, Maybify d, Maybify e, Maybify f, Maybify g) + + Maybify (a, b, c, d, e, f, g, h) = + (Maybify a, Maybify b, Maybify c, Maybify d, Maybify e, Maybify f, Maybify g, Maybify h) + + Maybify a = Maybe a diff --git a/apecs/test/Main.hs b/apecs/test/Main.hs index 92fe4a4..1cbd105 100644 --- a/apecs/test/Main.hs +++ b/apecs/test/Main.hs @@ -29,6 +29,7 @@ import Apecs.Experimental.Children import Apecs.Experimental.Reactive import Apecs.Experimental.Stores import Apecs.Stores +import Apecs.TH import Apecs.Util type Vec = (Double, Double) @@ -132,6 +133,38 @@ instance Component T3 where type Storage T3 = Map T3 makeWorld "Tuples" [''T1, ''T2, ''T3] +newtype G1 = G1 () deriving (Eq, Show, Arbitrary, Semigroup, Monoid) +instance Component G1 where type Storage G1 = Global G1 + +-- Tests Enumerable class +makeWorld "WorldEnumerable" [''G1, ''T1, ''T2, ''T3] +-- Generate a (T1, T2, T3) tuple in a contrived way +-- (that allows processing component lists when placed in external file) +pure <$> makeInstanceFold mkTupleT "WorldEnumerableShowable" [''T1, ''T2, ''T3] + +worldEntityIds :: System WorldEnumerable S.IntSet +worldEntityIds = do + s :: Storage WorldEnumerableEnumerable <- getStore + explMemberSet s + +prop_enumerable :: [Entity] -> [(Entity, (T1, T2))] -> [(Entity, T3)] -> Property +prop_enumerable dels t12s t3s = assertSys initWorldEnumerable $ do + forM_ t12s $ \(e, (t1, t2)) -> set e t1 >> set e t2 + forM_ t3s $ \(e, t3) -> set e t3 + + let expectedBefore = S.fromList (map (unEntity . fst) t12s ++ map (unEntity . fst) t3s) + actualBefore <- worldEntityIds + + everything <- forM (S.toList actualBefore) (get . Entity) + let it = show @[Maybify WorldEnumerableShowable] everything + guard (length it > 0) + + forM_ dels $ \e -> destroy e (Proxy @WorldEnumerableDestructible) + + let expectedAfter = expectedBefore `S.difference` S.fromList (map unEntity dels) + actualAfter <- worldEntityIds + return (expectedBefore == actualBefore && expectedAfter == actualAfter) + prop_setGetTuple = genericSetGet initTuples (undefined :: (T1,T2,T3)) prop_setSetTuple = genericSetSet initTuples (undefined :: (T1,T2,T3))