diff --git a/apecs/apecs.cabal b/apecs/apecs.cabal index a0c5d63..5b94e28 100644 --- a/apecs/apecs.cabal +++ b/apecs/apecs.cabal @@ -34,6 +34,7 @@ library Apecs.Stores Apecs.System Apecs.TH + Apecs.TH.Tags Apecs.Util other-modules: Apecs.THTuples diff --git a/apecs/src/Apecs.hs b/apecs/src/Apecs.hs index 9ec8995..113c3c9 100644 --- a/apecs/src/Apecs.hs +++ b/apecs/src/Apecs.hs @@ -6,6 +6,7 @@ module Apecs ( -- * Core types SystemT, System, Component(..), Entity(..), Has(..), Not(..), Get, Set, Destroy, Members, + HasTags(..), WTag, -- * Stores Map, Unique, Global, Cache, diff --git a/apecs/src/Apecs/Core.hs b/apecs/src/Apecs/Core.hs index 540f644..274941a 100644 --- a/apecs/src/Apecs/Core.hs +++ b/apecs/src/Apecs/Core.hs @@ -81,3 +81,12 @@ 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)) type Destroy w m c = (Has w m c, ExplDestroy m (Storage c)) + +-- | The type of tags for a world, e.g. @WTag MyWorld = MyWorldTag@. +-- Standalone so that multiple @HasTags w m@ instances share one equation. +type family WTag w + +-- | @HasTags w m@ means that world @w@ has a tag system generated by @makeTaggedComponents@. +-- Provides a way to query component tags for entities, dispatching on the world type @w@. +class Monad m => HasTags w m where + entityTags :: Entity -> SystemT w m [WTag w] diff --git a/apecs/src/Apecs/TH/Tags.hs b/apecs/src/Apecs/TH/Tags.hs new file mode 100644 index 0000000..52d59a7 --- /dev/null +++ b/apecs/src/Apecs/TH/Tags.hs @@ -0,0 +1,212 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +module Apecs.TH.Tags + ( makeTaggedComponents + , makeComponentTags + , makeComponentSum + , makeTagLookup + , makeTagFromSum + , makeGetTags + , makeCountComponents + , makeHasTagsInstance + ) where + +import Control.Monad (filterM) +import Control.Monad.Trans.Class (lift) +import qualified Data.Vector.Unboxed as U +import Language.Haskell.TH + +import Apecs.Core +import Apecs.TH (hasStoreInstance) + +makeTaggedComponents :: String -> [Name] -> Q [Dec] +makeTaggedComponents worldName cTypes = do + tags <- makeComponentTags tagType tagPrefix cTypes + sums <- makeComponentSum sumType sumPrefix cTypes + getter <- makeTagLookup lookupFunName worldName tagType tagPrefix sumType sumPrefix cTypes + toTag <- makeTagFromSum tagFromSumFunName tagType tagPrefix sumType sumPrefix cTypes + + let skip = ["Global", "ReadOnly"] + let m = ConT ''IO + existing <- filterM (hasStoreInstance skip ''ExplGet m) cTypes + + getTags <- makeGetTags getTagsFunName worldName tagType tagPrefix existing + hasTagsInst <- makeHasTagsInstance worldName tagType getTagsFunName existing + + enumerable <- filterM (hasStoreInstance skip ''ExplMembers m) cTypes + countComps <- makeCountComponents countCompsFunName worldName tagType tagPrefix enumerable + + pure $ tags ++ sums ++ getter ++ toTag ++ getTags ++ hasTagsInst ++ countComps + where + tagType = worldName ++ "Tag" + tagPrefix = "T" + sumType = worldName ++ "Sum" + sumPrefix = "S" + lookupFunName = "lookup" ++ worldName ++ "Tag" + tagFromSumFunName = "tag" ++ sumType + getTagsFunName = "get" ++ worldName ++ "Tags" + countCompsFunName = "count" ++ worldName ++ "Components" + +-- | Creates an Enum of component tags +makeComponentTags :: String -> String -> [Name] -> Q [Dec] +makeComponentTags typeName consPrefix cTypes = pure [decl] + where + decl = DataD [] (mkName typeName) [] Nothing cons derivs + cons = map (\c -> NormalC (mkName $ consPrefix ++ nameBase c) []) cTypes + derivs = [ DerivClause Nothing (map ConT [''Eq, ''Ord, ''Show, ''Enum, ''Bounded]) ] + +-- | Creates a sum type of components +makeComponentSum :: String -> String -> [Name] -> Q [Dec] +makeComponentSum typeName consPrefix cTypes = pure [decl] + where + decl = DataD [] (mkName typeName) [] Nothing cons derivs + cons = map (\c -> NormalC (mkName $ consPrefix ++ nameBase c) [(Bang NoSourceUnpackedness NoSourceStrictness, ConT c)]) cTypes + derivs = [ DerivClause Nothing [ConT ''Show] ] + +makeTagLookup :: String -> String -> String -> String -> String -> String -> [Name] -> Q [Dec] +makeTagLookup funName worldName tagType tagPrefix sumType sumPrefix cTypes = do + m <- newName "m" + sig <- forallCompClsSig fName ''Get worldN m cTypes + [t| + Entity -> + $(conT (mkName tagType)) -> + SystemT $(conT worldN) $(varT m) (Maybe $(conT (mkName sumType))) + |] + e <- newName "e" + matches <- mapM (makeMatch e) cTypes + t <- newName "t" + let body = caseE (varE t) (map pure matches) + decl <- funD fName [clause [varP e, varP t] (normalB body) []] + pure [sig, decl] + where + makeMatch e cType = match (conP tagCon []) (normalB matchBody) [] + where + matchBody = [| fmap $(conE sumCon) <$> get $(varE e) |] + tagCon = mkName (tagPrefix ++ nameBase cType) + sumCon = mkName (sumPrefix ++ nameBase cType) + fName = mkName funName + worldN = mkName worldName + +makeTagFromSum :: String -> String -> String -> String -> String -> [Name] -> Q [Dec] +makeTagFromSum funName tagType tagPrefix sumType sumPrefix cTypes = do + s <- newName "s" + + sig <- sigD fName [t| $(conT sumN) -> $(conT tagN) |] + + matches <- mapM makeMatch cTypes + let body = caseE (varE s) (map pure matches) + decl <- funD fName [clause [varP s] (normalB body) []] + pure [sig, decl] + where + makeMatch cType = match (conP sumCon [wildP]) (normalB (conE tagCon)) [] + where + tagCon = mkName (tagPrefix ++ nameBase cType) + sumCon = mkName (sumPrefix ++ nameBase cType) + fName = mkName funName + tagN = mkName tagType + sumN = mkName sumType + +-- | For each component type, get store and use explExists on the given entity +makeGetTags :: String -> String -> String -> String -> [Name] -> Q [Dec] +makeGetTags funName worldName tagType tagPrefix cTypes = do + m <- newName "m" + sig <- forallCompClsSig fName ''Get worldN m cTypes + [t| + Entity -> + SystemT $(conT worldN) $(varT m) [$(conT $ mkName tagType)] + |] + e <- newName "e" + stmts <- mapM (makeStmt m e) cTypes + decl <- funD fName [clause [varP e] (bodyS stmts) []] + pure [sig, decl] + where + fName = mkName funName + worldN = mkName worldName + makeStmt m e cType = bindS (varP tagName) body + where + tagName = mkName ("tag_" ++ nameBase cType) + tagCon = mkName (tagPrefix ++ nameBase cType) + body = [| + do + s <- getStore :: SystemT $(conT worldN) $(varT m) (Storage $(conT cType)) + has <- lift $ explExists s (unEntity $(varE e)) + pure [$(conE tagCon) | has] + |] + bodyS stmts = normalB . doE $ map pure stmts ++ [resultE] + where + tagNames = map (varE . mkName . ("tag_" ++) . nameBase) cTypes + resultE = noBindS . appE (varE 'pure) $ appE (varE 'concat) $ listE tagNames + +-- | Generates a standalone @type instance WTag World = WorldTag@ and a +-- @HasTags World m@ instance delegating @entityTags@ to the generated +-- @getWorldTags@ function. +makeHasTagsInstance :: String -> String -> String -> [Name] -> Q [Dec] +makeHasTagsInstance worldName tagType getTagsFunName cTypes = do + m <- newName "m" + instDec <- instanceD + ((:) <$> [t| Monad $(varT m) |] <*> worldConstraints ''Get worldN m cTypes) + [t| HasTags $(conT worldN) $(varT m) |] + [ valD + (varP 'entityTags) + (normalB . varE $ mkName getTagsFunName) + [] + ] + + let tySynDec = +#if MIN_VERSION_template_haskell(2,15,0) + TySynInstD $ TySynEqn Nothing (ConT ''WTag `AppT` ConT worldN) (ConT tagN) +#else + TySynInstD ''WTag $ TySynEqn [ConT worldN] (ConT tagN) +#endif + pure [tySynDec, instDec] + where + worldN = mkName worldName + tagN = mkName tagType + +-- | For each component type with ExplMembers, count the number of entities that have that component. +makeCountComponents :: String -> String -> String -> String -> [Name] -> Q [Dec] +makeCountComponents funName worldName tagType tagPrefix cTypes = do + m <- newName "m" + sig <- forallCompClsSig fName ''Members worldN m cTypes + [t| SystemT $(conT worldN) $(varT m) [($(conT tagN), Int)] |] + stmts <- mapM (makeStmt m) cTypes + decl <- funD fName [clause [] (bodyS stmts) []] + pure [sig, decl] + where + fName = mkName funName + tagN = mkName tagType + worldN = mkName worldName + makeStmt m cType = bindS (varP countName) body + where + countName = mkName ("count_" ++ nameBase cType) + tagCon = mkName (tagPrefix ++ nameBase cType) + body = [| + do + s <- getStore :: SystemT $(conT (mkName worldName)) $(varT m) (Storage $(conT cType)) + members <- lift $ explMembers s + pure ($(conE tagCon), U.length members) + |] + bodyS stmts = normalB . doE $ map pure stmts ++ [resultE] + where + countNames = map (varE . mkName . ("count_" ++) . nameBase) cTypes + resultE = noBindS . appE (varE 'pure) $ listE countNames + +-- | Build a @f :: forall m. (Cls World m C1, ...) => body@ type signature +forallCompClsSig :: Name -> Name -> Name -> Name -> [Name] -> Q Type -> Q Dec +forallCompClsSig fName cls worldN m cTypes mkBody = + sigD fName $ forallT [mkPlainTV m] (worldConstraints cls worldN m cTypes) mkBody + +worldConstraints :: Name -> Name -> Name -> [Name] -> Q Cxt +worldConstraints cls worldN m = traverse $ \c -> + [t| $(conT cls) $(conT worldN) $(varT m) $(conT c) |] + +#if MIN_VERSION_template_haskell(2,17,0) +mkPlainTV :: Name -> TyVarBndr Specificity +mkPlainTV n = PlainTV n SpecifiedSpec +#else +mkPlainTV :: Name -> TyVarBndr +mkPlainTV = PlainTV +#endif diff --git a/apecs/src/Apecs/Util.hs b/apecs/src/Apecs/Util.hs index 61d079c..6ee1ffc 100644 --- a/apecs/src/Apecs/Util.hs +++ b/apecs/src/Apecs/Util.hs @@ -15,13 +15,19 @@ module Apecs.Util ( -- * EntityCounter EntityCounter(..), nextEntity, newEntity, newEntity_, Maybify, + + -- * Census + countCombinations, ) where import Control.Applicative (liftA2) import Control.Monad.IO.Class import Control.Monad.Trans.Class (lift) +import qualified Data.IntSet as IS +import qualified Data.Map.Strict as M import Data.Monoid import Data.Semigroup +import qualified Data.Set as S import System.Mem (performMajorGC) import Apecs.Core @@ -68,6 +74,24 @@ newEntity_ component = do runGC :: MonadIO m => SystemT w m () runGC = liftIO performMajorGC +-- | Count entities grouped by their distinct component combination. +-- +-- Takes the world's entity member set and uses 'entityTags' from the +-- 'HasTags' class to query each entity's tags. Returns a map from tag sets +-- to entity counts. +countCombinations + :: (HasTags w m, Enum (WTag w), Ord (WTag w)) + => IS.IntSet -- ^ Entity IDs to census + -> SystemT w m (M.Map (S.Set (WTag w)) Int) +countCombinations entities = do + tagSets <- mapM poll (IS.toList entities) + let counts = M.fromListWith (+) [(ts, 1 :: Int) | ts <- tagSets] + pure $ M.mapKeysMonotonic (S.fromList . map toEnum . IS.toList) counts + where + poll eid = do + tags <- entityTags (Entity eid) + pure $! IS.fromList (map fromEnum tags) + -- | Wrap tuple elements in Maybe. -- -- This allows to safely `get` component packs generated by @makeInstanceFold mkTupleT@. diff --git a/apecs/test/Main.hs b/apecs/test/Main.hs index 1cbd105..c8f8d5d 100644 --- a/apecs/test/Main.hs +++ b/apecs/test/Main.hs @@ -1,11 +1,13 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -18,6 +20,9 @@ import qualified Data.Foldable as F import qualified Data.IntSet as S import Data.IORef import Data.List ((\\), delete, nub, sort) +import qualified Data.IntMap.Strict as IM +import qualified Data.Map.Strict as M +import qualified Data.Set as Set import qualified Data.Vector.Unboxed as U import Test.QuickCheck import Test.QuickCheck.Monadic @@ -30,6 +35,7 @@ import Apecs.Experimental.Reactive import Apecs.Experimental.Stores import Apecs.Stores import Apecs.TH +import Apecs.TH.Tags import Apecs.Util type Vec = (Double, Double) @@ -138,6 +144,7 @@ instance Component G1 where type Storage G1 = Global G1 -- Tests Enumerable class makeWorld "WorldEnumerable" [''G1, ''T1, ''T2, ''T3] +makeTaggedComponents "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] @@ -165,6 +172,86 @@ prop_enumerable dels t12s t3s = assertSys initWorldEnumerable $ do actualAfter <- worldEntityIds return (expectedBefore == actualBefore && expectedAfter == actualAfter) +prop_tags_lookup :: [(Entity, (T1, T2))] -> [(Entity, T3)] -> Property +prop_tags_lookup t12s t3s = assertSys initWorldEnumerable $ do + forM_ t12s $ \(e, (t1, t2)) -> set e t1 >> set e t2 + forM_ t3s $ \(e, t3) -> set e t3 + + entities <- worldEntityIds + + eav <- fmap M.fromList . forM (map Entity $ S.toList entities) $ \e -> do + tagged <- forM [minBound .. maxBound] $ \t -> fmap (t,) <$> lookupWorldEnumerableTag e t + pure (e, M.fromList [ (t, v) | Just (t, v) <- tagged ]) + + let it = show (eav :: M.Map Entity (M.Map WorldEnumerableTag WorldEnumerableSum)) + guard (length it > 0) + + pure True + +prop_tags_get :: [(Entity, (T1, T2))] -> [(Entity, T3)] -> Property +prop_tags_get t12s t3s = assertSys initWorldEnumerable $ do + forM_ t12s $ \(e, (t1, t2)) -> set e t1 >> set e t2 + forM_ t3s $ \(e, t3) -> set e t3 + + -- arbitrary will produce overlapping entity sets for t12s and t3s + -- the correct set of components for each entity is known at runtime + let has_t12s = S.fromList (map (unEntity . fst) t12s) + let has_t3s = S.fromList (map (unEntity . fst) t3s) + + forM_ (S.toList $ has_t12s <> has_t3s) $ \ety -> do + let t12 = [[TT1, TT2] | ety `S.member` has_t12s] + let t3 = [[TT3] | ety `S.member` has_t3s] + let + expected = + -- XXX: matching the order is important. + -- getWorldEnumerableTags will iterate in the "constructor order" + -- derived from the filtered component type list. + concat (t12 ++ t3) + tags <- entityTags $ Entity ety + unless (tags == expected) $ do + error $ show (tags, expected) + + pure True + +prop_count_components :: [(Entity, T1)] -> [(Entity, T2)] -> [(Entity, T3)] -> Property +prop_count_components t1s t2s t3s = assertSys initWorldEnumerable $ do + forM_ t1s $ uncurry set + forM_ t2s $ uncurry set + forM_ t3s $ uncurry set + + counts <- countWorldEnumerableComponents + let countMap = M.fromList counts + + let expectedT1 = length $ nub $ map fst t1s + let expectedT2 = length $ nub $ map fst t2s + let expectedT3 = length $ nub $ map fst t3s + + -- G1 is Global and should not appear in counts + return $ M.lookup TT1 countMap == Just expectedT1 + && M.lookup TT2 countMap == Just expectedT2 + && M.lookup TT3 countMap == Just expectedT3 + && M.lookup TG1 countMap == Nothing + +prop_count_combinations :: [(Entity, (T1, T2))] -> [(Entity, T3)] -> Property +prop_count_combinations t12s t3s = assertSys initWorldEnumerable $ do + forM_ t12s $ \(e, (t1, t2)) -> set e t1 >> set e t2 + forM_ t3s $ \(e, t3) -> set e t3 + + entities <- worldEntityIds + combos <- countCombinations entities + + let has_t12s = S.fromList (map (unEntity . fst) t12s) + let has_t3s = S.fromList (map (unEntity . fst) t3s) + let entityTags ety = + (if ety `S.member` has_t12s then [TT1, TT2] else []) + ++ (if ety `S.member` has_t3s then [TT3] else []) + let expected = M.fromListWith (+) + [ (Set.fromList (entityTags ety), 1 :: Int) + | ety <- S.toList (has_t12s <> has_t3s) + ] + + return $ combos == expected + prop_setGetTuple = genericSetGet initTuples (undefined :: (T1,T2,T3)) prop_setSetTuple = genericSetSet initTuples (undefined :: (T1,T2,T3))