aztecs 0.4.0.0 → 0.4.0.1

raw patch · 5 files changed

+91/−30 lines, 5 filesdep +QuickCheckPVP: minor bump suggested

API additions: PVP suggests at least a minor version bump

Dependencies added: QuickCheck

API changes (from Hackage documentation)

Files

• aztecs.cabal +3/−2
• bench/Iter.hs +16/−6
• src/Data/Aztecs/Access.hs +6/−0
• src/Data/Aztecs/World.hs +32/−9
• test/Main.hs +34/−13

@@ -1,6 +1,6 @@ cabal-version: 2.4 name:          aztecs-version:       0.4.0.0+version:       0.4.0.1 license:       BSD-3-Clause license-file:  LICENSE maintainer:    matt@hunzinger.me@@ -60,7 +60,8 @@     build-depends:         base >=4 && <5,         aztecs,-        hspec >=2+        hspec >=2,+        QuickCheck >=2  benchmark aztecs-bench     type:             exitcode-stdio-1.0

@@ -1,10 +1,10 @@+{-# LANGUAGE Arrows #-} {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE MultiParamTypeClasses #-}  import Criterion.Main import Data.Aztecs import qualified Data.Aztecs.Query as Q-import Data.Aztecs.World (World)+import qualified Data.Aztecs.System as S import qualified Data.Aztecs.World as W  newtype Position = Position Int deriving (Show)@@ -15,17 +15,27 @@  instance Component Velocity -run :: World -> World-run w = let !(_, w') = Q.mapWorld (\(Velocity v :& Position x) -> Position (x + v)) w in w'+run :: World -> IO ()+run w = do+  let s =+        const ()+          <$> S.map+            ( proc () -> do+                Velocity v <- Q.fetch -< ()+                Position p <- Q.fetch -< ()+                Q.set -< Position $ p + v+            )+  !_ <- S.runSystemWithWorld s w+  return ()  main :: IO () main = do   let !w =         foldr           ( \_ wAcc ->-              let (e, wAcc') = W.spawn (Position 0) wAcc+              let (e, wAcc') = W.spawn (bundle $ Position 0) wAcc                in W.insert e (Velocity 1) wAcc'           )           W.empty           [0 :: Int .. 10000]-  defaultMain [bench "iter" $ whnf run w]+  defaultMain [bench "iter" $ nfIO (run w)]

@@ -10,6 +10,7 @@     spawn,     spawn_,     insert,+    lookup,     despawn,   ) where@@ -54,6 +55,11 @@   w <- get   let w' = W.insert e c w   put w'++lookup :: (Monad m, Component a) => EntityID -> Access m (Maybe a)+lookup e = Access $ do+  w <- get+  return $ W.lookup e w  despawn :: (Monad m) => EntityID -> Access m () despawn e = Access $ do

