aztecs-hierarchy (empty) → 0.1.0.0

raw patch · 4 files changed

+210/−0 lines, 4 filesdep +QuickCheckdep +aztecsdep +aztecs-hierarchy

Dependencies added: QuickCheck, aztecs, aztecs-hierarchy, base, containers, hspec, linear, mtl

Files

LICENSE +29/−0
aztecs-hierarchy.cabal +47/−0
src/Data/Aztecs/Hierarchy.hs +106/−0
test/Main.hs +28/−0

+ LICENSE view

@@ -0,0 +1,29 @@+Copyright (c) 2024, Matt Hunzinger+++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of the copyright holder nor the names of its+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ aztecs-hierarchy.cabal view

@@ -0,0 +1,47 @@+cabal-version: 2.4+name:          aztecs-hierarchy+version:       0.1.0.0+license:       BSD-3-Clause+license-file:  LICENSE+maintainer:    matt@hunzinger.me+author:        Matt Hunzinger+synopsis:      A type-safe and friendly Entity-Component-System (ECS) for Haskell+description:   The Entity-Component-System (ECS) pattern is commonly used in video game develop to represent world objects.+               .+               ECS follows the principal of composition over inheritence. Each type of+               object (e.g. sword, monster, etc), in the game has a unique EntityId. Each+               entity has various Components associated with it (material, weight, damage, etc).+               Systems act on entities which have the required Components.+homepage:      https://github.com/matthunz/aztecs+category:      Game Engine++source-repository head+    type:     git+    location: https://github.com/matthunz/aztecs.git++library+    exposed-modules:+        Data.Aztecs.Hierarchy+    hs-source-dirs:   src+    default-language: Haskell2010+    ghc-options:      -Wall+    build-depends:+        base >=4 && <5,+        aztecs >= 0.3,+        containers >=0.7,+        mtl >=2,+        linear >= 1++test-suite aztecs-hierarchy-test+    type:             exitcode-stdio-1.0+    main-is:          Main.hs+    hs-source-dirs:   test+    default-language: Haskell2010+    ghc-options:      -Wall+    build-depends:+        base >=4 && <5,+        aztecs,+        aztecs-hierarchy,+        containers >=0.7,+        hspec >=2,+        QuickCheck >=2

+ src/Data/Aztecs/Hierarchy.hs view

@@ -0,0 +1,106 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE Arrows #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Data.Aztecs.Hierarchy where++import Control.Arrow (returnA)+import Data.Aztecs+import qualified Data.Aztecs.Access as A+import qualified Data.Aztecs.Query as Q+import qualified Data.Aztecs.System as S+import Data.Maybe (fromMaybe)+import Data.Set (Set)+import qualified Data.Set as Set++newtype Parent = Parent {unParent :: EntityID}+  deriving (Eq, Ord, Show)++instance Component Parent++newtype ParentState = ParentState {unParentState :: EntityID}+  deriving (Show)++instance Component ParentState++newtype Children = Children {unChildren :: Set EntityID}+  deriving (Eq, Ord, Show, Semigroup, Monoid)++instance Component Children++newtype ChildState = ChildState {unChildState :: Set EntityID}+  deriving (Show)++instance Component ChildState++update :: System () ()+update = proc () -> do+  parents <-+    S.all+      ( proc () -> do+          entity <- Q.entity -< ()+          Parent parent <- Q.fetch -< ()+          maybeParentState <- Q.fetchMaybe @_ @ParentState -< ()+          returnA -< (entity, parent, maybeParentState)+      )+      -<+        ()+  children <-+    S.all+      ( proc () -> do+          entity <- Q.entity -< ()+          Children cs <- Q.fetch -< ()+          maybeChildState <- Q.fetchMaybe @_ @ChildState -< ()+          returnA -< (entity, cs, maybeChildState)+      )+      -<+        ()+  S.queue+    ( \(parents, childRes) -> do+        mapM_+          ( \(entity, parent, maybeParentState) -> case maybeParentState of+              Just (ParentState parentState) -> do+                if parent /= parentState+                  then do+                    A.insert parent $ ParentState parent++                    -- Remove this entity from the previous parent's children.+                    maybeLastChildren <- A.lookup parentState+                    let lastChildren = fromMaybe mempty $ unChildren <$> maybeLastChildren+                    let lastChildren' = Set.filter (/= entity) lastChildren+                    A.insert parentState . Children $ lastChildren'++                    -- Add this entity to the new parent's children.+                    maybeChildren <- A.lookup parent+                    let parentChildren = fromMaybe mempty $ unChildren <$> maybeChildren+                    A.insert parent . Children $ Set.insert entity parentChildren+                  else return ()+              Nothing -> do+                A.spawn_ . bundle $ ParentState parent+                maybeChildren <- A.lookup parent+                let parentChildren = fromMaybe mempty $ unChildren <$> maybeChildren+                A.insert parent . Children $ Set.insert entity parentChildren+          )+          parents+        mapM_+          ( \(entity, children, maybeChildState) -> case maybeChildState of+              Just (ChildState childState) -> do+                if children /= childState+                  then do+                    A.insert entity $ ChildState children+                    let added = Set.difference children childState+                        removed = Set.difference childState children+                    mapM_ (\e -> A.insert e . Parent $ entity) added+                  else return ()+              Nothing -> do+                A.insert entity $ ChildState children+                mapM_ (\e -> A.insert e . Parent $ entity) children+          )+          childRes+    )+    -<+      (parents, children)

+ test/Main.hs view

@@ -0,0 +1,28 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Main (main) where++import Data.Aztecs+import Data.Aztecs.Hierarchy (Children (..), Parent (..))+import qualified Data.Aztecs.Hierarchy as Hierarchy+import qualified Data.Aztecs.Query as Q+import Data.Aztecs.System (runSystemWithWorld)+import qualified Data.Aztecs.World as W+import Data.Functor.Identity (Identity (..))+import qualified Data.Set as Set+import Test.Hspec+import Test.QuickCheck++main :: IO ()+main = hspec $ do+  describe "Data.Aztecs.Hierarchy.update" $ do+    it "adds Parent components to children" $ property prop_addParents++prop_addParents :: Expectation+prop_addParents = do+  let (_, w) = W.spawnEmpty W.empty+      (e, w') = W.spawn (bundle . Children $ Set.singleton e) w+  w'' <- runSystemWithWorld Hierarchy.update w'+  let (res, _) = runIdentity $ Q.all Q.fetch w''+  res `shouldMatchList` [Parent e]