@@ -14,6 +14,7 @@     spawnEmpty,     insert,     insertWithId,+    lookup,     despawn,   ) where@@ -35,6 +36,7 @@ import Data.Maybe (fromMaybe) import qualified Data.Set as Set import Data.Typeable (Proxy (..), Typeable, typeOf)+import Prelude hiding (lookup)  -- | World of entities and their components. data World = World@@ -58,17 +60,17 @@ spawn :: Bundle -> World -> (EntityID, World) spawn b w =   let (eId, w') = spawnEmpty w-      (cIds, components', dynB) = unBundle b (components w)-   in case AS.lookupArchetypeId cIds (archetypes w) of+      (cIds, components', dynB) = unBundle b (components w')+   in case AS.lookupArchetypeId cIds (archetypes w') of         Just aId -> fromMaybe (eId, w') $ do-          node <- AS.lookupNode aId (archetypes w)+          node <- AS.lookupNode aId (archetypes w')           let arch' = runDynamicBundle dynB eId (nodeArchetype node)           return             ( eId,-              w-                { archetypes = (archetypes w) {AS.nodes = Map.insert aId node {nodeArchetype = arch'} (AS.nodes $ archetypes w)},+              w'+                { archetypes = (archetypes w') {AS.nodes = Map.insert aId node {nodeArchetype = arch'} (AS.nodes $ archetypes w)},                   components = components',-                  entities = Map.insert eId aId (entities w)+                  entities = Map.insert eId aId (entities w')                 }             )         Nothing ->@@ -87,7 +89,7 @@            in ( eId,                 w'                   { archetypes = arches,-                    entities = Map.insert eId aId (entities w),+                    entities = Map.insert eId aId (entities w'),                     components = components'                   }               )@@ -202,7 +204,7 @@                               nextAId                               (AS.nodes $ archetypes w')                         },-                    entities = Map.insert e nextAId (entities w)+                    entities = Map.insert e nextAId (entities w')                   }           Nothing ->             let (s, arch') = A.removeStorages e (nodeArchetype node)@@ -229,7 +231,28 @@                     entities = Map.insert e nextAId (entities w)                   }     Nothing -> w-  Nothing -> w+  Nothing -> case AS.lookupArchetypeId (Set.singleton cId) (archetypes w) of+    Just aId -> spawnWithArchetypeId' e aId cId c w+    Nothing ->+      let (aId, arches) =+            AS.insertArchetype+              (Set.singleton cId)+              ( Node+                  { nodeComponentIds = Set.singleton cId,+                    nodeArchetype = A.insertComponent e cId c A.empty,+                    nodeAdd = Map.empty,+                    nodeRemove = Map.empty+                  }+              )+              (archetypes w)+       in w {archetypes = arches, entities = Map.insert e aId (entities w)}++lookup :: forall a. (Component a) => EntityID -> World -> Maybe a+lookup e w = do+  cId <- CS.lookup @a (components w)+  aId <- Map.lookup e (entities w)+  node <- AS.lookupNode aId (archetypes w)+  A.lookupComponent e cId (nodeArchetype node)  -- | Despawn an entity, returning its components. despawn :: EntityID -> World -> (Map ComponentID Dynamic, World)

@@ -1,33 +1,54 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+ module Main (main) where  import Control.Arrow ((&&&)) import Data.Aztecs import qualified Data.Aztecs.Query as Q import qualified Data.Aztecs.World as W+import Data.Functor.Identity (Identity (..)) import Test.Hspec+import Test.QuickCheck -newtype X = X Int deriving (Eq, Show)+newtype X = X Int deriving (Eq, Show, Arbitrary)  instance Component X -newtype Y = Y Int deriving (Eq, Show)+newtype Y = Y Int deriving (Eq, Show, Arbitrary)  instance Component Y -newtype Z = Z Int deriving (Eq, Show)+newtype Z = Z Int deriving (Eq, Show, Arbitrary)  instance Component Z  main :: IO () main = hspec $ do   describe "Data.Aztecs.Query.all" $ do-    it "queries multiple components" $ do-      let (_, w) = W.spawn (bundle $ X 0) W.empty-          (_, w') = W.spawn (bundle $ X 1) w-      (xs, _) <- Q.all (Q.fetch) w'-      xs `shouldMatchList` [X 0, X 1]-    it "queries a group of components" $ do-      let (e, w) = W.spawn (bundle $ X 0) W.empty-          w' = W.insert e (Y 1) w-      (xs, _) <- Q.all (Q.fetch &&& Q.fetch) w'-      xs `shouldMatchList` [(X 0, Y 1)]+    it "queries a single component" $ property prop_queryOneComponent+    it "queries two components" $ property prop_queryTwoComponents+    it "queries three components" $ property prop_queryThreeComponents++prop_queryOneComponent :: [X] -> Expectation+prop_queryOneComponent xs =+  let w = foldr (\x -> snd . W.spawn (bundle x)) W.empty xs+      (res, _) = runIdentity $ Q.all Q.fetch w+   in res `shouldMatchList` xs++prop_queryTwoComponents :: [(X, Y)] -> Expectation+prop_queryTwoComponents xys =+  let w = foldr (\(x, y) -> snd . W.spawn (bundle x <> bundle y)) W.empty xys+      (res, _) = runIdentity $ Q.all (Q.fetch &&& Q.fetch) w+   in res `shouldMatchList` xys++prop_queryThreeComponents :: [(X, Y, Z)] -> Expectation+prop_queryThreeComponents xyzs =+  let w = foldr (\(x, y, z) -> snd . W.spawn (bundle x <> bundle y <> bundle z)) W.empty xyzs+      q = do+        x <- Q.fetch+        y <- Q.fetch+        z <- Q.fetch+        pure (x, y, z)+      (res, _) = runIdentity $ Q.all q w+   in res `shouldMatchList` xyzs