mischief-ecs 0.1.0.0 → 0.2.0.0

raw patch · 102 files changed

+7576/−7217 lines, 102 filesdep +exceptionsdep +string-interpolatedep −binarydep −bytestringdep −hashabledep ~basedep ~containersdep ~data-defaultnew-component:exe:example-startupPVP ok

version bump matches the API change (PVP)

Dependencies added: exceptions, string-interpolate

Dependencies removed: binary, bytestring, hashable

Dependency ranges changed: base, containers, data-default, mischief-ecs, primitive, random, text, time, transformers

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−2
• README.md +11/−0
• benchmarks/bench-insert.hs +3/−6
• benchmarks/bench-spawn.hs +5/−9
• benchmarks/bench-update.hs +7/−9
• examples/Dungeon.hs +164/−134
• examples/Startup.hs +67/−0
• mischief-ecs.cabal +86/−56
• src/Mischief/ECS.hs +86/−168
• src/Mischief/ECS/App.hs +118/−62
• src/Mischief/ECS/App/Plugins.hs +39/−37
• src/Mischief/ECS/App/Schedules.hs +21/−20
• src/Mischief/ECS/App/SystemConfig.hs +0/−42
• src/Mischief/ECS/App/SystemDef.hs +0/−1
• src/Mischief/ECS/App/Systems.hs +27/−36
• src/Mischief/ECS/Archetypes.hs +4/−8
• src/Mischief/ECS/Archetypes/Graph.hs +100/−107
• src/Mischief/ECS/Collectable.hs +0/−2
• src/Mischief/ECS/Components.hs +112/−48
• src/Mischief/ECS/Components/Bundle.hs +24/−10
• src/Mischief/ECS/Components/Common.hs +1/−1
• src/Mischief/ECS/Components/HooksDef.hs +9/−4
• src/Mischief/ECS/Components/Required.hs +44/−8
• src/Mischief/ECS/Components/Runnable.hs +0/−25
• src/Mischief/ECS/Components/Spawn.hs +66/−42
• src/Mischief/ECS/Entities.hs +40/−36
• src/Mischief/ECS/EntityDef.hs +13/−10
• src/Mischief/ECS/Events.hs +14/−32
• src/Mischief/ECS/Exports.hs +12/−0
• src/Mischief/ECS/Fixed.hs +108/−0
• src/Mischief/ECS/Foreign.hs +11/−0
• src/Mischief/ECS/Graph.hs +0/−92
• src/Mischief/ECS/Hidden.hs +1/−1
• src/Mischief/ECS/Hooks.hs +5/−88
• src/Mischief/ECS/HooksRel.hs +115/−0
• src/Mischief/ECS/Interval.hs +0/−30
• src/Mischief/ECS/Log.hs +9/−18
• src/Mischief/ECS/Mappable.hs +0/−106
• src/Mischief/ECS/Messages.hs +10/−17
• src/Mischief/ECS/Observer.hs +1/−6
• src/Mischief/ECS/Observers.hs +0/−10
• src/Mischief/ECS/Prelude.hs +0/−57
• src/Mischief/ECS/Relationships.hs +0/−7
• src/Mischief/ECS/Relationships/ChildOf.hs +9/−11
• src/Mischief/ECS/Relationships/Graph.hs +28/−11
• src/Mischief/ECS/Relationships/Order.hs +8/−13
• src/Mischief/ECS/Relationships/Tree.hs +28/−25
• src/Mischief/ECS/Repeater.hs +47/−0
• src/Mischief/ECS/Resources.hs +52/−10
• src/Mischief/ECS/Schedules.hs +7/−4
• src/Mischief/ECS/Stdin.hs +2/−0
• src/Mischief/ECS/Systems.hs +68/−38
• src/Mischief/ECS/Tables.hs +110/−113
• src/Mischief/ECS/Time.hs +70/−19
• src/Mischief/ECS/Timer.hs +4/−0
• src/Mischief/ECS/Tutorial/App.hs +0/−179
• src/Mischief/ECS/Tutorial/Components.hs +0/−573
• src/Mischief/ECS/Tutorial/Dungeon.hs +0/−1229
• src/Mischief/ECS/Tutorial/Events.hs +0/−99
• src/Mischief/ECS/Tutorial/Guides/Basics.hs +281/−0
• src/Mischief/ECS/Tutorial/Guides/Change.hs +140/−0
• src/Mischief/ECS/Tutorial/Guides/Events.hs +91/−0
• src/Mischief/ECS/Tutorial/Guides/MonadicQueries.hs +263/−0
• src/Mischief/ECS/Tutorial/Guides/Organizing.hs +76/−0
• src/Mischief/ECS/Tutorial/Guides/Parallelism.hs +118/−0
• src/Mischief/ECS/Tutorial/Guides/QuasiConversion.hs +125/−0
• src/Mischief/ECS/Tutorial/Guides/QueryBasics.hs +150/−0
• src/Mischief/ECS/Tutorial/Guides/QueryPiping.hs +205/−0
• src/Mischief/ECS/Tutorial/Guides/Scheduling.hs +187/−0
• src/Mischief/ECS/Tutorial/Guides/Time.hs +83/−0
• src/Mischief/ECS/Tutorial/Introduction/Dungeon.hs +1194/−0
• src/Mischief/ECS/Tutorial/Introduction/Startup.hs +426/−0
• src/Mischief/ECS/Tutorial/Queries.hs +0/−322
• src/Mischief/ECS/Tutorial/Relationships.hs +0/−402
• src/Mischief/ECS/Tutorial/Startup.hs +0/−431
• src/Mischief/ECS/Tutorial/Systems.hs +0/−397
• src/Mischief/ECS/Utils.hs +52/−4
• src/Mischief/ECS/Vec.hs +65/−65
• src/Mischief/ECS/World.hs +143/−60
• src/Mischief/ECS/World/Change.hs +51/−44
• src/Mischief/ECS/World/Defer.hs +46/−68
• src/Mischief/ECS/World/Insert.hs +132/−141
• src/Mischief/ECS/World/Modify.hs +0/−70
• src/Mischief/ECS/World/Par.hs +67/−28
• src/Mischief/ECS/World/Prefs.hs +0/−14
• src/Mischief/ECS/World/Query.hs +349/−101
• src/Mischief/ECS/World/Query/Markers.hs +4/−0
• src/Mischief/ECS/World/Query/Pipe.hs +359/−0
• src/Mischief/ECS/World/Query/QueryFilter.hs +32/−219
• src/Mischief/ECS/World/Query/QueryType.hs +0/−6
• src/Mischief/ECS/World/Query/Queryable.hs +420/−343
• src/Mischief/ECS/World/Query/TH.hs +50/−59
• src/Mischief/ECS/World/Query/TH/Common.hs +34/−38
• src/Mischief/ECS/World/Query/TH/QD.hs +75/−67
• src/Mischief/ECS/World/Query/TH/QF.hs +73/−89
• src/Mischief/ECS/World/Remove.hs +48/−65
• src/Mischief/ECS/World/Spawn.hs +63/−57
• src/Mischief/ECS/World/Systems.hs +0/−1
• src/Mischief/ECS/World/Utils.hs +117/−150
• test/Changes.hs +114/−0
• test/Main.hs +107/−305
• test/Utils.hs +64/−0

@@ -1,5 +1,9 @@ # Revision history for mischief -## 0.1.0.0 -- YYYY-mm-dd+## 0.2.0.0  -* First version. Released on an unsuspecting world.+Almost a full rework of the high-level API in the previous version. The ECS is now designed to encourage functional coding. Also many performance improvements and bug fixes. ++## 0.1.0.0 ++First version. Released on an unsuspecting world. 

@@ -0,0 +1,11 @@+# Mischief ++This is the ECS library for the Mischief game engine. It is the root of every other library that's part of the engine. In other words, this is the source of all Mischief. ++It is meant to be a simple, yet powerful archetype ECS written fully in Haskell, that provides a unique blend of Data-Oriented Design+and Functional Programming.++To contribute, you can file issues, such as bug reports and feature requests, in the official [repository](https://codeberg.org/mischief/mischief).+You can also join the official server on discord to be kept up to date with updates and chat with the rest of the community. Link in the aforementioned repo. ++Check out the [Learn You an ECS for Great Mischief](https://hackage-content.haskell.org/package/mischief-ecs/docs/Mischief-ECS.html) book to learn about using this library! 

@@ -12,12 +12,11 @@ main :: IO () main =   defaultMainWith-    defaultConfig {reportFile = Just "/home/pvd/GameRepos/mischief/benches/insert.html"}+    defaultConfig {reportFile = Just "/home/pvd/mischief/benches/insert.html"}     [ benchInsert 10,       benchInsert 100,       benchInsert 1000,-      benchInsert 10000,-      benchInsert 100000+      benchInsert 10000     ]  benchInsert :: Int -> Benchmark@@ -31,11 +30,9 @@  mkEs :: Int -> IO (Es, W) mkEs n = do-  app <- newApp P+  app <- newApp   es <- runSystem (replicateM n (spawn ())) app.world   pure (Es es, W app.world)--data P = P deriving (Eq, Plugin)  data Comp1 = Comp1 deriving (Component) 

@@ -13,21 +13,19 @@  flame :: IO () flame = do-  app <- newApp P+  app <- newApp   runSystem (spawnEntities 100000 2 5) app.world  main :: IO () main =   -- flame   defaultMainWith-    defaultConfig {reportFile = Just "/home/pvd/GameRepos/mischief/benches/spawn.html"}+    defaultConfig {reportFile = Just "/home/pvd/mischief/benches/spawn.html"}     [ bgroup         "Spawn"         [ benchSpawnEntities 10,           benchSpawnEntities 100,-          benchSpawnEntities 1000,-          benchSpawnEntities 10000,-          benchSpawnEntities 100000+          benchSpawnEntities 10000         ]     ] @@ -35,14 +33,14 @@ benchSpawnEntities a = bgroup (show a ++ " Entities") $ [benchSpawnComponents a b | b <- [2, 5]]  benchSpawnComponents :: Int -> Int -> Benchmark-benchSpawnComponents a b = bgroup (show b ++ " Components") $ [env mkWorld (benchSpawnArchetypes a b c) | c <- [1, 2, 4, 5]]+benchSpawnComponents a b = bgroup (show b ++ " Components") $ [env mkWorld (benchSpawnArchetypes a b c) | c <- [1, 5]]  benchSpawnArchetypes :: Int -> Int -> Int -> W -> Benchmark benchSpawnArchetypes a b c w = bench (show c ++ " Archetypes") $ nfIO (benchSpawn a b c w)  mkWorld :: IO W mkWorld = do-  app <- newApp P+  app <- newApp   pure $ W app.world  newtype W = W World@@ -54,8 +52,6 @@ benchSpawn :: Int -> Int -> Int -> W -> IO () benchSpawn ne nc na (W world) =   runSystem (spawnEntities ne nc na) world--data P = P deriving (Eq, Plugin)  data Comp11 = Comp11 deriving (Component) 

@@ -10,16 +10,15 @@ main :: IO () main =   defaultMainWith-    defaultConfig {reportFile = Just "/home/pvd/GameRepos/mischief/benches/update.html"}+    defaultConfig {reportFile = Just "/home/pvd/mischief/benches/update.html"}     [ benchEntities 10,       benchEntities 100,       benchEntities 1000,-      benchEntities 10000,-      benchEntities 100000+      benchEntities 10000     ]  benchEntities :: Int -> Benchmark-benchEntities a = bgroup (show a ++ " Entities") $ [env (mkWorld a) $ benchUpdates a b | b <- [1, 4, 8]]+benchEntities a = bgroup (show a ++ " Entities") $ [env (mkWorld a) $ benchUpdates a b | b <- [1]]  benchUpdates :: Int -> Int -> W -> Benchmark benchUpdates a b w = bench (show b ++ " Updates") $ nfIO $ benchUpdate a b w@@ -36,16 +35,15 @@  mkWorld :: Int -> IO W mkWorld n = do-  app <- newApp P+  app <- newApp   runSystem (pre n) app.world   pure $ W app.world -data P = P deriving (Eq, Plugin)- pre :: Int -> System () pre m = replicateM_ m (spawn Comp1)  up :: System () up = do-  q <- query (C @Comp1)-  for_ q $ flip set Comp1+  [q|Comp1|]+    & qinsert (const Comp1)+    & query_

@@ -1,87 +1,78 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE MultiWayIf #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+{-# OPTIONS_GHC -Wno-type-defaults #-}  {- HLINT ignore "Use newtype instead of data" -}  module Main where -import Control.Monad (void, when)+import Control.Monad import Control.Monad.IO.Class import Data.Default import Data.Foldable import Data.List ((!?)) import Data.Traversable import Mischief.ECS-import Mischief.ECS.Hooks qualified as Hooks-import Mischief.ECS.Interval qualified as Interval-import Mischief.ECS.Observers qualified as Observers import Mischief.ECS.Stdin qualified as Stdin import Mischief.ECS.Stdout-import Mischief.ECS.Systems qualified as Systems-import Mischief.ECS.Timer (Timer)+import Mischief.ECS.Time qualified as Time import Mischief.ECS.Timer qualified as Timer-import Mischief.ECS.World.Query.QueryType-import System.Exit+import System.Exit (exitSuccess) import System.Random import System.Random.Stateful -data Likes = Likes Int deriving (Show)--instance Component Likes where-  hooks = Hooks.relCleanupRemove- main :: IO () main = do-  app <- newApp MainPlugin+  app <- newApp+  addPlugin @MainPlugin app   runApp app -data MainPlugin = MainPlugin deriving (Eq)+data MainPlugin  instance Plugin MainPlugin where-  init _ = do+  init = do     Stdin.init-    Systems.add Startup (spawnGrid, spawnWalls)-    Systems.add Update printGrid -    interval <- Interval.start 2000000 spawnCoin+    systems spawnGrid+      & schedule @Startup +    systems spawnWalls+      & after spawnGrid+      & schedule @Startup++    systems printGrid+      & schedule @Update++    spawn_ $ Repeater 2 spawnCoin+     insertRes =<< newGen-    insertRes $ Coins 0 -  plugins _ = plug (PlayerPlugin, EnemyPlugin, TimePlugin)+  deps = [dep @PlayerPlugin, dep @EnemyPlugin, dep @TimePlugin] -data PlayerPlugin = PlayerPlugin deriving (Eq)+data PlayerPlugin  instance Plugin PlayerPlugin where-  init _ = do-    Systems.add Startup $ spawnPlayer `after` spawnGrid-    Systems.add Update movePlayer-    Systems.add Update $ collectCoins `after` movePlayer+  init = do+    systems spawnPlayer+      & after spawnGrid+      & schedule @Startup -    void $ Observers.spawn onDamage+    systems movePlayer+      & schedule @Update -data EnemyPlugin = EnemyPlugin deriving (Eq)+    systems collectCoins+      & after movePlayer+      & schedule @Update -instance Plugin EnemyPlugin where-  init _ = do-    Systems.add Startup spawnEnemies-    Systems.add Update moveEnemies-    Systems.add Update $ tryDamage `after` movePlayer `after` moveEnemies+    void $ spawn (Observer onDamage)  data Tile = Tile deriving (Component) -newtype Pos = Pos {pos :: (Int, Int)} deriving (Component, Show)+data Pos = Pos (Int, Int) deriving (Component)  data Grid = Grid [[Entity]] deriving (Component) -getTile :: (Int, Int) -> System (Maybe Entity)-getTile (x, y) = do-  grid <- res @Grid-  pure $ do-    Grid tiles <- grid-    line <- tiles !? x-    line !? y- gridH :: Int gridH = 10 @@ -90,37 +81,44 @@  spawnGrid :: System () spawnGrid = do-  tiles <- for [0 .. gridH - 1] $ \i -> for [0 .. gridW - 1] $ \j ->-    spawn (Tile, Pos (i, j))+  tiles <-+    for [0 .. gridH - 1] $ \i ->+      for [0 .. gridW - 1] $ \j ->+        spawn (Tile, Pos (i, j))    insertRes $ Grid tiles -moveBy :: (Int, Int) -> Entity -> System (Maybe Entity)-moveBy (x, y) entity = do-  Just (Pos (x', y')) <- [g|*Pos|] entity-  getTile (x' + x, y' + y)+getTile :: (Int, Int) -> Grid -> Maybe Entity+getTile (x, y) (Grid tiles) = do+  line <- tiles !? x+  line !? y +moveBy :: (Int, Int) -> Pos -> Grid -> Maybe Entity+moveBy (x, y) (Pos (x', y')) = getTile (x' + x, y' + y)+ data Player = Player  instance Component Player where-  required = require @Health+  required = require @(Health, Coins)  data OnTile = OnTile  instance Component OnTile where-  type RelExclusivity OnTile = Exclusive+  type IsExclusiveRel OnTile = True  spawnPlayer :: System () spawnPlayer = do-  Just tile <- getTile (5, 5)+  Just grid <- res @Grid+  let Just tile = getTile (5, 5) grid   void $ spawn (Player, Rel OnTile tile)  data Wall = Wall deriving (Component) -spawnWall :: (Int, Int) -> System Entity+spawnWall :: (Int, Int) -> System (Maybe Entity) spawnWall pos = do-  Just tile <- getTile pos-  spawn (Wall, Rel OnTile tile)+  Just grid <- res @Grid+  for (getTile pos grid) $ \tile ->+    spawn (Wall, Rel OnTile tile)  spawnWalls :: System () spawnWalls = do@@ -129,6 +127,12 @@   for_ [1 .. gridH - 2] $ \i -> spawnWall (i, 0)   for_ [1 .. gridH - 2] $ \i -> spawnWall (i, gridW - 1) +tileHas :: forall c. (Component c) => Entity -> System Bool+tileHas tile = not . null <$> query [q|Entity / With (c, OnTile -> tile)|]++hasWall :: Entity -> System Bool+hasWall = tileHas @Wall+ showTile :: Entity -> System Char showTile tile = do   player <- tileHas @Player tile@@ -148,17 +152,7 @@ showGrid = do   Just (Grid tiles) <- res @Grid   lines <- for tiles $ traverse showTile-  return $ unlines lines--showHealth :: System String-showHealth = do-  Just health <- [s|Health / With Player|]-  pure $ "Health: " ++ show health.hp--showCoins :: System String-showCoins = do-  Just (Coins c) <- res @Coins-  pure $ "Coins: " ++ show c+  pure $ unlines lines  printGrid :: System () printGrid = do@@ -167,6 +161,15 @@   coins <- showCoins   printClear $ health ++ "\n" ++ grid ++ "\n" ++ coins ++ "\n" +movePlayerBy :: (Int, Int) -> System ()+movePlayerBy dir = do+  Just grid <- res @Grid+  [q|OnTile -> (Pos) / With Player|]+    & qmapMaybe (\pos -> moveBy dir pos.comp grid)+    & qfilterM (const tileIsFree)+    & qinsert (Rel OnTile)+    & query_+ movePlayer :: System () movePlayer = do   c <- Stdin.readLast@@ -177,29 +180,6 @@     'd' -> movePlayerBy (0, 1)     _ -> pure () -movePlayerBy :: (Int, Int) -> System ()-movePlayerBy dir = do-  Just player <- single' E (With (C @Player))--  Just (tile, pos) <- [g|OnTile -> (Entity, *Pos)|] player-  newTile <- moveBy dir tile--  for_ newTile $ \t ->-    tileIsFree t >>= flip when (insert (Rel OnTile t) player)--hasWall :: Entity -> System Bool-hasWall = tileHas @Wall--data Enemy = Enemy--instance Component Enemy where-  required = require @Cooldown--data Cooldown = Cooldown {timer :: Timer} deriving (Component)--instance Default Cooldown where-  def = Cooldown $ Timer.new 0.5 Timer.Repeat- data Rand = Rand (IOGenM StdGen) deriving (Component)  newGen :: System Rand@@ -208,13 +188,22 @@ randomPos :: System (Int, Int) randomPos = do   Just (Rand gen) <- res @Rand-  i <- applyIOGen (uniformR (1, gridH - 1)) gen-  j <- applyIOGen (uniformR (1, gridW - 1)) gen+  i <- applyIOGen (uniformR (0, gridH - 1)) gen+  j <- applyIOGen (uniformR (0, gridW - 1)) gen   return (i, j)  randomTile :: System Entity-randomTile = unwrap <$> (getTile =<< randomPos)+randomTile = do+  Just grid <- res @Grid+  randomPos <- randomPos +  pure . unwrap $ getTile randomPos grid++data Enemy = Enemy++instance Component Enemy where+  required = require @Cooldown+ spawnEnemy :: System Entity spawnEnemy = do   tile <- randomTile@@ -223,6 +212,22 @@ spawnEnemies :: System () spawnEnemies = for_ [0 .. 4] $ const spawnEnemy +data EnemyPlugin++instance Plugin EnemyPlugin where+  init = do+    systems spawnEnemies+      & after spawnGrid+      & schedule @Startup++    systems moveEnemies+      & schedule @Update++    systems tryDamage+      & after moveEnemies+      & after movePlayer+      & schedule @Update+ decideEnemyDir :: Pos -> Pos -> System (Int, Int) decideEnemyDir (Pos (ex, ey)) (Pos (px, py)) = do   left <- tileAtPosIsFree (ex - 1, ey)@@ -240,28 +245,38 @@  moveEnemies :: System () moveEnemies = do-  Just pos <- [s|OnTile -> (*Pos) / With Player|]-  delta <- deltaTime+  Just (From _ playerPos) <- single [q|OnTile -> (Pos) / With Player|]+  Just grid <- res @Grid -  enemies <- [q|Entity, OnTile -> (Entity, *Pos), Cooldown / With Enemy|]-  for_ enemies $ \(enemy, (enemyTile, enemyPos), cooldown) -> do-    let (timer, finished) = Timer.tick delta cooldown.timer-    set cooldown $ Cooldown timer+  [q|OnTile -> (Pos) / With Enemy|]+    & qfilterCooldown+    & qdecideEnemyTile grid playerPos+    & qinsert (Rel OnTile)+    & query_ -    when finished $ do-      diff <- decideEnemyDir enemyPos pos+qdecideEnemyTile :: Grid -> Pos -> Query System (From Pos) -> Query System Entity+qdecideEnemyTile grid playerPos x =+  x+    & qtraverse (\_ pos -> (,pos) <$> decideEnemyDir pos.comp playerPos)+    & qmapMaybe (\(diff, pos) -> moveBy diff pos.comp grid) -      newTile <- moveBy diff enemyTile-      for_ newTile $ \t -> do-        insert (Rel OnTile t) enemy+data Cooldown = Cooldown {timer :: Timer} deriving (Component) -tileHas :: forall c. (QueryType c) => Entity -> System Bool-tileHas tile = not . null <$> [q|Entity / With (c, OnTile -> tile)|]+instance Default Cooldown where+  def = Cooldown $ Timer.new 1 Timer.Repeat -tileAtPosIsFree :: (Int, Int) -> System Bool-tileAtPosIsFree pos = do-  tile <- getTile pos-  maybe (pure False) tileIsFree tile+qfilterCooldown :: Query System a -> Query System a+qfilterCooldown x = do+  x+    & qextend [qd|Cooldown|] (,)+    & qfilterM+      ( \entity (_, Cooldown timer) -> do+          delta <- Time.delta+          let (timer', justFinished) = Timer.tick delta timer+          insert (Cooldown timer') entity+          pure justFinished+      )+    & qmap fst  tileIsFree :: Entity -> System Bool tileIsFree tile = do@@ -270,25 +285,43 @@   player <- tileHas @Player tile   pure $ not (wall || enemy || player) +tileAtPosIsFree :: (Int, Int) -> System Bool+tileAtPosIsFree pos = do+  Just grid <- res @Grid+  maybe (pure False) tileIsFree (getTile pos grid)+ data Health = Health {hp :: Int} deriving (Component)  instance Default Health where   def = Health 100 +showHealth :: System String+showHealth = do+  Just health <- single [q|Health / With Player|]+  pure $ "Health: " ++ show health.hp+ data Damage = Damage {amount :: Int} deriving (Event)  onDamage :: Damage -> System () onDamage dmg = do-  player <- [s|(Entity, Health) / With Player, Without Invincible|]--  for_ player $ \(entity, health) -> do-    modify health $ \(Health x) -> Health $ max (x - dmg.amount) 0+  [q|Health / With Player, Without Invincible|]+    & qmodify (\(Health x) -> (Health $ max (x - dmg.amount) 0, Invincible))+    & qtap+      ( \e (Health hp, _) -> do+          delay 1 $ remove (C @Invincible) e+          when (hp == 0) $ liftIO exitSuccess+      )+    & query_ -    insert Invincible entity-    delay 1000000 $ remove (C @Invincible) entity+tryDamage :: System ()+tryDamage = do+  adjacentEnemies <-+    [q|OnTile -> (Pos) / With Player|]+      & qjoin (\pos -> [q|OnTile -> (Pos) / With Enemy|] & qfilter (\a -> isAdjacent a.comp pos.comp)) (,)+      & query -    Just health <- update health-    when (health.hp == 0) $ liftIO exitSuccess+  unless (null adjacentEnemies) $ do+    trigger $ Damage 5  isAdjacent :: Pos -> Pos -> Bool isAdjacent (Pos (x1, y1)) (Pos (x2, y2)) =@@ -296,18 +329,9 @@       dy = abs (y1 - y2)    in (dx == 1 && dy == 0) || (dx == 0 && dy == 1) -tryDamage :: System ()-tryDamage = do-  Just player <- [s|OnTile -> (*Pos) / With Player|]-  enemies <- [q|OnTile -> (*Pos) / With Enemy|]--  for_ enemies $ \pos -> do-    when (isAdjacent pos player) $ do-      trigger (Damage 5)- data Invincible = Invincible deriving (Component) -data Coin = Coin deriving (Component)+data Coin = Coin Int deriving (Component)  spawnCoin :: System () spawnCoin = do@@ -315,18 +339,24 @@   free <- tileIsFree tile   if free     then-      void $ spawn (Coin, Rel OnTile tile)+      void $ spawn (Coin 5, Rel OnTile tile)     else       spawnCoin -data Coins = Coins Int deriving (Component)+data Coins = Coins Int deriving (Component, Generic, Default) +showCoins :: System String+showCoins = do+  Just (Coins c) <- single $ [q|Coins|]+  pure $ "Coins: " ++ show c+ collectCoins :: System () collectCoins = do-  Just playerTile <- [s|OnTile -> (Entity) / With Player|]-  coins <- [q|Entity / With OnTile -> playerTile, With Coin|]--  Just (Coins c) <- res @Coins-  insertRes $ Coins $ c + length coins+  players <- query [q|Entity, OnTile -> (Entity), Coins / With Player|]+  for_ players $ \(player, From _ tile, Coins coins) -> do+    collected <-+      [q|Coin / With OnTile -> tile|]+        & qtap (\e _ -> despawn e)+        & query -  for_ coins despawn+    insert (Coins $ foldr (\(Coin x) -> (+ x)) coins collected) player

@@ -0,0 +1,67 @@+module Main where++import Mischief.ECS++main :: IO ()+main = do+  app <- newApp+  addPlugin @MyPlugin app+  runApp app++data MyPlugin++instance Plugin MyPlugin where+  init = do+    systems (helloWorld, greetPeople, showLikes)+      & schedule @Update++    systems addPeople+      & schedule @Startup++    systems updateFlo+      & before (greetPeople, showLikes)+      & schedule @Update++    insertRes (Greeting "Hey")++helloWorld :: System ()+helloWorld = info "Hello World!"++data Person = Person deriving (Component)++addPeople :: System ()+addPeople = do+  kim <- spawn (Person, Name "Kimberly")+  nick <- spawn (Person, Name "Nicholas")+  flo <- spawn (Person, Name "Florian")++  insert (Rel Likes kim) flo+  insert (Rel Likes nick, Rel Likes flo) kim++greetPeople :: System ()+greetPeople = do+  Just greeting <- res @Greeting++  [q|Name / With Person|]+    & qinfo (\name -> [i|#{greeting} #{name}!|])+    & query_++updateFlo :: System ()+updateFlo = do+  [q|Name / With Person|]+    & qfilter (== Name "Florian")+    & qinsert (\_ -> Name "Florianne")+    & query_++data Greeting = Greeting String deriving (Component)++instance Show Greeting where+  show (Greeting a) = a++data Likes = Likes deriving (Component)++showLikes :: System ()+showLikes = do+  [q|Name, Likes -> (Name)|]+    & qinfo (\(name, likes) -> [i|#{name} likes #{likes}|])+    & query_

@@ -18,16 +18,13 @@ -- PVP summary:     +-+------- breaking API changes --                  | | +----- non-breaking API additions --                  | | | +--- code changes with no API change-version: 0.1.0.0+version: 0.2.0.0 -- A short (one-line) description of the package.-synopsis: An opinionated archetype ECS engine built in Haskell.+synopsis: An archetype ECS engine built in Haskell.+homepage: https://codeberg.org/mischief/mischief -- A longer description of the package. description:-  The ECS at the core of the Mischief game engine. It is mainly focused on ergonomics and-  accessibility. Check the "Learn You an ECS for Great Mischief" book in the haddock documentation-  to learn about using it.--  The high-level API is quite opinionated compared to other Haskell libraries.+  The ECS at the core of the Mischief game engine.  category: Game Engine, ECS, Game, Control, Data, Framework -- The license under which the package is released.@@ -42,7 +39,9 @@ -- copyright: build-type: Simple -- Extra doc files to be distributed with the package, such as a CHANGELOG or a README.-extra-doc-files: CHANGELOG.md+extra-doc-files:+  CHANGELOG.md+  README.md  -- Extra source files to be distributed with the package, such as examples, or a tutorial module. -- extra-source-files:@@ -60,7 +59,6 @@     Mischief.ECS.App     Mischief.ECS.App.Plugins     Mischief.ECS.App.Schedules-    Mischief.ECS.App.SystemConfig     Mischief.ECS.App.SystemDef     Mischief.ECS.App.Systems     Mischief.ECS.Archetypes@@ -72,26 +70,24 @@     Mischief.ECS.Components.Common     Mischief.ECS.Components.HooksDef     Mischief.ECS.Components.Required-    Mischief.ECS.Components.Runnable     Mischief.ECS.Components.Spawn     Mischief.ECS.Entities     Mischief.ECS.EntityDef     Mischief.ECS.EventDef     Mischief.ECS.Events-    Mischief.ECS.Graph+    Mischief.ECS.Exports+    Mischief.ECS.Fixed+    Mischief.ECS.Foreign     Mischief.ECS.Hooks-    Mischief.ECS.Interval+    Mischief.ECS.HooksRel     Mischief.ECS.Log-    Mischief.ECS.Mappable     Mischief.ECS.Messages     Mischief.ECS.Observer-    Mischief.ECS.Observers-    Mischief.ECS.Prelude-    Mischief.ECS.Relationships     Mischief.ECS.Relationships.ChildOf     Mischief.ECS.Relationships.Graph     Mischief.ECS.Relationships.Order     Mischief.ECS.Relationships.Tree+    Mischief.ECS.Repeater     Mischief.ECS.Resources     Mischief.ECS.Schedules     Mischief.ECS.Stdin@@ -100,35 +96,37 @@     Mischief.ECS.Tables     Mischief.ECS.Time     Mischief.ECS.Timer-    Mischief.ECS.Tutorial.App-    Mischief.ECS.Tutorial.Components-    Mischief.ECS.Tutorial.Dungeon-    Mischief.ECS.Tutorial.Events-    Mischief.ECS.Tutorial.Queries-    Mischief.ECS.Tutorial.Relationships-    Mischief.ECS.Tutorial.Startup-    Mischief.ECS.Tutorial.Systems+    Mischief.ECS.Tutorial.Guides.Basics+    Mischief.ECS.Tutorial.Guides.Change+    Mischief.ECS.Tutorial.Guides.Events+    Mischief.ECS.Tutorial.Guides.MonadicQueries+    Mischief.ECS.Tutorial.Guides.Organizing+    Mischief.ECS.Tutorial.Guides.Parallelism+    Mischief.ECS.Tutorial.Guides.QuasiConversion+    Mischief.ECS.Tutorial.Guides.QueryBasics+    Mischief.ECS.Tutorial.Guides.QueryPiping+    Mischief.ECS.Tutorial.Guides.Scheduling+    Mischief.ECS.Tutorial.Guides.Time+    Mischief.ECS.Tutorial.Introduction.Dungeon+    Mischief.ECS.Tutorial.Introduction.Startup     Mischief.ECS.Utils     Mischief.ECS.Vec     Mischief.ECS.World     Mischief.ECS.World.Change     Mischief.ECS.World.Defer     Mischief.ECS.World.Insert-    Mischief.ECS.World.Modify     Mischief.ECS.World.Par-    Mischief.ECS.World.Prefs     Mischief.ECS.World.Query     Mischief.ECS.World.Query.Markers+    Mischief.ECS.World.Query.Pipe     Mischief.ECS.World.Query.Queryable     Mischief.ECS.World.Query.QueryFilter-    Mischief.ECS.World.Query.QueryType     Mischief.ECS.World.Query.TH     Mischief.ECS.World.Query.TH.Common     Mischief.ECS.World.Query.TH.QD     Mischief.ECS.World.Query.TH.QF     Mischief.ECS.World.Remove     Mischief.ECS.World.Spawn-    Mischief.ECS.World.Systems     Mischief.ECS.World.Utils    -- Modules included in this library but not exported.@@ -162,23 +160,21 @@   build-depends:     ansi-terminal >=1.1.5 && <1.2,     async >=2.2.6 && <2.3,-    base ^>=4.21.0.0,-    binary >=0.8.9 && <0.9,-    bytestring >=0.12.2 && <0.13,+    base >=4.21.0.0 && <4.22,     clock >=0.8.4 && <0.9,     co-log >=0.7.0 && <0.8,     containers >=0.7 && <0.8,     data-default >=0.8.0 && <0.9,-    hashable >=1.5.1 && <1.6,+    exceptions >=0.10.9 && <0.11,     hashtables >=1.4.2 && <1.5,     haskell-src-meta >=0.8.16 && <0.9,     megaparsec >=9.8.1 && <9.9,     mtl >=2.3.1 && <2.4,     primitive >=0.9.1 && <0.10,     stm >=2.5.3 && <2.6,+    string-interpolate >=1.0.0 && <1.1,     template-haskell >=2.23.0 && <2.24,     text >=2.1.2 && <2.2,-    time >=1.14 && <1.15,     transformers >=0.6.1 && <0.7,     vector >=0.13.2 && <0.14, @@ -219,27 +215,34 @@   hs-source-dirs: test   -- The entrypoint to the test suite.   main-is: Main.hs-  other-modules: Relationships+  other-modules:+    Changes+    Relationships+    Utils+   -- Test dependencies.   build-depends:-    base ^>=4.21.0.0,+    base >=4.21.0.0 && <4.22,     containers,     data-default,     mischief-ecs,     primitive,-    random,+    random >=1.3.1 && <1.4,+    text,     transformers,  executable example-dungeon   main-is: Dungeon.hs   hs-source-dirs: examples   build-depends:-    base ^>=4.21.0.0,-    containers >=0.7 && <0.8,-    data-default >=0.8.0 && <0.9,-    primitive >=0.9.1 && <0.10,+    base >=4.21.0.0 && <4.22,+    containers,+    data-default,+    mischief-ecs,+    primitive,     random >=1.3.1 && <1.4,-    transformers >=0.6.1 && <0.7,+    text,+    transformers,    default-language: GHC2024   default-extensions:@@ -254,19 +257,44 @@     TemplateHaskell     TypeFamilyDependencies +executable example-startup+  main-is: Startup.hs+  hs-source-dirs: examples+  build-depends:+    base >=4.21.0.0 && <4.22,+    containers,+    mischief-ecs ==0.2.0.0,+    primitive,+    text,+    transformers,++  default-language: GHC2024+  default-extensions:+    DeriveAnyClass+    DuplicateRecordFields+    NoFieldSelectors+    NoGeneralizedNewtypeDeriving+    OverloadedRecordDot+    OverloadedStrings+    QuasiQuotes+    RequiredTypeArguments+    TemplateHaskell+    TypeFamilyDependencies+ benchmark bench-spawn   type: exitcode-stdio-1.0   main-is: bench-spawn.hs   hs-source-dirs: benchmarks   default-language: GHC2024   build-depends:-    base >=4.21.0 && <4.22,-    containers >=0.7 && <0.8,+    base >=4.21.0.0 && <4.22,+    containers,     criterion >=1.6.5 && <1.7,     deepseq >=1.5.1 && <1.6,-    primitive >=0.9.1 && <0.10,-    time >=1.14 && <1.15,-    transformers >=0.6.1 && <0.7,+    mischief-ecs,+    primitive,+    time,+    transformers,    default-extensions:     DeriveAnyClass@@ -286,13 +314,14 @@   hs-source-dirs: benchmarks   default-language: GHC2024   build-depends:-    base >=4.21.0 && <4.22,-    containers >=0.7 && <0.8,+    base >=4.21.0.0 && <4.22,+    containers,     criterion >=1.6.5 && <1.7,     deepseq >=1.5.1 && <1.6,-    primitive >=0.9.1 && <0.10,-    time >=1.14 && <1.15,-    transformers >=0.6.1 && <0.7,+    mischief-ecs,+    primitive,+    time,+    transformers,    default-extensions:     DeriveAnyClass@@ -312,13 +341,14 @@   hs-source-dirs: benchmarks   default-language: GHC2024   build-depends:-    base >=4.21.0 && <4.22,-    containers >=0.7 && <0.8,+    base >=4.21.0.0 && <4.22,+    containers,     criterion >=1.6.5 && <1.7,     deepseq >=1.5.1 && <1.6,-    primitive >=0.9.1 && <0.10,-    time >=1.14 && <1.15,-    transformers >=0.6.1 && <0.7,+    mischief-ecs,+    primitive,+    time,+    transformers,    default-extensions:     DeriveAnyClass

@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wno-unused-imports #-} {-# OPTIONS_GHC -Wno-unused-top-binds #-}  -- |@@ -7,191 +8,108 @@ -- -- This library contains the ECS used by the Mischief Game Engine. module Mischief.ECS-  ( -- * What is Mischief?-    -- $mischief--    -- * Learn You an ECS for Great Mischief!+  ( -- * Learn You an ECS for Great Mischief!     -- $tutorials-    module Mischief.ECS.App,-    module Mischief.ECS.App.Plugins,-    module Mischief.ECS.App.Schedules,-    module Mischief.ECS.App.SystemConfig,-    module Mischief.ECS.App.Systems,-    module Mischief.ECS.Archetypes,-    module Mischief.ECS.Archetypes.Graph,-    module Mischief.ECS.Collectable,+    module Mischief.ECS.Exports,     module Mischief.ECS.Components,-    module Mischief.ECS.Components.Bundle,-    module Mischief.ECS.Components.BundleTypes,-    module Mischief.ECS.Components.Common,     module Mischief.ECS.Components.Required,-    module Mischief.ECS.Components.Runnable,-    module Mischief.ECS.Components.Spawn,+    module Mischief.ECS.Components.Common,     module Mischief.ECS.Entities,-    module Mischief.ECS.Events,-    module Mischief.ECS.Hooks,-    module Mischief.ECS.Log,-    module Mischief.ECS.Mappable,-    module Mischief.ECS.Messages,-    module Mischief.ECS.Prelude,-    module Mischief.ECS.Relationships,-    module Mischief.ECS.Relationships.ChildOf,-    module Mischief.ECS.Relationships.Graph,-    module Mischief.ECS.Relationships.Order,-    module Mischief.ECS.Relationships.Tree,-    module Mischief.ECS.Tables,-    module Mischief.ECS.Time,-    module Mischief.ECS.Utils,-    module Mischief.ECS.World,-    module Mischief.ECS.World.Change,-    module Mischief.ECS.World.Defer,-    module Mischief.ECS.World.Insert,-    module Mischief.ECS.World.Modify,-    module Mischief.ECS.World.Par,-    module Mischief.ECS.World.Prefs,-    module Mischief.ECS.Resources,     module Mischief.ECS.World.Query,-    module Mischief.ECS.World.Query.Queryable,     module Mischief.ECS.World.Query.QueryFilter,     module Mischief.ECS.World.Query.Markers,-    module Mischief.ECS.EventDef,     module Mischief.ECS.World.Query.TH,+    module Mischief.ECS.World.Insert,     module Mischief.ECS.World.Remove,     module Mischief.ECS.World.Spawn,-    module Mischief.ECS.World.Utils,-    TestTest (..),+    module Mischief.ECS.Resources,+    module Mischief.ECS.EventDef,+    module Mischief.ECS.World,+    module Mischief.ECS.Time,+    module Mischief.ECS.World.Defer,+    module Mischief.ECS.App,+    module Mischief.ECS.App.Plugins,+    module Mischief.ECS.App.Schedules,+    module Mischief.ECS.Systems,+    module Mischief.ECS.Log,+    module Mischief.ECS.Utils,+    module Mischief.ECS.Events,+    module Mischief.ECS.Components.HooksDef,+    module Mischief.ECS.Hooks,+    module Mischief.ECS.Components.Bundle,+    module Mischief.ECS.Timer,+    module Mischief.ECS.World.Query.Pipe,+    module Mischief.ECS.Observer,+    module Mischief.ECS.Fixed,+    module Data.Function,+    module Mischief.ECS.Relationships.ChildOf,+    module Mischief.ECS.World.Query.Queryable,+    module Mischief.ECS.Relationships.Order,+    module Mischief.ECS.Repeater,+    module Mischief.ECS.Components.Spawn,   ) where -import Control.Monad (void)-import Control.Monad.IO.Class (MonadIO (liftIO))-import Data.Foldable (for_)-import Data.Text (Text)-import Language.Haskell.TH-import Language.Haskell.TH.Syntax-import Mischief.ECS.App-import Mischief.ECS.App.Plugins-import Mischief.ECS.App.Schedules-import Mischief.ECS.App.SystemConfig-import Mischief.ECS.App.Systems-import Mischief.ECS.Archetypes-import Mischief.ECS.Archetypes.Graph-import Mischief.ECS.Collectable (Collectable, EraseIntoStorage (..), collect)-import Mischief.ECS.Components-import Mischief.ECS.Components.Bundle-import Mischief.ECS.Components.BundleTypes-import Mischief.ECS.Components.Common-import Mischief.ECS.Components.Required-import Mischief.ECS.Components.Runnable-import Mischief.ECS.Components.Spawn-import Mischief.ECS.Entities-import Mischief.ECS.EventDef-import Mischief.ECS.Events-import Mischief.ECS.Graph-import Mischief.ECS.Hooks+import Data.Function ((&))+import Mischief.ECS.App (App, addPlugin, newApp, runApp)+import Mischief.ECS.App.Plugins (Dependency, Plugin (..), dep)+import Mischief.ECS.App.Schedules (PostStartup, PostUpdate, PreStartup, PreUpdate, Schedule, Startup, StartupSchedule (..), Update, UpdateSchedule (..), scheduleEntity)+import Mischief.ECS.Components (Component (..), From (..), Rel (..), Res (..), Tick (..))+import Mischief.ECS.Components.Bundle (Bundle, BundleBuilder, BundleEq, BundleEqBuilder, bundle, bundleEq)+import Mischief.ECS.Components.Common (Name (..))+import Mischief.ECS.Components.HooksDef (Hook, HookContext (..), HookContextRel (..), HookRel)+import Mischief.ECS.Components.Required (require)+import Mischief.ECS.Components.Spawn (meta)+import Mischief.ECS.Entities (Entity)+import Mischief.ECS.EventDef (Event)+import Mischief.ECS.Events (OnAdd (..), OnAddRel (..), OnRemove (..), OnRemoveRel (..), OnSet (..), OnSetRel (..), trigger)+import Mischief.ECS.Exports+import Mischief.ECS.Fixed (FixedFrequency (..), FixedPlugin, FixedPostUpdate, FixedPreUpdate, FixedUpdate)+import Mischief.ECS.Hooks (hook, hookRel) import Mischief.ECS.Log-import Mischief.ECS.Mappable-import Mischief.ECS.Messages (Message)-import Mischief.ECS.Prelude-import Mischief.ECS.Relationships-import Mischief.ECS.Relationships.ChildOf-import Mischief.ECS.Relationships.Graph-import Mischief.ECS.Relationships.Order-import Mischief.ECS.Relationships.Tree-import Mischief.ECS.Resources-import Mischief.ECS.Systems-import Mischief.ECS.Tables-import Mischief.ECS.Time-import Mischief.ECS.Utils-import Mischief.ECS.Vec-import Mischief.ECS.World-import Mischief.ECS.World.Change-import Mischief.ECS.World.Defer-import Mischief.ECS.World.Insert-import Mischief.ECS.World.Modify-import Mischief.ECS.World.Par-import Mischief.ECS.World.Prefs-import Mischief.ECS.World.Query-import Mischief.ECS.World.Query.Markers-import Mischief.ECS.World.Query.QueryFilter-import Mischief.ECS.World.Query.Queryable-import Mischief.ECS.World.Query.TH-import Mischief.ECS.World.Remove-import Mischief.ECS.World.Spawn-import Mischief.ECS.World.Systems-import Mischief.ECS.World.Utils--data TestTest = TestTest---- x = quoteD---- x = $quoteE--qq :: System ()-qq = do-  -- x <- $(quoteC ''ChildOf)-  undefined---- $pre--- This version of Mischief isn't meant for public use. It's just a pre-release published mostly to showcase the documentation.+import Mischief.ECS.Observer (Observer (..))+import Mischief.ECS.Relationships.ChildOf (ChildOf (..))+import Mischief.ECS.Relationships.Order (Before (..))+import Mischief.ECS.Repeater+import Mischief.ECS.Resources (insertRes, res, resOrInsert, resOrInsertM)+import Mischief.ECS.Systems (after, before, order, schedule, systems, unschedule, unschedule')+import Mischief.ECS.Time (Time, TimePlugin)+import Mischief.ECS.Timer (Timer)+import Mischief.ECS.Utils (expect, mapLeft, unwrap)+import Mischief.ECS.World (MonadSystem, ParSystem, System, runWhen)+import Mischief.ECS.World.Defer (defer, delay, flush, runAfter)+import Mischief.ECS.World.Insert (insert, insertIfNeq, insertNew)+import Mischief.ECS.World.Par (par, par', parFor, parFor', parFor'_, parFor_)+import Mischief.ECS.World.Query (Query, check, mkGet, mkGet', mkQuery, mkQuery', query, queryOne, query_, runWhenOne, runWhenQ, single)+import Mischief.ECS.World.Query.Markers (Any (..), C (..), E (..), Has (..), HasR (..), M (..), MR (..), Q (..), Q' (..), R (..), R' (..))+import Mischief.ECS.World.Query.Pipe+import Mischief.ECS.World.Query.QueryFilter (QueryFilter (..))+import Mischief.ECS.World.Query.Queryable (Queryable)+import Mischief.ECS.World.Query.TH (q, qd, qf)+import Mischief.ECS.World.Remove (remove)+import Mischief.ECS.World.Spawn (despawn, spawn, spawnDefer, spawn_) --- $mischief--- Mischief has various meanings. It can be a group of rats. Or it can refer to being naughty and playful.------ This Mischief, however, is an @ECS Game Engine@! In other words...------ @--- Mischief :: Entity -> Component c => System ()--- @------ Mischief takes great inspiration from [@Bevy@](https://bevy.org/) and [@Flecs@](https://www.flecs.dev/flecs/), and--- was written in @100% Haskell@, taking advantage of its great ergonomics and strong type system.--- It is a refreshing spin on the functional and data-driven paradigms.------ == Package------ This package contains only @mischief-ecs@, the ECS at the core of Mischief. Other packages, such as @mischief-input@, @mischief-assets@,--- @mischief-render@ are planned, but haven't yet been developed to the same level as the ECS itself.------ == Design Goals------ These are the main design goals of Mischief:------ * __Ergonomic and Accessible__. Mischief's main purpose is to provide a very clean, intuitive, inherently opinionated, high-level API. This is the main way we differentiate ourselves from other ECS's.--- Learning to use Mischief should be a painless and intuitive process.--- * __Functional and Data Driven__. We strive to find a balance between functional programming and data-driven design. These are two concepts that don't--- interact very often, but that both stand at the core of Msichief.--- * __Modular__. Mischief is meant to be modular, allowing you to plug packages in and out, whether they are made by us or a third party.------ == Highlights------ Here are some highlights of Mischief:+-- $tutorials+-- The official Mischief book. ----- * __Highly Dynamic__ . Want to disable a system? Despawn it!--- * __Fancy Queries__. Complete with transitive queries and filters.--- * __Quasi-Queries__. Scripting language for writing queries.--- * __Rich Systems__. Monadic Systems? Yes please.--- * __Book__. Mischief has its very own book! See below.--- * __Relationships__. Bob Likes Charlie.--- * __Events__.--- * And much much more..+-- You can read chapters and subchapters in any order.+-- The @Startup Guide@ (1.1) is heavily recommended if this is your first time using Mischief. --+-- * 1. Introduction ----- == Performance+--     * 1.1 [Startup Guide]("Mischief.ECS.Tutorial.Introduction.Startup")+--     * 1.2 [Coding a Dungeon Game]("Mischief.ECS.Tutorial.Introduction.Dungeon") ----- Performance-wise, Mischief still has a long way to go; there are many easy performance gains that we have just been too busy to implement, as we've--- been mostly focusing on ergonomics, modularity, and ease-of-use.--- This is a pretty strong @Archetype ECS@ however, and it is possible to bring it to about the same /asymptotic/ performance as Bevy or Flecs, although--- there will probably always be a layer of indirection (or 20) that makes it a bit slower, due to the high-level, boxed, nature of Haskell.---- $tutorials--- In order to learn how to use Mischief, you can read through the official book:+-- * 2. Guides ----- (1) [Startup Guide]("Mischief.ECS.Tutorial.Startup")--- (2) [Coding a Dungeon Game]("Mischief.ECS.Tutorial.Dungeon")--- (3) [App and Plugins]("Mischief.ECS.Tutorial.App")--- (4) [Components]("Mischief.ECS.Tutorial.Components")--- (5) [Relationships]("Mischief.ECS.Tutorial.Relationships")--- (6) [Queries]("Mischief.ECS.Tutorial.Queries")--- (7) [Systems]("Mischief.ECS.Tutorial.Systems")--- (8) [Events and Messages]("Mischief.ECS.Tutorial.Events")+--     * 2.1 [Organizing your Project]("Mischief.ECS.Tutorial.Guides.Organizing")+--     * 2.2 [Entities and Components Basics]("Mischief.ECS.Tutorial.Guides.Basics")+--     * 2.3 [Query Basics]("Mischief.ECS.Tutorial.Guides.QueryBasics")+--     * 2.4 [Query Piping]("Mischief.ECS.Tutorial.Guides.QueryPiping")+--     * 2.5 [Quasi-Query Conversion]("Mischief.ECS.Tutorial.Guides.QuasiConversion")+--     * 2.6 [Monadic Queries]("Mischief.ECS.Tutorial.Guides.MonadicQueries")+--     * 2.7 [Scheduling and Running Systems]("Mischief.ECS.Tutorial.Guides.Scheduling")+--     * 2.8 [Keeping Track of Time]("Mischief.ECS.Tutorial.Guides.Time")+--     * 2.9 [Parallelism and Asynchronicity]("Mischief.ECS.Tutorial.Guides.Parallelism")+--     * 2.10 [Events and Messages]("Mischief.ECS.Tutorial.Guides.Events")+--     * 2.11 [Change Detection]("Mischief.ECS.Tutorial.Guides.Change")

@@ -5,135 +5,182 @@ -- import Data.Map -- import Data.Map qualified as Map -import Control.Monad (forever, void)+import Control.Monad (filterM, forever, unless, when) import Control.Monad.IO.Class (MonadIO (liftIO))-import Control.Monad.Reader (MonadReader (..), asks)-import Control.Monad.Trans.Reader (ReaderT (..))+import Control.Monad.Reader (MonadReader (..)) import Data.Data import Data.Default import Data.Foldable import Data.IORef import Mischief.ECS.App.Plugins import Mischief.ECS.App.Schedules-import Mischief.ECS.App.SystemConfig hiding (Before) import Mischief.ECS.App.SystemDef-import Mischief.ECS.App.Systems (ScheduledIn (ScheduledIn), SystemFunction (SystemFunction), Systems, systemEntity)+import Mischief.ECS.App.Systems (ScheduledIn, SystemFunction, Systems) import Mischief.ECS.App.Systems qualified as Systems import Mischief.ECS.Components import Mischief.ECS.Components.Bundle-import Mischief.ECS.Components.Runnable (Runnable, runFor)-import Mischief.ECS.Components.Spawn (getOrAddComponentId, meta)+import Mischief.ECS.Components.Spawn (getOrAddComponentId) import Mischief.ECS.Entities-import Mischief.ECS.Events import Mischief.ECS.Hidden import Mischief.ECS.Log-import Mischief.ECS.Mappable import Mischief.ECS.Relationships.Order import Mischief.ECS.Resources-import Mischief.ECS.Systems qualified as Systems-import Mischief.ECS.Tables import Mischief.ECS.World import Mischief.ECS.World.Defer import Mischief.ECS.World.Insert import Mischief.ECS.World.Query import Mischief.ECS.World.Query.Markers import Mischief.ECS.World.Query.QueryFilter-import Mischief.ECS.World.Query.QueryType-import Mischief.ECS.World.Query.Queryable import Mischief.ECS.World.Spawn +-- | The App is a wrapper around the World through which plugins can be added. data App = App   { world :: World,     systems :: Systems   } -newApp :: (Plugin p) => p -> IO App-newApp plugin = do-  world <- newWorld getTools-  systems <- Systems.newSystems+-- | Create a new App.+newApp :: IO App+newApp = do+  !world <- newWorld getTools+  runSystem (spawnEntity (Entity (# 0##, 0## #)) ()) world -  let app = App {world, systems}+  !systems <- Systems.newSystems +  let !app = App {world, systems}+   runSystem appInit app.world-  runSystem (Systems.add Init $ runPluginRec plugin) app.world+  pure app -  return app+-- | Add a plugin to the App.+addPlugin :: forall p. (Plugin p) => App -> IO ()+addPlugin !app = runSystem (addPluginRec @p) app.world +-- | Run the App. runApp :: App -> IO ()-runApp app = flip runSystem app.world $ do-  startups <- orderEntities =<< query' E (With (C @StartupSchedule))-  updates <- orderEntities =<< query' E (With (C @UpdateSchedule))+runApp !app = flip runSystem app.world $ do+  !x <- scheduleEntity @Init+  liftIO $ runSchedules [x] +  !startups <- orderEntities =<< query (mkQuery' E (With (C @StartupSchedule)))+  !updates <- orderEntities =<< query (mkQuery' E (With (C @UpdateSchedule)))+   liftIO $ runSchedules startups   liftIO $ runSchedulesLoop updates   where-    runSchedulesLoop schedules = do+    runSchedulesLoop !schedules = do       forever $ do         runSchedules schedules         modifyIORef' app.world.frame (\(Frame x) -> Frame $ x + 1) -    runSchedules schedules =-      for_ schedules $ \schedule -> do+    runSchedules !schedules =+      for_ schedules $ \(!schedule) -> do         runSystem (runSchedule' schedule) app.world -runSchedule :: (Schedule sch) => sch -> System ()-runSchedule sch = scheduleEntity sch >>= runSchedule'+-- | Run all systems of a Schedule.+runSchedule :: forall sch. (Schedule sch) => System ()+runSchedule = scheduleEntity @sch >>= runSchedule'  runSchedule' :: Entity -> System () runSchedule' schedule = do-  world <- unsafeGetWorld-  systems <- orderEntities =<< query' E (With (R @ScheduledIn schedule))+  !world <- unsafeGetWorld+  !systems <- orderEntities =<< query (mkQuery' E (With (R @ScheduledIn schedule))) -  for_ systems $ \systemId -> do-    Just (systemFunction, lastSystemTick) <- get (C @SystemFunction, C @SystemTick) systemId-    currentSystemTick <- liftIO $ readIORef world.tick+  for_ systems $ \(!systemId) -> do+    Just (!systemFunction, !lastSystemTick) <- single $ mkGet systemId (C @SystemFunction, C @SystemTick)+    !currentSystemTick <- liftIO $ readIORef world.tick -    set lastSystemTick (SystemTick currentSystemTick)+    insert (SystemTick currentSystemTick) systemId     insert (LastSystemTick lastSystemTick.inner) systemId      Control.Monad.Reader.local (hide . setSystemId (SystemId systemId) . unhide) $ do       systemFunction.inner       flush       flushAsync-      flushEvents+      tryRun       tick +  when (null systems) $ do+    flush+    flushAsync+    tryRun+    tick++simulateSystem :: System () -> System ()+simulateSystem s = do+  e <- spawn (SystemTick (Tick 0), LastSystemTick (Tick 0))+  Control.Monad.Reader.local (hide . setSystemId (SystemId e) . unhide) s++setSystemTicks :: Tick -> Tick -> System ()+setSystemTicks a b = do+  world <- unsafeGetWorld+  let SystemId id = world.systemId+  insert (LastSystemTick a, SystemTick b) id++tryRun :: System ()+tryRun = do+  World {trySystems = !trySystems} <- unsafeGetWorld+  newSystems <- liftIO $ newIORef []+  !trySystems' <- liftIO $ readIORef trySystems+  liftIO $ writeIORef trySystems []++  !trySystems'' <-+    filterM+      ( \(!s1, !s2) -> do+          !b <- s1+          case b of+            Nothing -> pure True+            Just x -> do+              s2 x++              World {trySystems = !trySystemsNew} <- unsafeGetWorld+              t <- liftIO $ readIORef trySystemsNew+              liftIO $ modifyIORef' newSystems (++ t)++              pure False+      )+      trySystems'+  t <- liftIO $ readIORef newSystems+  liftIO $ writeIORef trySystems (t ++ trySystems'')+  unless (null t) tryRun+ appInit :: System () appInit = do   insertRes $ def @Schedules -  systems <- liftIO Systems.newSystems+  !systems <- liftIO Systems.newSystems   insertRes systems -  init <- scheduleEntity Init-  pre <- scheduleEntity PreStartup-  startup <- scheduleEntity Startup-  post <- scheduleEntity PostStartup+  !pre <- scheduleEntity @PreStartup+  !startup <- scheduleEntity @Startup+  !post <- scheduleEntity @PostStartup -  for_ [init, pre, startup, post] $ insert StartupSchedule+  for_ [pre, startup, post] $ insert StartupSchedule -  insert (Rel Before pre) init   insert (Rel Before startup) pre   insert (Rel Before post) startup -  first <- scheduleEntity First-  pre <- scheduleEntity PreUpdate-  update <- scheduleEntity Update-  post <- scheduleEntity PostUpdate+  !first <- scheduleEntity @First+  !pre <- scheduleEntity @PreUpdate+  !update <- scheduleEntity @Update+  !post <- scheduleEntity @PostUpdate+  !last <- scheduleEntity @Last -  for_ [first, pre, update, post] $ insert UpdateSchedule+  for_ [first, pre, update, post, last] $ insert UpdateSchedule    insert (Rel Before pre) first   insert (Rel Before update) pre   insert (Rel Before post) update+  insert (Rel Before last) post -register :: forall c. (Runnable c) => System ()-register = runFor @c registerComponent+-- | Register a Component. This is done automatically when inserting it for the first time.+register :: forall c. (Component c) => System ()+register = registerComponent $ Proxy @c  registerComponent :: forall c. (Component c) => Proxy c -> System ()-registerComponent c = do+registerComponent !c = do   _ <- getOrAddComponentId (ComponentType c)-  return ()+  pure ()  getTools :: SystemTools getTools =@@ -144,30 +191,39 @@       spawnByInsert = toolsSpawnByInsert     } -toolsGet :: forall c m w. (MonadSystem w m, QueryType c) => Proxy c -> Entity -> m (Maybe c)-toolsGet _ = get (Val (C @c))+toolsGet :: forall c m w. (MonadSystem w m, Component c) => Proxy c -> Entity -> m (Maybe c)+toolsGet _ !e = single $ mkGet e (C @c)  toolsSet :: forall c. (Bundle c) => c -> Entity -> System () toolsSet = insert -toolsGetRAny :: forall c m w. (Component c, MonadSystem w m, RelExclusivity c ~ Inclusive) => Proxy c -> Entity -> m (Maybe [Rel c])-toolsGetRAny _ = get (Val (R @c Any))+toolsGetRAny :: forall c m w. (Component c, MonadSystem w m, IsExclusiveRel c ~ False) => Proxy c -> Entity -> m (Maybe [Rel c])+toolsGetRAny _ !e = single $ mkGet e (R @c Any)  toolsSpawnByInsert :: forall b. (Bundle b) => Entity -> b -> System () toolsSpawnByInsert = spawnEntityByInsert  incTick :: Tick -> Maybe Tick-incTick (Tick (a, b)) | a == maxBound && b == maxBound = Nothing-incTick (Tick (a, b)) | b == maxBound = Just $ Tick (a + 1, 0)-incTick (Tick (a, b)) = Just $ Tick (a, b + 1)+incTick (Tick !a) | a == maxBound = Nothing+incTick (Tick !a) = Just $ Tick (a + 1)  -- | Increment the World's Tick. tick :: System () tick = do-  world <- unsafeGetWorld-  tick <- liftIO $ incTick <$> readIORef world.tick+  !world <- unsafeGetWorld+  !tick <- liftIO $ incTick <$> readIORef world.tick   case tick of     Nothing -> do       warn "Reached maximum Tick. Resetting count. Previous changed will not be detected."-      liftIO $ writeIORef world.tick $ Tick (0, 0)-    Just t -> liftIO $ writeIORef world.tick t+      liftIO $ writeIORef world.tick $ Tick 0+    Just !t -> liftIO $ writeIORef world.tick t++getTick :: (MonadSystem w m) => m Tick+getTick = do+  world <- unsafeGetWorld+  liftIO $ readIORef world.tick++setTick :: Tick -> System ()+setTick tick = do+  world <- unsafeGetWorld+  liftIO $ writeIORef world.tick tick

@@ -1,56 +1,58 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+ {- HLINT ignore "Use newtype instead of data" -}-module Mischief.ECS.App.Plugins where+module Mischief.ECS.App.Plugins (Plugin (..), Dependency, dep, addPluginRec) where +import Control.Monad import Data.Foldable-import Data.Map (Map)-import Data.Map qualified as Map+import Data.Kind+import Data.Set (Set)+import Data.Set qualified as Set import Data.Typeable-import Mischief.ECS.Collectable-import Mischief.ECS.Components.Bundle+import Mischief.ECS.Components import Mischief.ECS.Components.Common import Mischief.ECS.World-import Unsafe.Coerce+import Mischief.ECS.World.Query+import Mischief.ECS.World.Query.Markers+import Mischief.ECS.World.Query.QueryFilter+import Mischief.ECS.World.Spawn -class (Typeable p, Eq p) => Plugin p where-  plugins :: p -> Plugins-  plugins _ = collect ()+class (Typeable p) => Plugin (p :: Type) where+  deps :: [Dependency]+  deps = [] -  init :: p -> System ()-  init _ = pure ()+  init :: System ()+  init = pure () -data ErasedPlugin where-  ErasedPlugin :: (Plugin p, Eq p) => p -> ErasedPlugin+data Dependency where+  Dependency :: (Plugin p) => Proxy p -> Dependency -getInit :: ErasedPlugin -> System ()-getInit (ErasedPlugin p) = Mischief.ECS.App.Plugins.init p+instance Eq Dependency where+  (Dependency !p) == (Dependency !p') = typeRep p == typeRep p' -newtype Plugins = Plugins {inner :: [ErasedPlugin]} deriving newtype (Semigroup, Monoid)+instance Ord Dependency where+  compare (Dependency !p) (Dependency !p') = compare (typeRep p) (typeRep p') -instance (Plugin p) => EraseIntoStorage p Plugins where-  erase p = Plugins [ErasedPlugin p]+instance Show Dependency where+  show (Dependency !p) = show (typeRep p) -instance {-# OVERLAPPING #-} EraseIntoStorage () Plugins where-  erase _ = Plugins []+dep :: forall p. (Plugin p) => Dependency+dep = Dependency (Proxy @p) -newtype PluginData = PluginData {inner :: Map TypeRep ErasedPlugin}+data PluginMarker p = PluginMarker deriving (Component) -instance Show PluginData where-  show p = show $ map fst $ Map.toList p.inner+addPluginRec :: forall p. (Plugin p) => System ()+addPluginRec = addPluginRec' @p Set.empty -plug :: (Collectable p Plugins) => p -> Plugins-plug = collect+addPluginRec' :: forall p. (Plugin p) => Set Dependency -> System ()+addPluginRec' !set = do+  !x <- query $ mkQuery' E (With (C @(PluginMarker p))) -addErasedRec :: ErasedPlugin -> PluginData -> PluginData-addErasedRec (ErasedPlugin (plugin :: p)) d =-  case Map.lookup (typeOf plugin) d.inner of-    Nothing -> foldr addErasedRec (PluginData $ Map.insert (typeOf plugin) (ErasedPlugin plugin) d.inner) (plugins plugin).inner-    Just other ->-      if plugin == unsafeCoerce other-        then d-        else undefined+  when (null x) $ do+    when (Set.member (Dependency (Proxy @p)) set) $ error $ "Cyclic Plugin Dependency: " ++ show set -plugAll :: (Plugin p) => p -> PluginData-plugAll p = addErasedRec (ErasedPlugin p) (PluginData Map.empty)+    for_ (Mischief.ECS.App.Plugins.deps @p) $ \(Dependency (_ :: Proxy p')) -> do+      addPluginRec' @p' (Set.insert (Dependency (Proxy @p)) set) -runPluginRec :: (Plugin p) => p -> System ()-runPluginRec p = for_ (map snd $ Map.toList (plugAll p).inner) getInit+    void $ spawn (Name . show . typeRep $ Proxy @p, PluginMarker @p)+    Mischief.ECS.App.Plugins.init @p

@@ -1,3 +1,5 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+ module Mischief.ECS.App.Schedules where  import Data.Data@@ -7,11 +9,8 @@ import GHC.Generics import Mischief.ECS.Components import Mischief.ECS.Entities-import Mischief.ECS.Log import Mischief.ECS.Resources import Mischief.ECS.World-import Mischief.ECS.World.Modify-import Mischief.ECS.World.Query import Mischief.ECS.World.Spawn  newtype ScheduleLabel = ScheduleLabel {rep :: TypeRep}@@ -20,26 +19,30 @@  class (Typeable s) => Schedule s -data Init = Init deriving (Schedule, Show)+data Init deriving (Schedule, Show) -data PreStartup = PreStartup deriving (Schedule)+data PreStartup deriving (Schedule) -data Startup = Startup deriving (Schedule, Show)+data Startup deriving (Schedule, Show) -data PostStartup = PostStartup deriving (Schedule)+data PostStartup deriving (Schedule) -data First = First deriving (Schedule, Show)+data First deriving (Schedule, Show) -data Update = Update deriving (Schedule, Show)+data Update deriving (Schedule, Show) -data PreUpdate = PreUpdate deriving (Schedule)+data PreUpdate deriving (Schedule) -data PostUpdate = PostUpdate deriving (Schedule)+data PostUpdate deriving (Schedule) +data Last deriving (Schedule)+ data StartupSchedule = StartupSchedule deriving (Component)  data UpdateSchedule = UpdateSchedule deriving (Component) +data FixedSchedule = FixedSchedule deriving (Component)+ newtype ScheduleId = ScheduleId {id :: Entity} deriving (Ord, Eq, Show)  newtype Schedules = Schedules {inner :: Map TypeRep ScheduleId}@@ -47,18 +50,16 @@   deriving anyclass (Component, Default)  getScheduleId :: ScheduleLabel -> System ScheduleId-getScheduleId sch = do-  Just schedules <- res @Schedules+getScheduleId !sch = do+  Just !schedules <- res @Schedules   case Map.lookup sch.rep schedules.inner of-    Just x -> return x+    Just !x -> return x     Nothing -> do-      e <- spawn sch+      !e <- spawn sch       insertRes $ Schedules $ Map.insert sch.rep (ScheduleId e) schedules.inner       return $ ScheduleId e -scheduleEntity :: (Schedule sch) => sch -> System Entity-scheduleEntity sch = do-  ScheduleId id <- getScheduleId $ ScheduleLabel $ typeOf sch+scheduleEntity :: forall sch. (Schedule sch) => System Entity+scheduleEntity = do+  ScheduleId !id <- getScheduleId $ ScheduleLabel $ typeRep (Proxy @sch)   return id---- runSystemsIn :: (Schedule sch) => sch -> System ()

@@ -1,42 +0,0 @@-module Mischief.ECS.App.SystemConfig where--import Mischief.ECS.World--data SystemConfigData = SystemConfigData-  { systems :: [System ()],-    edges :: [(System (), System ())]-  }---- | First type will be a SystemConfig. Second type will be a System ().-data SystemConfigModifier s1 s2 = ModAfter s1 s2 | ModBefore s1 s2--after :: s1 -> System () -> SystemConfigModifier s1 (System ())-after = ModAfter--before :: s1 -> System () -> SystemConfigModifier s1 (System ())-before = ModBefore--class SystemConfig s where-  systemConfigData :: s -> SystemConfigData--instance SystemConfig (System ()) where-  systemConfigData :: System () -> SystemConfigData-  systemConfigData system = SystemConfigData {systems = [system], edges = []}--instance (SystemConfig s1) => SystemConfig (SystemConfigModifier s1 (System ())) where-  systemConfigData :: SystemConfigModifier s1 (System ()) -> SystemConfigData-  systemConfigData (ModAfter s1 s2) =-    let SystemConfigData {systems, edges} = systemConfigData s1-        newEdges = [(s2, system) | system <- systems]-     in SystemConfigData {systems, edges = newEdges ++ edges}-  systemConfigData (ModBefore s1 s2) =-    let SystemConfigData {systems, edges} = systemConfigData s1-        newEdges = [(system, s2) | system <- systems]-     in SystemConfigData {systems, edges = newEdges ++ edges}--instance (SystemConfig s0, SystemConfig s1) => SystemConfig (s0, s1) where-  systemConfigData :: (s0, s1) -> SystemConfigData-  systemConfigData (s0, s1) =-    let SystemConfigData {systems = systems0, edges = edges0} = systemConfigData s0-        SystemConfigData {systems = systems1, edges = edges1} = systemConfigData s1-     in SystemConfigData {systems = systems0 ++ systems1, edges = edges0 ++ edges1}

@@ -3,7 +3,6 @@ import Data.Default import GHC.Generics import Mischief.ECS.Components-import Mischief.ECS.World  newtype SystemTick = SystemTick {inner :: Tick}   deriving stock (Generic)

@@ -3,31 +3,22 @@ module Mischief.ECS.App.Systems where  import Control.Monad.IO.Class-import Control.Monad.Reader-import Data.Default import Data.Foldable import Data.IORef import Data.Map (Map) import Data.Map qualified as Map-import GHC.Generics import GHC.StableName (StableName, eqStableName, hashStableName, makeStableName) import GHC.Stack.Types import Mischief.ECS.App.Schedules import Mischief.ECS.App.SystemDef import Mischief.ECS.Components-import Mischief.ECS.Components.Bundle import Mischief.ECS.Components.Required import Mischief.ECS.Entities-import Mischief.ECS.Log-import Mischief.ECS.Relationships.Order import Mischief.ECS.Resources-import Mischief.ECS.Tables import Mischief.ECS.Utils import Mischief.ECS.World-import Mischief.ECS.World.Insert import Mischief.ECS.World.Query import Mischief.ECS.World.Query.Markers-import Mischief.ECS.World.Query.Queryable import Mischief.ECS.World.Spawn  newtype Systems = Systems@@ -42,68 +33,68 @@  newSystems :: IO Systems newSystems = do-  systemMap <- newIORef Map.empty-  return Systems {systemMap}+  !systemMap <- newIORef Map.empty+  pure Systems {systemMap}  getSystemId' :: (HasCallStack) => ScheduleId -> System () -> StableName (System ()) -> IORef [(StableName (System ()), SystemId)] -> System SystemId-getSystemId' schedule system stableName list = do-  list' <- liftIO $ readIORef list+getSystemId' !schedule !system !stableName !list = do+  !list' <- liftIO $ readIORef list   case find (\x -> fst x `eqStableName` stableName) list' of-    Just (_, x) -> return x+    Just (_, !x) -> return x     Nothing -> do-      index <- spawn (SystemFunction system, Rel ScheduledIn schedule.id)+      !index <- spawn (SystemFunction system, Rel ScheduledIn schedule.id)       liftIO $ modifyIORef' list (++ [(stableName, SystemId index)])-      return $ SystemId index+      pure $ SystemId index  getSystemId :: (HasCallStack) => ScheduleId -> System () -> System SystemId-getSystemId sch system = do+getSystemId !sch !system = do   Systems {systemMap} <- unwrap <$> (res @Systems) -  stableName <- liftIO $ makeStableName system-  systemMap' <- liftIO $ readIORef systemMap+  !stableName <- liftIO $ makeStableName system+  !systemMap' <- liftIO $ readIORef systemMap    case Map.lookup (sch, hashStableName stableName) systemMap' of-    Just x -> getSystemId' sch system stableName x+    Just !x -> getSystemId' sch system stableName x     Nothing -> do-      l <- liftIO $ newIORef []+      !l <- liftIO $ newIORef []       liftIO $ modifyIORef' systemMap (Map.insert (sch, hashStableName stableName) l)       getSystemId' sch system stableName l  removeSystemFromMap' :: StableName (System ()) -> IORef [(StableName (System ()), SystemId)] -> System ()-removeSystemFromMap' stableName list = do+removeSystemFromMap' !stableName !list = do   liftIO $ modifyIORef' list $ filter (\x -> not $ fst x `eqStableName` stableName)  removeSystemFromMap :: ScheduleId -> System () -> System ()-removeSystemFromMap sch system = do+removeSystemFromMap !sch !system = do   Systems {systemMap} <- unwrap <$> (res @Systems) -  stableName <- liftIO $ makeStableName system-  systemMap' <- liftIO $ readIORef systemMap+  !stableName <- liftIO $ makeStableName system+  !systemMap' <- liftIO $ readIORef systemMap    forM_     (Map.lookup (sch, hashStableName stableName) systemMap')     (removeSystemFromMap' stableName) -systemEntity :: (HasCallStack, Schedule sch) => sch -> System () -> System Entity-systemEntity sch s = do-  schId <- scheduleEntity sch-  x <- getSystemId (ScheduleId schId) s-  return x.id+systemEntity :: forall sch. (HasCallStack, Schedule sch) => System () -> System Entity+systemEntity !s = do+  !schId <- scheduleEntity @sch+  !x <- getSystemId (ScheduleId schId) s+  pure x.id  self :: forall m w. (MonadSystem w m) => m Entity self = do-  world <- unsafeGetWorld-  let (SystemId sys) = world.systemId-  return sys+  !world <- unsafeGetWorld+  let (SystemId !sys) = world.systemId+  pure sys  data ScheduledIn = ScheduledIn deriving (Component)  getSystemTicks :: World -> IO (Tick, Tick)-getSystemTicks world = do-  let (SystemId sys) = world.systemId+getSystemTicks !world = do+  let (SystemId !sys) = world.systemId   runSystem     ( do-        Just (a, b) <- get (C @LastSystemTick, C @SystemTick) sys+        Just (!a, !b) <- single $ mkGet sys (C @LastSystemTick, C @SystemTick)         return (a.inner, b.inner)     )     world

@@ -1,12 +1,8 @@ module Mischief.ECS.Archetypes where -import Control.Monad-import Data.Foldable import Data.IORef-import Data.List import Data.Map (Map) import Data.Map qualified as Map-import Data.Maybe import Data.Set (Set) import Data.Set qualified as Set import Mischief.ECS.Components@@ -19,14 +15,14 @@  newArchetypeGraph :: IO ArchetypeGraph newArchetypeGraph = do-  nodes <- Vec.new 1024+  !nodes <- Vec.new 1024    -- Add the empty archetype to the graph.   Vec.pushBack nodes ArchetypeNode {archetype = ArchetypeData {id = ArchetypeId 0, components = Set.empty}, insert = Map.empty, remove = Map.empty} -  counter <- newIORef 1-  lookup <- newIORef $ Map.singleton Set.empty 0-  return $ ArchetypeGraph {nodes, lookup, counter}+  !counter <- newIORef 1+  !lookup <- newIORef $ Map.singleton Set.empty 0+  pure $ ArchetypeGraph {nodes, lookup, counter}  data ArchetypeNode = ArchetypeNode   { archetype :: ArchetypeData,

@@ -2,13 +2,10 @@  import Control.Monad import Control.Monad.IO.Class-import Control.Monad.Primitive-import Control.Monad.Reader import Data.Data import Data.Foldable import Data.IORef import Data.List-import Data.Map (Map, mapMaybe) import Data.Map qualified as Map import Data.Maybe import Data.Set (Set)@@ -16,33 +13,25 @@ import GHC.Base (eqWord#, isTrue#) import Mischief.ECS.Archetypes import Mischief.ECS.Components-import Mischief.ECS.Components.Common import Mischief.ECS.Entities-import Mischief.ECS.EntityDef-import Mischief.ECS.Log-import Mischief.ECS.Relationships import Mischief.ECS.Tables-import Mischief.ECS.Utils-import Mischief.ECS.Vec (IOVec) import Mischief.ECS.Vec qualified as Vec import Mischief.ECS.World-import Mischief.ECS.World (SystemTools (get))-import Mischief.ECS.World.Query.Queryable  data ArchetypeTransition = Inserted ComponentId | Removed ComponentId  getNewId :: ArchetypeGraph -> IO Int-getNewId ArchetypeGraph {counter} = do-  x <- readIORef counter+getNewId ArchetypeGraph {counter = !counter} = do+  !x <- readIORef counter   modifyIORef' counter (+ 1)-  return x+  pure x  createNode :: Set ComponentId -> System Int-createNode components = do-  world <- unsafeGetWorld-  let Archetypes {graph} = world.archetypes+createNode !components = do+  !world <- unsafeGetWorld+  let Archetypes {graph = !graph} = world.archetypes -  id <- liftIO $ getNewId graph+  !id <- liftIO $ getNewId graph   liftIO $ modifyIORef' graph.lookup $ Map.insert components id   Vec.pushBack graph.nodes ArchetypeNode {archetype = ArchetypeData {id = ArchetypeId id, components}, insert = Map.empty, remove = Map.empty} @@ -54,24 +43,29 @@   --     )   --     (Set.toList components) -  -- debug $ "archetype " <> text id <> " = " <> text (catMaybes comps)+  -- debug $ "archetype " <> T.show id <> " = " <> T.show (catMaybes comps) <> " (length = " <> T.show (length $ Set.toList components) <> ")"+  -- debug $ T.show $ Set.toList components    let Tables tables = world.tables   Vec.pushBack tables =<< liftIO (newTable $ Set.toList components) -  for_ components $ \(ComponentId (# id', target' #)) -> do+  for_ components $ \(ComponentId (# !id', !target' #)) -> do     case target' of       -- Component isn't a pair.       Nothing -> do-        set <- worldGet (Proxy @ComponentArchetypes) (Entity (# id', 0## #))+        !set <- worldGet (Proxy @ComponentArchetypes) (Entity (# id', 0## #))++        when (isNothing set) $ do+          worldSet (ComponentArchetypes {inner = Set.singleton (ArchetypeId id)}) (Entity (# id', 0## #))+         for_ set $ \set -> do           worldSet (ComponentArchetypes {inner = Set.insert (ArchetypeId id) set.inner}) (Entity (# id', 0## #))       -- modify set $ \ComponentArchetypes {inner} -> ComponentArchetypes {inner = Set.insert (ArchetypeId id) inner}       -- Component is a pair.-      Just e -> do+      Just !e -> do         set <- worldGet (Proxy @ComponentPairs) (Entity (# id', 0## #))         for_ set $ \set -> do-          let ComponentPairs {any, pairs} = set+          let !ComponentPairs {any, pairs} = set           flip worldSet (Entity (# id', 0## #)) $             ComponentPairs               { any = Set.insert (ArchetypeId id) any,@@ -79,52 +73,53 @@                   Map.alter                     ( \case                         Nothing -> Just $ Set.singleton $ ArchetypeId id-                        Just s -> Just $ Set.insert (ArchetypeId id) s+                        Just !s -> Just $ Set.insert (ArchetypeId id) s                     )                     e                     pairs               } -  return id+  pure id  getOrCreateNode :: Set ComponentId -> System Int-getOrCreateNode components = do-  world <- unsafeGetWorld-  let Archetypes {graph} = world.archetypes+getOrCreateNode !components = do+  !world <- unsafeGetWorld+  let Archetypes {graph = !graph} = world.archetypes -  lookup <- liftIO $ readIORef graph.lookup+  !lookup <- liftIO $ readIORef graph.lookup+  -- warn $ T.show lookup   case Map.lookup components lookup of-    Just x -> return x+    Just !x -> pure x     Nothing -> createNode components  addEdge :: Int -> Int -> ComponentId -> System ()-addEdge a b component = do-  world <- unsafeGetWorld-  let Archetypes {graph} = world.archetypes+addEdge !a !b !component = do+  !world <- unsafeGetWorld+  let Archetypes {graph = !graph} = world.archetypes   Vec.modify_ graph.nodes a $ \ArchetypeNode {insert, remove, archetype} -> ArchetypeNode {insert = Map.insert component b insert, remove, archetype}   Vec.modify_ graph.nodes b $ \ArchetypeNode {insert, remove, archetype} -> ArchetypeNode {insert, remove = Map.insert component a remove, archetype}  addEdgeI :: Int -> Int -> ComponentId -> System ()-addEdgeI a b component = do-  world <- unsafeGetWorld-  let Archetypes {graph} = world.archetypes+addEdgeI !a !b !component = do+  !world <- unsafeGetWorld+  let Archetypes {graph = !graph} = world.archetypes   Vec.modify_ graph.nodes a $ \ArchetypeNode {insert, remove, archetype} -> ArchetypeNode {insert = Map.insert component b insert, remove, archetype}  addEdgeR :: Int -> Int -> ComponentId -> System ()-addEdgeR a b component = do-  world <- unsafeGetWorld-  let Archetypes {graph} = world.archetypes+addEdgeR !a !b !component = do+  !world <- unsafeGetWorld+  let Archetypes {graph = !graph} = world.archetypes   Vec.modify_ graph.nodes b $ \ArchetypeNode {insert, remove, archetype} -> ArchetypeNode {insert, remove = Map.insert component a remove, archetype}  getArchetypeOnRemoveSingle :: ArchetypeId -> ComponentId -> System ArchetypeData-getArchetypeOnRemoveSingle (ArchetypeId id) component = do-  world <- unsafeGetWorld-  let Archetypes {graph} = world.archetypes+getArchetypeOnRemoveSingle (ArchetypeId !id) !component = do+  !world <- unsafeGetWorld+  let Archetypes {graph = !graph} = world.archetypes -  node <- Vec.read graph.nodes id+  !node <- Vec.read graph.nodes id    case Map.lookup component node.remove of-    Just x -> do+    Just !x -> do       newNode <- Vec.read graph.nodes x       return newNode.archetype     Nothing -> do@@ -132,136 +127,134 @@       -- TODO: check if another component requires this one!        let newComponents = Set.delete component components-      newId <- getOrCreateNode newComponents+      !newId <- getOrCreateNode newComponents       addEdgeR newId id component -      newNode <- Vec.read graph.nodes newId-      return newNode.archetype+      !newNode <- Vec.read graph.nodes newId+      pure newNode.archetype  getArchetypeOnInsertSingle :: ArchetypeId -> ComponentId -> System ArchetypeData-getArchetypeOnInsertSingle (ArchetypeId id) component = do-  world <- unsafeGetWorld-  let Archetypes {graph} = world.archetypes+getArchetypeOnInsertSingle (ArchetypeId !id) !component = do+  !world <- unsafeGetWorld+  let Archetypes {graph = !graph} = world.archetypes -  node <- Vec.read graph.nodes id+  !node <- Vec.read graph.nodes id    case Map.lookup component node.insert of-    Just x -> do-      newNode <- Vec.read graph.nodes x-      return newNode.archetype+    Just !x -> do+      !newNode <- Vec.read graph.nodes x+      pure newNode.archetype     Nothing -> do       components <- do         let components = node.archetype.components--        let !(ComponentId (# id, _ #)) = component+        let !(ComponentId (# !id, _ #)) = component -        isExclusiveRel <- isJust <$> worldGet (Proxy @IsExclusiveRelationship) (Entity (# id, 0## #))+        !isExclusiveRel <- isJust <$> worldGet (Proxy @IsExclusiveRelationship) (Entity (# id, 0## #))          case isExclusiveRel of           True ->-            return $ Set.filter (\(ComponentId (# id', a #)) -> not (isTrue# $ eqWord# id' id) || isNothing a) components+            pure $ Set.filter (\(ComponentId (# id', a #)) -> not (isTrue# $ eqWord# id' id) || isNothing a) components           _ ->-            return components+            pure components -      requirements <- getRequirements component+      !requirements <- getRequirements component -      let newComponents = Set.union (Set.insert component components) requirements+      let !newComponents = Set.union (Set.insert component components) requirements -      newId <- getOrCreateNode newComponents+      !newId <- getOrCreateNode newComponents       addEdgeI id newId component -      newNode <- Vec.read graph.nodes newId-      return newNode.archetype+      !newNode <- Vec.read graph.nodes newId+      pure newNode.archetype  getArchetypeOnInsert :: ArchetypeId -> [ComponentId] -> System ArchetypeData-getArchetypeOnInsert archetype components =+getArchetypeOnInsert !archetype !components =   do-    world <- unsafeGetWorld-    let Archetypes {graph} = world.archetypes-    let d = ArchetypeData {id = archetype, components = Set.empty}+    !world <- unsafeGetWorld+    let Archetypes {graph = !graph} = world.archetypes+    let !d = ArchetypeData {id = archetype, components = Set.empty}      f d components graph   where-    f archetype [] _ = return archetype-    f archetype (component : xs) graph = do-      x <- getArchetypeOnInsertSingle archetype.id component+    f !archetype [] _ = pure archetype+    f !archetype (!component : !xs) graph = do+      !x <- getArchetypeOnInsertSingle archetype.id component       f x xs graph  newtype ArchetypeRemovalResult = ArchetypeRemovalResult {removed :: [ComponentId]}  getArchetypeOnRemove :: ArchetypeId -> [ComponentId] -> System (ArchetypeData, [ComponentId])-getArchetypeOnRemove archetype components =+getArchetypeOnRemove !archetype !components =   do-    world <- unsafeGetWorld-    let Archetypes {graph} = world.archetypes-    let d = ArchetypeData {id = archetype, components = Set.empty}+    !world <- unsafeGetWorld+    let Archetypes {graph = !graph} = world.archetypes+    let !d = ArchetypeData {id = archetype, components = Set.empty}      f d components graph   where-    f archetype [] _ = return (archetype, [])-    f archetype (component : xs) graph = do-      x <- getArchetypeOnRemoveSingle archetype.id component+    f !archetype [] _ = pure (archetype, [])+    f !archetype (!component : !xs) !graph = do+      !x <- getArchetypeOnRemoveSingle archetype.id component -      (a, b) <- f x xs graph+      (!a, !b) <- f x xs graph       if x.id /= archetype.id-        then return (a, b ++ [component])-        else return (a, b)+        then pure (a, b ++ [component])+        else pure (a, b)  getArchetypeOnSpawn :: [ComponentId] -> System ArchetypeData-getArchetypeOnSpawn components =+getArchetypeOnSpawn !components =   do-    world <- unsafeGetWorld-    let Archetypes {graph} = world.archetypes+    !world <- unsafeGetWorld+    let Archetypes {graph = !graph} = world.archetypes -    regs <- mapM getRequirements components+    !regs <- mapM getRequirements components -    let allComps = foldr' (flip Set.union) (Set.fromList components) regs-    node <- getOrCreateNode allComps+    let !allComps = foldr' (flip Set.union) (Set.fromList components) regs+    !node <- getOrCreateNode allComps -    nodeData <- Vec.read graph.nodes node+    !nodeData <- Vec.read graph.nodes node -    return nodeData.archetype+    pure nodeData.archetype  getRequirements :: ComponentId -> System (Set ComponentId)-getRequirements (ComponentId (# id, _ #)) = do-  x <- worldGetRAny (Proxy @Requires) (Entity (# id, 0## #))-  return $ case x of+getRequirements (ComponentId (# !id, _ #)) = do+  !x <- worldGetRAny (Proxy @Requires) (Entity (# id, 0## #))+  pure $ case x of     Nothing -> Set.empty-    Just x -> Set.fromList $ map ((\(Entity (# id, _ #)) -> ComponentId (# id, Nothing #)) . (\x -> x.target)) x+    Just !x -> Set.fromList $ map ((\(Entity (# id, _ #)) -> ComponentId (# id, Nothing #)) . (\x -> x.target)) x  data ComponentQuery = ComponentQuery | RelationshipQueryAny | RelationshipQuery -findMatchingArchetypes :: forall m w. (MonadSystem w m) => [(ComponentId, ComponentQuery)] -> Archetypes -> m [([ComponentId], ArchetypeId)]+findMatchingArchetypes :: forall m w. (MonadSystem w m) => [(ComponentId, ComponentQuery)] -> Archetypes -> m [ArchetypeId] findMatchingArchetypes [] _ = allArchetypes findMatchingArchetypes components Archetypes {graph} = do-  archetypes'' <- forM components $ \(ComponentId (# id, target #), q) -> do+  !archetypes'' <- forM components $ \(ComponentId (# id, target #), q) -> do     case q of       ComponentQuery -> do-        Just x <- worldGet (Proxy @ComponentArchetypes) (Entity (# id, 0## #))+        !x <- fromMaybe (ComponentArchetypes Set.empty) <$> worldGet (Proxy @ComponentArchetypes) (Entity (# id, 0## #))         return x.inner       RelationshipQueryAny -> do-        Just x <- worldGet (Proxy @ComponentPairs) (Entity (# id, 0## #))+        Just !x <- worldGet (Proxy @ComponentPairs) (Entity (# id, 0## #))         return x.any       RelationshipQuery -> do         case target of           Nothing -> undefined-          Just target -> do-            Just x <- worldGet (Proxy @ComponentPairs) (Entity (# id, 0## #))+          Just !target -> do+            Just !x <- worldGet (Proxy @ComponentPairs) (Entity (# id, 0## #))             return $ fromMaybe undefined $ Map.lookup target x.pairs    case map Set.toList archetypes'' of     [] -> return []-    h : tail -> do-      let archetypes = foldr intersect h tail+    !h : !tail -> do+      let !archetypes = foldr intersect h tail        mapM-        ( \(ArchetypeId x) -> do-            x' <- Vec.read graph.nodes x-            return (Set.toList x'.archetype.components, ArchetypeId x)+        ( \(ArchetypeId !x) -> do+            pure $ ArchetypeId x         )         archetypes -allArchetypes :: forall m w. (MonadSystem w m) => m [([ComponentId], ArchetypeId)]+allArchetypes :: forall m w. (MonadSystem w m) => m [ArchetypeId] allArchetypes = do-  world <- unsafeGetWorld-  map (\x -> (Set.toList x.archetype.components, x.archetype.id)) <$> Vec.toList world.archetypes.graph.nodes+  !world <- unsafeGetWorld+  map (\(!x) -> x.archetype.id) <$> Vec.toList world.archetypes.graph.nodes

@@ -1,7 +1,5 @@ module Mischief.ECS.Collectable where -class Idk x y- class (Semigroup s) => EraseIntoStorage v s where   erase :: v -> s 

@@ -27,8 +27,7 @@     BundleElement (..),      -- * Tables-    ComponentTicks (..),-    ComponentData (..),+    ComponentTick (..),      -- * Storage     Components (..),@@ -38,25 +37,27 @@     -- * Utils     Pair (..),     Rel (..),+    From (..),+    Res (..),     ComponentRep (..),     Tick (..),     ErasedComponentEq (..),     IsExclusive (..),     isPair,     setCompIdTarget,+    IsExclusiveRelationship (..),   ) where  import Data.Default import Data.HashTable.IO qualified as H-import Data.IORef import Data.Kind import Data.List qualified as List import Data.Map (Map)-import Data.Map qualified as Map import Data.Set (Set) import Data.Set qualified as Set import Data.Typeable+import Data.Word (Word64) import GHC.Base (Word (W#), Word#, compareWord#, eqWord#, isTrue#) import GHC.Generics import Mischief.ECS.Collectable@@ -67,7 +68,7 @@ data Exclusivity = Inclusive | Exclusive  -- | The @Component@ typeclass.-class (Typeable c, IsExclusive (RelExclusivity c)) => Component c where+class (Typeable c, IsExclusive (IsExclusiveRel c)) => Component c where   -- | List of components required by this one.   -- All required components must be 'Default'   --@@ -87,31 +88,51 @@   required :: Set DefaultComponentType   required = Set.empty -  type RelExclusivity c :: Exclusivity-  type RelExclusivity c = Inclusive+  -- | Set whether the relationships this component is used in are exclusive or not.+  type IsExclusiveRel c :: Bool -  hooks :: Hooks c-  hooks = Hooks []+  type IsExclusiveRel c = False -class IsExclusive (e :: Exclusivity) where+  onAdd :: [Hook c]+  onAdd = []++  onSet :: [Hook c]+  onSet = []++  onRemove :: [Hook c]+  onRemove = []++  onAddRel :: [HookRel c]+  onAddRel = []++  onSetRel :: [HookRel c]+  onSetRel = []++  onRemoveRel :: [HookRel c]+  onRemoveRel = []++class IsExclusive (e :: Bool) where   isExclusive :: Bool -instance IsExclusive Inclusive where+instance IsExclusive False where   isExclusive = False -instance IsExclusive Exclusive where+instance IsExclusive True where   isExclusive = True  -- | Unique id for components and component pairs. data ComponentId = ComponentId (# Word#, Maybe Entity #) +instance Show ComponentId where+  show (ComponentId (# !a, !b #)) = "Component (" ++ show (W# a) ++ ", " ++ show b ++ ")"+ instance Eq ComponentId where   (==) :: ComponentId -> ComponentId -> Bool-  (==) (ComponentId (# a, b #)) (ComponentId (# x, y #)) = isTrue# (eqWord# a x) && b == y+  (==) (ComponentId (# !a, !b #)) (ComponentId (# !x, !y #)) = isTrue# (eqWord# a x) && b == y  instance Ord ComponentId where   compare :: ComponentId -> ComponentId -> Ordering-  compare (ComponentId (# a, b #)) ((ComponentId (# x, y #))) =+  compare (ComponentId (# !a, !b #)) ((ComponentId (# !x, !y #))) =     case compareWord# a x of       EQ -> compare b y       x -> x@@ -128,8 +149,8 @@ isPair _ = False  setCompIdTarget :: Maybe Entity -> ComponentId -> ComponentId-setCompIdTarget Nothing (ComponentId (# a, _ #)) = ComponentId (# a, Nothing #)-setCompIdTarget (Just e) (ComponentId (# a, _ #)) = ComponentId (# a, Just e #)+setCompIdTarget Nothing (ComponentId (# !a, _ #)) = ComponentId (# a, Nothing #)+setCompIdTarget (Just !e) (ComponentId (# !a, _ #)) = ComponentId (# a, Just e #)  newtype Pair = Pair (ComponentType, Entity) @@ -163,41 +184,62 @@  -- | Get the id of a component through IO. getComponentId :: TypeRep -> Components -> IO (Maybe ComponentId)-getComponentId t Components {components} = do-  comp <- H.lookup components t-  return $ case comp of+getComponentId !t Components {components = !components} = do+  !comp <- H.lookup components t+  pure $ case comp of     Nothing -> Nothing-    Just (W# t) -> Just $ ComponentId (# t, Nothing #)+    Just (W# !t) -> Just $ ComponentId (# t, Nothing #)  -- | Try to get the inner data of a 'ErasedComponent'. tryGetComponent :: forall c. (Component c) => ErasedComponent -> Maybe c-tryGetComponent (ErasedComponent (s :: c')) =+tryGetComponent (ErasedComponent (!s :: c')) =   case eqT @c @c' of     Just Refl -> Just s     Nothing -> Nothing  instance {-# OVERLAPPING #-} EraseIntoStorage () (BundleData ErasedComponent) where-  erase _ = BundleData Set.empty+  erase _ = BundleData Set.empty Set.empty Set.empty  instance {-# OVERLAPPING #-} EraseIntoStorage (BundleData ErasedComponent) (BundleData ErasedComponent) where   erase = id  instance (Component c) => EraseIntoStorage c (BundleData ErasedComponent) where-  erase c =-    BundleData $ Set.singleton BundleElement {rep = ComponentRep $ ComponentType $ Proxy @c, component = ErasedComponent c}+  erase !c =+    BundleData (Set.singleton BundleElement {rep = ComponentRep $ ComponentType $ Proxy @c, component = ErasedComponent c}) Set.empty Set.empty  instance {-# OVERLAPPING #-} (Component c) => EraseIntoStorage (Rel c) (BundleData ErasedComponent) where-  erase (Rel c entity) =-    BundleData $ Set.singleton BundleElement {rep = PairRep (ComponentType $ Proxy @c, entity), component = ErasedComponent c}+  erase (Rel !c !entity) =+    BundleData (Set.singleton BundleElement {rep = PairRep (ComponentType $ Proxy @c, entity), component = ErasedComponent c}) Set.empty Set.empty +instance {-# OVERLAPPING #-} (Component c) => EraseIntoStorage (Res c) (BundleData ErasedComponent) where+  erase (Res !c) = BundleData Set.empty (Set.singleton BundleElement {rep = ComponentRep $ ComponentType $ Proxy @c, component = ErasedComponent c}) Set.empty++instance {-# OVERLAPPING #-} (Collectable c (BundleData ErasedComponent)) => EraseIntoStorage (From c) (BundleData ErasedComponent) where+  erase (From !e !c) = BundleData Set.empty Set.empty (Set.singleton (e, collect c))++instance {-# OVERLAPPING #-} (Collectable c (BundleData ErasedComponent)) => EraseIntoStorage [c] (BundleData ErasedComponent) where+  erase = foldr ((<>) . collect) (BundleData Set.empty Set.empty Set.empty)+ instance (Component c, Eq c) => EraseIntoStorage c (BundleData ErasedComponentEq) where-  erase c =-    BundleData $ Set.singleton BundleElement {rep = ComponentRep $ ComponentType $ Proxy @c, component = ErasedComponentEq c}+  erase !c =+    BundleData (Set.singleton BundleElement {rep = ComponentRep $ ComponentType $ Proxy @c, component = ErasedComponentEq c}) Set.empty Set.empty  instance {-# OVERLAPPING #-} (Component c, Eq c) => EraseIntoStorage (Rel c) (BundleData ErasedComponentEq) where-  erase (Rel c entity) =-    BundleData $ Set.singleton BundleElement {rep = PairRep (ComponentType $ Proxy @c, entity), component = ErasedComponentEq c}+  erase (Rel !c !entity) =+    BundleData (Set.singleton BundleElement {rep = PairRep (ComponentType $ Proxy @c, entity), component = ErasedComponentEq c}) Set.empty Set.empty +instance {-# OVERLAPPING #-} (Component c, Eq c) => EraseIntoStorage (Res c) (BundleData ErasedComponentEq) where+  erase (Res !c) = BundleData Set.empty (Set.singleton BundleElement {rep = ComponentRep $ ComponentType $ Proxy @c, component = ErasedComponentEq c}) Set.empty++instance {-# OVERLAPPING #-} (Collectable c (BundleData ErasedComponentEq)) => EraseIntoStorage (From c) (BundleData ErasedComponentEq) where+  erase (From !e !c) = BundleData Set.empty Set.empty (Set.singleton (e, collect c))++instance {-# OVERLAPPING #-} (Collectable c (BundleData ErasedComponentEq)) => EraseIntoStorage [c] (BundleData ErasedComponentEq) where+  erase = foldr ((<>) . collect) (BundleData Set.empty Set.empty Set.empty)++instance {-# OVERLAPPING #-} EraseIntoStorage (BundleData ErasedComponentEq) (BundleData ErasedComponentEq) where+  erase = id+ -- | Unique id corresponding to an archetype. newtype ArchetypeId = ArchetypeId   { id :: Int@@ -205,22 +247,42 @@   deriving (Show, Eq, Ord)  -- | Data extracted from a 'Mischief.ECS.Components.Bundle.Bundle'.-newtype BundleData e = BundleData {elements :: Set (BundleElement e)} deriving newtype (Semigroup)+data BundleData e = BundleData {elements :: Set (BundleElement e), resources :: Set (BundleElement e), external :: Set (Entity, BundleData e)} deriving (Eq, Ord) +instance Semigroup (BundleData e) where+  (<>) (BundleData a0 b0 c0) (BundleData a1 b1 c1) = BundleData (a0 <> a1) (b0 <> b1) (c0 <> c1)+ instance Show (BundleData e) where-  show BundleData {elements} = mconcat ["BundleData e [", List.intercalate ", " ts, "]"]+  show BundleData {elements = !elements} = mconcat ["BundleData e [", List.intercalate ", " ts, "]"]     where-      ts = map (\bundle -> show bundle.rep) (Set.toList elements)+      !ts = map (\bundle -> show bundle.rep) (Set.toList elements)  -- | Change ticks for a specific component.-data ComponentTicks = ComponentTicks {changed :: Tick, added :: Tick} deriving (Show)---- | Data for a component that's stored in a table.-data ComponentData = ComponentData {value :: ErasedComponent, ticks :: ComponentTicks}+newtype ComponentTick = ComponentTick Tick deriving (Show)  -- | Type used for querying and inserting relationships.-data Rel c = Rel {comp :: c, target :: Entity} deriving (Show)+data Rel c = Rel {comp :: c, target :: Entity} deriving (Eq) +instance Functor Rel where+  fmap !f (Rel !c !target) = Rel (f c) target++instance (Show c) => Show (Rel c) where+  show Rel {comp = !comp, target = !target} = "Rel (" ++ show comp ++ ", " ++ show target ++ ")"++data From c = From {entity :: Entity, comp :: c} deriving (Eq)++instance Functor From where+  fmap :: (a -> b) -> From a -> From b+  fmap !f (From !c !x) = From c (f x)++instance (Show c) => Show (From c) where+  show From {entity = !entity, comp = !comp} = "From (" ++ show entity ++ ", " ++ show comp ++ ")"++newtype Res c = Res {comp :: c} deriving newtype (Show, Eq)++instance Functor Res where+  fmap !f (Res !c) = Res (f c)+ -- | @Meta@ component with the /erased/ default value of this component. Added to components required by other components. newtype DefaultValue = DefaultValue ErasedComponent deriving anyclass (Component) @@ -247,15 +309,15 @@  instance Show (BundleElement a) where   show :: BundleElement a -> String-  show e = show e.rep+  show !e = show e.rep  instance Eq (BundleElement a) where   (==) :: BundleElement a -> BundleElement a -> Bool-  (==) BundleElement {rep = rep1} BundleElement {rep = rep2} = rep1 == rep2+  (==) BundleElement {rep = !rep1} BundleElement {rep = !rep2} = rep1 == rep2  instance Ord (BundleElement a) where   compare :: BundleElement a -> BundleElement a -> Ordering-  compare BundleElement {rep = rep1} BundleElement {rep = rep2} = compare rep1 rep2+  compare BundleElement {rep = !rep1} BundleElement {rep = !rep2} = compare rep1 rep2  -- @Meta@ component containing the erased type of this component. data ComponentType where@@ -263,30 +325,30 @@  instance Show ComponentType where   show :: ComponentType -> String-  show x = show $ getRep x+  show !x = show $ getRep x  instance Eq ComponentType where   (==) :: ComponentType -> ComponentType -> Bool-  (==) a b = getRep a == getRep b+  (==) !a !b = getRep a == getRep b  instance Ord ComponentType where   compare :: ComponentType -> ComponentType -> Ordering-  compare a b = compare (getRep a) (getRep b)+  compare !a !b = compare (getRep a) (getRep b)  data DefaultComponentType where   DefaultComponentType :: forall (c :: Type). (Component c, Default c) => (Proxy c) -> DefaultComponentType  instance Show DefaultComponentType where   show :: DefaultComponentType -> String-  show x = show $ getRep x+  show !x = show $ getRep x  instance Eq DefaultComponentType where   (==) :: DefaultComponentType -> DefaultComponentType -> Bool-  (==) a b = getRep a == getRep b+  (==) !a !b = getRep a == getRep b  instance Ord DefaultComponentType where   compare :: DefaultComponentType -> DefaultComponentType -> Ordering-  compare a b = compare (getRep a) (getRep b)+  compare !a !b = compare (getRep a) (getRep b)  instance GetRep ComponentType where   getRep :: ComponentType -> TypeRep@@ -300,6 +362,8 @@   getRep :: DefaultComponentType -> TypeRep   getRep (DefaultComponentType (_ :: (Proxy t))) = typeRep $ Proxy @t -newtype Tick = Tick (Int, Int)+newtype Tick = Tick Word64   deriving stock (Show, Eq, Ord)   deriving newtype (Default)++data IsExclusiveRelationship = IsExclusiveRelationship deriving (Show, Component)

@@ -2,6 +2,7 @@  module Mischief.ECS.Components.Bundle where +import Data.Bifunctor qualified import Data.Set qualified as Set import Data.Typeable import Mischief.ECS.Collectable (Collectable (collect))@@ -9,33 +10,46 @@  newtype ProcessedBundleData = ProcessedBundleData {elements :: [ProcessedBundleElement]} -data ProcessedBundleElement = ProcessedBundleElement {id :: ComponentId, component :: ComponentData}+data ProcessedBundleElement = ProcessedBundleElement {id :: ComponentId, component :: ErasedComponent}  addComponentToBundleData :: forall c. (Component c) => c -> BundleData ErasedComponent -> BundleData ErasedComponent-addComponentToBundleData c (BundleData {elements}) =-  let rep = ComponentRep $ ComponentType (Proxy @c)-      component = ErasedComponent c-      element = BundleElement {rep, component}-   in BundleData {elements = Set.union elements (Set.singleton element)}+addComponentToBundleData !c (BundleData {elements = !elements, resources = !resources, external = !external}) =+  let !rep = ComponentRep $ ComponentType (Proxy @c)+      !component = ErasedComponent c+      !element = BundleElement {rep, component}+   in BundleData {elements = Set.union elements (Set.singleton element), resources, external}  instance Eq ProcessedBundleElement where   (==) :: ProcessedBundleElement -> ProcessedBundleElement -> Bool-  (==) ProcessedBundleElement {id = id1} ProcessedBundleElement {id = id2} = id1 == id2+  (==) ProcessedBundleElement {id = !id1} ProcessedBundleElement {id = !id2} = id1 == id2  instance Ord ProcessedBundleElement where   compare :: ProcessedBundleElement -> ProcessedBundleElement -> Ordering-  compare ProcessedBundleElement {id = id1} ProcessedBundleElement {id = id2} = compare id1 id2+  compare ProcessedBundleElement {id = !id1} ProcessedBundleElement {id = !id2} = compare id1 id2  type Bundle b = Collectable b (BundleData ErasedComponent)  bundleData :: (Bundle b) => b -> BundleData ErasedComponent bundleData = collect +type BundleBuilder = BundleData ErasedComponent++bundle :: (Bundle b) => b -> BundleBuilder+bundle = collect++type BundleEqBuilder = BundleData ErasedComponentEq++bundleEq :: (BundleEq b) => b -> BundleEqBuilder+bundleEq = collect+ type BundleEq b = Collectable b (BundleData ErasedComponentEq)  bundleDataEq :: (BundleEq b) => b -> BundleData ErasedComponentEq bundleDataEq = collect  bundleEqToSimple :: BundleData ErasedComponentEq -> BundleData ErasedComponent-bundleEqToSimple BundleData {elements} =-  BundleData $ Set.map (\BundleElement {rep, component = ErasedComponentEq (a :: s)} -> BundleElement {rep, component = ErasedComponent a}) elements+bundleEqToSimple BundleData {elements = !elements, resources = !resources, external = !external} =+  BundleData+    (Set.map (\BundleElement {rep, component = ErasedComponentEq (!a :: s)} -> BundleElement {rep, component = ErasedComponent a}) elements)+    (Set.map (\BundleElement {rep, component = ErasedComponentEq (!a :: s)} -> BundleElement {rep, component = ErasedComponent a}) resources)+    (Set.map (Data.Bifunctor.second bundleEqToSimple) external)

@@ -11,4 +11,4 @@  instance Show Name where   show :: Name -> String-  show (Name name) = show name+  show (Name !name) = name

@@ -1,9 +1,14 @@ module Mischief.ECS.Components.HooksDef where  import Data.Data-import Mischief.ECS.EventDef+import Mischief.ECS.EntityDef -data ErasedHook c where-  ErasedHook :: forall e c m. (Event (e c), Typeable m) => (e c -> m ()) -> ErasedHook c+data Hook a where+  Hook :: (Typeable m) => (HookContext -> m ()) -> Hook a -newtype Hooks c = Hooks [ErasedHook c] deriving newtype (Semigroup)+data HookRel a where+  HookRel :: (Typeable m) => (HookContextRel -> m ()) -> HookRel a++newtype HookContext = HookContext {entity :: Entity}++data HookContextRel = HookContextRel {entity :: Entity, target :: Entity}

@@ -20,11 +20,47 @@   defaultBundleData _ = Set.singleton $ DefaultComponentType $ Proxy @c  instance {-# OVERLAPPING #-} (RequiredBundle b0, RequiredBundle b1) => RequiredBundle (b0, b1) where-  defaultBundleData _ =-    let b0 = defaultBundleData (Proxy @b0)-        b1 = defaultBundleData (Proxy @b1)-     in Set.union b0 b1+  defaultBundleData _ = Set.unions [defaultBundleData $ Proxy @b0, defaultBundleData $ Proxy @b1] +instance {-# OVERLAPPING #-} (RequiredBundle b0, RequiredBundle b1, RequiredBundle b2) => RequiredBundle (b0, b1, b2) where+  defaultBundleData _ = Set.unions [defaultBundleData $ Proxy @b0, defaultBundleData $ Proxy @b1, defaultBundleData $ Proxy @b2]++instance {-# OVERLAPPING #-} (RequiredBundle b0, RequiredBundle b1, RequiredBundle b2, RequiredBundle b3) => RequiredBundle (b0, b1, b2, b3) where+  defaultBundleData _ = Set.unions [defaultBundleData $ Proxy @b0, defaultBundleData $ Proxy @b1, defaultBundleData $ Proxy @b2, defaultBundleData $ Proxy @b3]++instance {-# OVERLAPPING #-} (RequiredBundle b0, RequiredBundle b1, RequiredBundle b2, RequiredBundle b3, RequiredBundle b4) => RequiredBundle (b0, b1, b2, b3, b4) where+  defaultBundleData _ = Set.unions [defaultBundleData $ Proxy @b0, defaultBundleData $ Proxy @b1, defaultBundleData $ Proxy @b2, defaultBundleData $ Proxy @b3, defaultBundleData $ Proxy @b4]++instance {-# OVERLAPPING #-} (RequiredBundle b0, RequiredBundle b1, RequiredBundle b2, RequiredBundle b3, RequiredBundle b4, RequiredBundle b5) => RequiredBundle (b0, b1, b2, b3, b4, b5) where+  defaultBundleData _ = Set.unions [defaultBundleData $ Proxy @b0, defaultBundleData $ Proxy @b1, defaultBundleData $ Proxy @b2, defaultBundleData $ Proxy @b3, defaultBundleData $ Proxy @b4, defaultBundleData $ Proxy @b5]++instance {-# OVERLAPPING #-} (RequiredBundle b0, RequiredBundle b1, RequiredBundle b2, RequiredBundle b3, RequiredBundle b4, RequiredBundle b5, RequiredBundle b6) => RequiredBundle (b0, b1, b2, b3, b4, b5, b6) where+  defaultBundleData _ = Set.unions [defaultBundleData $ Proxy @b0, defaultBundleData $ Proxy @b1, defaultBundleData $ Proxy @b2, defaultBundleData $ Proxy @b3, defaultBundleData $ Proxy @b4, defaultBundleData $ Proxy @b5, defaultBundleData $ Proxy @b6]++instance {-# OVERLAPPING #-} (RequiredBundle b0, RequiredBundle b1, RequiredBundle b2, RequiredBundle b3, RequiredBundle b4, RequiredBundle b5, RequiredBundle b6, RequiredBundle b7) => RequiredBundle (b0, b1, b2, b3, b4, b5, b6, b7) where+  defaultBundleData _ = Set.unions [defaultBundleData $ Proxy @b0, defaultBundleData $ Proxy @b1, defaultBundleData $ Proxy @b2, defaultBundleData $ Proxy @b3, defaultBundleData $ Proxy @b4, defaultBundleData $ Proxy @b5, defaultBundleData $ Proxy @b6, defaultBundleData $ Proxy @b7]++instance {-# OVERLAPPING #-} (RequiredBundle b0, RequiredBundle b1, RequiredBundle b2, RequiredBundle b3, RequiredBundle b4, RequiredBundle b5, RequiredBundle b6, RequiredBundle b7, RequiredBundle b8) => RequiredBundle (b0, b1, b2, b3, b4, b5, b6, b7, b8) where+  defaultBundleData _ = Set.unions [defaultBundleData $ Proxy @b0, defaultBundleData $ Proxy @b1, defaultBundleData $ Proxy @b2, defaultBundleData $ Proxy @b3, defaultBundleData $ Proxy @b4, defaultBundleData $ Proxy @b5, defaultBundleData $ Proxy @b6, defaultBundleData $ Proxy @b7, defaultBundleData $ Proxy @b8]++instance {-# OVERLAPPING #-} (RequiredBundle b0, RequiredBundle b1, RequiredBundle b2, RequiredBundle b3, RequiredBundle b4, RequiredBundle b5, RequiredBundle b6, RequiredBundle b7, RequiredBundle b8, RequiredBundle b9) => RequiredBundle (b0, b1, b2, b3, b4, b5, b6, b7, b8, b9) where+  defaultBundleData _ = Set.unions [defaultBundleData $ Proxy @b0, defaultBundleData $ Proxy @b1, defaultBundleData $ Proxy @b2, defaultBundleData $ Proxy @b3, defaultBundleData $ Proxy @b4, defaultBundleData $ Proxy @b5, defaultBundleData $ Proxy @b6, defaultBundleData $ Proxy @b7, defaultBundleData $ Proxy @b8, defaultBundleData $ Proxy @b9]++instance {-# OVERLAPPING #-} (RequiredBundle b0, RequiredBundle b1, RequiredBundle b2, RequiredBundle b3, RequiredBundle b4, RequiredBundle b5, RequiredBundle b6, RequiredBundle b7, RequiredBundle b8, RequiredBundle b9, RequiredBundle b10) => RequiredBundle (b0, b1, b2, b3, b4, b5, b6, b7, b8, b9, b10) where+  defaultBundleData _ = Set.unions [defaultBundleData $ Proxy @b0, defaultBundleData $ Proxy @b1, defaultBundleData $ Proxy @b2, defaultBundleData $ Proxy @b3, defaultBundleData $ Proxy @b4, defaultBundleData $ Proxy @b5, defaultBundleData $ Proxy @b6, defaultBundleData $ Proxy @b7, defaultBundleData $ Proxy @b8, defaultBundleData $ Proxy @b9, defaultBundleData $ Proxy @b10]++instance {-# OVERLAPPING #-} (RequiredBundle b0, RequiredBundle b1, RequiredBundle b2, RequiredBundle b3, RequiredBundle b4, RequiredBundle b5, RequiredBundle b6, RequiredBundle b7, RequiredBundle b8, RequiredBundle b9, RequiredBundle b10, RequiredBundle b11) => RequiredBundle (b0, b1, b2, b3, b4, b5, b6, b7, b8, b9, b10, b11) where+  defaultBundleData _ = Set.unions [defaultBundleData $ Proxy @b0, defaultBundleData $ Proxy @b1, defaultBundleData $ Proxy @b2, defaultBundleData $ Proxy @b3, defaultBundleData $ Proxy @b4, defaultBundleData $ Proxy @b5, defaultBundleData $ Proxy @b6, defaultBundleData $ Proxy @b7, defaultBundleData $ Proxy @b8, defaultBundleData $ Proxy @b9, defaultBundleData $ Proxy @b10, defaultBundleData $ Proxy @b11]++instance {-# OVERLAPPING #-} (RequiredBundle b0, RequiredBundle b1, RequiredBundle b2, RequiredBundle b3, RequiredBundle b4, RequiredBundle b5, RequiredBundle b6, RequiredBundle b7, RequiredBundle b8, RequiredBundle b9, RequiredBundle b10, RequiredBundle b11, RequiredBundle b12) => RequiredBundle (b0, b1, b2, b3, b4, b5, b6, b7, b8, b9, b10, b11, b12) where+  defaultBundleData _ = Set.unions [defaultBundleData $ Proxy @b0, defaultBundleData $ Proxy @b1, defaultBundleData $ Proxy @b2, defaultBundleData $ Proxy @b3, defaultBundleData $ Proxy @b4, defaultBundleData $ Proxy @b5, defaultBundleData $ Proxy @b6, defaultBundleData $ Proxy @b7, defaultBundleData $ Proxy @b8, defaultBundleData $ Proxy @b9, defaultBundleData $ Proxy @b10, defaultBundleData $ Proxy @b11, defaultBundleData $ Proxy @b12]++instance {-# OVERLAPPING #-} (RequiredBundle b0, RequiredBundle b1, RequiredBundle b2, RequiredBundle b3, RequiredBundle b4, RequiredBundle b5, RequiredBundle b6, RequiredBundle b7, RequiredBundle b8, RequiredBundle b9, RequiredBundle b10, RequiredBundle b11, RequiredBundle b12, RequiredBundle b13) => RequiredBundle (b0, b1, b2, b3, b4, b5, b6, b7, b8, b9, b10, b11, b12, b13) where+  defaultBundleData _ = Set.unions [defaultBundleData $ Proxy @b0, defaultBundleData $ Proxy @b1, defaultBundleData $ Proxy @b2, defaultBundleData $ Proxy @b3, defaultBundleData $ Proxy @b4, defaultBundleData $ Proxy @b5, defaultBundleData $ Proxy @b6, defaultBundleData $ Proxy @b7, defaultBundleData $ Proxy @b8, defaultBundleData $ Proxy @b9, defaultBundleData $ Proxy @b10, defaultBundleData $ Proxy @b11, defaultBundleData $ Proxy @b12, defaultBundleData $ Proxy @b13]++instance {-# OVERLAPPING #-} (RequiredBundle b0, RequiredBundle b1, RequiredBundle b2, RequiredBundle b3, RequiredBundle b4, RequiredBundle b5, RequiredBundle b6, RequiredBundle b7, RequiredBundle b8, RequiredBundle b9, RequiredBundle b10, RequiredBundle b11, RequiredBundle b12, RequiredBundle b13, RequiredBundle b14) => RequiredBundle (b0, b1, b2, b3, b4, b5, b6, b7, b8, b9, b10, b11, b12, b13, b14) where+  defaultBundleData _ = Set.unions [defaultBundleData $ Proxy @b0, defaultBundleData $ Proxy @b1, defaultBundleData $ Proxy @b2, defaultBundleData $ Proxy @b3, defaultBundleData $ Proxy @b4, defaultBundleData $ Proxy @b5, defaultBundleData $ Proxy @b6, defaultBundleData $ Proxy @b7, defaultBundleData $ Proxy @b8, defaultBundleData $ Proxy @b9, defaultBundleData $ Proxy @b10, defaultBundleData $ Proxy @b11, defaultBundleData $ Proxy @b12, defaultBundleData $ Proxy @b13, defaultBundleData $ Proxy @b14]+ require :: forall b. (RequiredBundle b) => Set DefaultComponentType require = defaultBundleData (Proxy @b) @@ -32,13 +68,13 @@ requireAll = requireAll' $ required @c  requireAll' :: Set DefaultComponentType -> Set DefaultComponentType-requireAll' set =-  let nextSet = expandAll set+requireAll' !set =+  let !nextSet = expandAll set    in if null nextSet then set else requireAll' $ Set.union set nextSet  expandAll :: Set DefaultComponentType -> Set DefaultComponentType-expandAll set =-  let newSet = Set.unions $ map expandOne (Set.toList set)+expandAll !set =+  let !newSet = Set.unions $ map expandOne (Set.toList set)    in Set.difference newSet set  expandOne :: DefaultComponentType -> Set DefaultComponentType

@@ -1,25 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# OPTIONS_GHC -Wno-redundant-constraints #-}-{-# OPTIONS_GHC -Wno-unused-foralls #-}--module Mischief.ECS.Components.Runnable where--import Data.Data-import Data.Kind-import Mischief.ECS.Components-import Mischief.ECS.Components.Bundle-import Mischief.ECS.World--class Runnable c where-  runFor' :: Proxy c -> (forall d. (Component d, Bundle d) => Proxy d -> System ()) -> System ()--instance {-# OVERLAPPABLE #-} (Component c, Bundle c) => Runnable c where-  runFor' c s = s c--instance {-# OVERLAPPING #-} (Runnable r0, Runnable r1) => Runnable (r0, r1) where-  runFor' _ s = do-    runFor' (Proxy @r0) s-    runFor' (Proxy @r1) s--runFor :: forall c. (Runnable c) => (forall (d :: Type). (Component d, Bundle d) => Proxy d -> System ()) -> System ()-runFor = runFor' (Proxy @c)

@@ -4,7 +4,6 @@  import Control.Monad import Control.Monad.IO.Class-import Control.Monad.Reader import Data.Data import Data.Default import Data.Foldable@@ -15,45 +14,34 @@ -- import Mischief.ECS.Events  import Data.HashTable.IO qualified as H-import Data.IORef-import Data.Kind-import Data.Map qualified as Map-import Data.Maybe-import Data.Set qualified as Set import GHC.Base (Word (..)) import Mischief.ECS.Components-import Mischief.ECS.Components.Bundle import Mischief.ECS.Components.Common import Mischief.ECS.Components.HooksDef import Mischief.ECS.Components.Required (requireAll) import Mischief.ECS.Entities-import Mischief.ECS.EntityDef-import Mischief.ECS.Log-import Mischief.ECS.Observer-import Mischief.ECS.Relationships import Mischief.ECS.World-import Mischief.ECS.World.Prefs  -- import Mischief.ECS.World.Spawn  -- | Get the id of a component - entity pair. In case the component isn't registered, it will give it a new id. getOrAddPairId :: Pair -> System ComponentId-getOrAddPairId (Pair (t, entity)) = do-  (ComponentId (# id, _ #)) <- getOrAddComponentId t-  return $ ComponentId (# id, Just entity #)+getOrAddPairId (Pair (!t, !entity)) = do+  (ComponentId (# !id, _ #)) <- getOrAddComponentId t+  pure $ ComponentId (# id, Just entity #)  -- | Get the id of a component. In case the component isn't registered, it will give it a new id. getOrAddComponentId :: ComponentType -> System ComponentId getOrAddComponentId (ComponentType (_ :: Proxy c)) = do-  world <- unsafeGetWorld-  let comp = world.components-  w <- liftIO $ H.lookup comp.components (typeRep $ Proxy @c)+  !world <- unsafeGetWorld+  let !comp = world.components+  !w <- liftIO $ H.lookup comp.components (typeRep $ Proxy @c)    case w of-    Just (W# t) -> return $ ComponentId (# t, Nothing #)+    Just (W# !t) -> pure $ ComponentId (# t, Nothing #)     Nothing -> do-      result <- liftIO $ getNewEntityComp world.entities-      let !(Entity (# id, _ #)) = result+      !result <- liftIO $ getNewEntityComp world.entities+      let !(Entity (# !id, _ #)) = result        liftIO $ H.insert comp.components (typeRep $ Proxy @c) (W# id)       -- liftIO $ modifyIORef' comp.components $ Map.insert (typeRep $ Proxy @c) (W# id)@@ -61,54 +49,90 @@       -- l <- liftIO $ newIORef Set.empty       -- liftIO $ modifyIORef' comp.archetypes $ Map.insert result l -      forkPrefs (supressEvents True) $+      setPref @SupressEventsPref True $         worldSpawnByInsert           result           ( ( ComponentType $ Proxy @c,-              ( def @ComponentArchetypes,-                def @ComponentPairs-              )+              def @ComponentPairs             ),             Name $               "Meta entity for " ++ show (typeRep $ Proxy @c)           ) -      when (isExclusive @(RelExclusivity c)) $ do+      when (isExclusive @(IsExclusiveRel c)) $ do         worldSet IsExclusiveRelationship result        for_ (requireAll @c) $ \(DefaultComponentType (_ :: (Proxy other))) -> do-        (ComponentId (# otherId', _ #)) <- getOrAddComponentId (ComponentType $ Proxy @other)+        (ComponentId (# !otherId', _ #)) <- getOrAddComponentId (ComponentType $ Proxy @other) -        let otherId = Entity (# otherId', 0## #)+        let !otherId = Entity (# otherId', 0## #)         worldSet (Rel RequiredBy result) otherId         worldSet (Rel Requires otherId) result         worldSet (DefaultValue $ ErasedComponent $ def @other) otherId -      registerHooks $ hooks @c+      registerHooks @c result -      return $ ComponentId (# id, Nothing #)+      pure $ ComponentId (# id, Nothing #)  -- l <- liftIO $ newIORef Set.empty -- liftIO $ modifyIORef' archetypes $ Map.insert id l +-- | Return the meta entity corresponding to a given component. meta :: forall c. (Component c) => System Entity meta = do-  (ComponentId (# id, _ #)) <- getOrAddComponentId (ComponentType $ Proxy @c)-  return $ Entity (# id, 0## #)+  (ComponentId (# !id, _ #)) <- getOrAddComponentId (ComponentType $ Proxy @c)+  pure $ Entity (# id, 0## #)  tryMeta :: forall c m w. (Component c, MonadSystem w m) => m (Maybe Entity) tryMeta = do-  world <- unsafeGetWorld-  component <- liftIO $ getComponentId (typeRep $ Proxy @c) world.components-  return $ fmap (\(ComponentId (# id, _ #)) -> Entity (# id, 0## #)) component+  !world <- unsafeGetWorld+  !component <- liftIO $ getComponentId (typeRep $ Proxy @c) world.components+  pure $ fmap (\(ComponentId (# !id, _ #)) -> Entity (# id, 0## #)) component -registerHooks :: Hooks c -> System ()-registerHooks (Hooks h) = for_ h registerHook+registerHooks :: forall c. (Component c) => Entity -> System ()+registerHooks !entity = do+  let !a = map getHook (onAdd @c)+  let !s = map getHook (onSet @c)+  let !r = map getHook (onRemove @c)+  let !ar = map getHookRel (onAddRel @c)+  let !sr = map getHookRel (onSetRel @c)+  let !rr = map getHookRel (onRemoveRel @c) -registerHook :: ErasedHook c -> System ()-registerHook (ErasedHook (h :: e c -> m ())) = do-  world <- unsafeGetWorld-  e <- liftIO $ getNewEntity world.entities+  worldSet (ComponentAddHooks a) entity+  worldSet (ComponentSetHooks s) entity+  worldSet (ComponentRemoveHooks r) entity+  worldSet (ComponentAddHooksRel ar) entity+  worldSet (ComponentSetHooksRel sr) entity+  worldSet (ComponentRemoveHooksRel rr) entity++getHook :: Hook c -> (HookContext -> System ())+getHook (Hook (!h :: HookContext -> m ())) = do   case eqT @m @System of-    Just Refl -> void $ worldSpawnByInsert e $ Observer h     Nothing -> undefined+    Just Refl -> h++getHookRel :: HookRel c -> (HookContextRel -> System ())+getHookRel (HookRel (!h :: HookContextRel -> m ())) = do+  case eqT @m @System of+    Nothing -> undefined+    Just Refl -> h++-- registerHook :: ErasedHook c -> System ()+-- registerHook (ErasedHook (h :: e c -> m ())) = do+--   world <- unsafeGetWorld+--   e <- liftIO $ getNewEntity world.entities+--   case eqT @m @System of+--     Just Refl -> void $ worldSpawnByInsert e $ Observer h+--     Nothing -> undefined++newtype ComponentAddHooks = ComponentAddHooks [HookContext -> System ()] deriving anyclass (Component)++newtype ComponentSetHooks = ComponentSetHooks [HookContext -> System ()] deriving anyclass (Component)++newtype ComponentRemoveHooks = ComponentRemoveHooks [HookContext -> System ()] deriving anyclass (Component)++newtype ComponentAddHooksRel = ComponentAddHooksRel [HookContextRel -> System ()] deriving anyclass (Component)++newtype ComponentSetHooksRel = ComponentSetHooksRel [HookContextRel -> System ()] deriving anyclass (Component)++newtype ComponentRemoveHooksRel = ComponentRemoveHooksRel [HookContextRel -> System ()] deriving anyclass (Component)

@@ -21,12 +21,8 @@ import Control.Concurrent.STM.TVar import Control.Monad import Data.IORef-import Data.Map (Map)-import Data.Map qualified as Map-import Data.Maybe (isJust) import GHC.Base import GHC.Conc-import Mischief.ECS.Components import Mischief.ECS.EntityDef import Mischief.ECS.Vec (IOVec) import Mischief.ECS.Vec qualified as Vec@@ -44,7 +40,7 @@ -- | A storage for entity ids and pointers. data Entities = Entities   { -- | Associates each @Entity@ to an @EntityPointer@.-    pointers :: IOVec (IORef EntityPointer),+    pointers :: IOVec (Word, IORef EntityPointer),     nullPtr :: IORef EntityPointer,     -- | A counter for assigning new entity ids. It is in a TVar so     -- it can be used in parallel systems.@@ -56,81 +52,89 @@  -- | Associate an Entity with a new pointer. insertPointer :: Entity -> IORef EntityPointer -> Entities -> IO ()-insertPointer (Entity (# i, _ #)) pointer entities = do-  Vec.write entities.pointers (I# $ word2Int# i) pointer+insertPointer (Entity (# !i, g #)) pointer entities = do+  let !i' = I# $ word2Int# i+  fillVec entities i'+  Vec.write entities.pointers i' (W# g, pointer)  -- | Get the pointer to an entity. getPointer :: Entity -> Entities -> IO (Maybe (IORef EntityPointer))-getPointer (Entity (# i', _ #)) entities = do-  let i = I# (word2Int# i')-  l <- Vec.length entities.pointers+getPointer (Entity (# !i', g #)) entities = do+  let !i = I# (word2Int# i')+  !l <- Vec.length entities.pointers    if i < l     then do-      p <- Vec.unsafeRead entities.pointers i-      pure $ if p /= entities.nullPtr then Just p else Nothing+      (!g', !p) <- Vec.unsafeRead entities.pointers i+      pure $ if p /= entities.nullPtr && g' == W# g then Just p else Nothing     else       pure Nothing  -- | Create a new entity. getNewEntity :: Entities -> IO Entity-getNewEntity entities = do-  (e, reused) <- atomically $ do+getNewEntity !entities = do+  (!e, _) <- atomically $ do     EntityCounter {counter, free} <- readTVar entities.counter     case free of       [] -> do         writeTVar entities.counter EntityCounter {counter = plusWord# counter 1##, free}         pure (Entity (# counter, 1## #), False)-      (Entity (# id, gen #) : xs) -> do+      (Entity (# !id, !gen #) : xs) -> do         writeTVar entities.counter EntityCounter {counter = counter, free = xs}         pure (Entity (# id, plusWord# gen 1## #), True) -  unless reused $ do-    Vec.pushBack entities.pointers entities.nullPtr+  -- unless reused $ do+  --   Vec.pushBack entities.pointers entities.nullPtr    pure e  -- | Creates a new entity using a fresh id, never incrementing the generation of a previous one. getNewEntityComp :: Entities -> IO Entity-getNewEntityComp entities = do-  Vec.pushBack entities.pointers entities.nullPtr+getNewEntityComp !entities = do+  -- Vec.pushBack entities.pointers entities.nullPtr   atomically $ do-    EntityCounter {counter, free} <- readTVar entities.counter-    let e = Entity (# counter, 0## #)+    EntityCounter {counter = !counter, free = !free} <- readTVar entities.counter+    let !e = Entity (# counter, 0## #)     writeTVar entities.counter EntityCounter {counter = plusWord# counter 1##, free}     pure e  -- | Remove an entity from storage. removeEntity :: Entity -> Entities -> IO ()-removeEntity (Entity (# i', g #)) entities = do-  let i = I# (word2Int# i')-  l <- Vec.length entities.pointers+removeEntity (Entity (# !i', !g #)) entities = do+  let !i = I# (word2Int# i')+  !l <- Vec.length entities.pointers    when (i < l) $ do-    Vec.unsafeWrite entities.pointers i entities.nullPtr+    Vec.unsafeWrite entities.pointers i (0, entities.nullPtr)      atomically $ do-      EntityCounter {counter, free} <- readTVar entities.counter+      EntityCounter {counter = !counter, free = !free} <- readTVar entities.counter       writeTVar entities.counter EntityCounter {counter, free = Entity (# i', g #) : free} +fillVec :: Entities -> Int -> IO ()+fillVec !entities !n = do+  !l <- Vec.length entities.pointers+  when (n >= l) $ do+    replicateM_ (n - l + 1) $ Vec.pushBack entities.pointers (0, entities.nullPtr)+ -- | Create a new storage for entities. emptyEntities :: IO Entities emptyEntities = do-  map <- Vec.new 256-  counter <- newTVarIO EntityCounter {counter = 1##, free = []}-  nullPtr <- newIORef $ EntityPointer (# 0#, 0# #)+  !map <- Vec.new 256+  !counter <- newTVarIO EntityCounter {counter = 1##, free = []}+  !nullPtr <- newIORef $ EntityPointer (# 0#, 0# #) -  Vec.pushBack map nullPtr-  return $ Entities map nullPtr counter+  Vec.pushBack map (0, nullPtr)+  pure $ Entities map nullPtr counter  -- | Check if an Entity is alive through IO. isAliveIO :: Entity -> Entities -> IO Bool-isAliveIO (Entity (# i', _ #)) entities = do-  let i = I# (word2Int# i')-  l <- Vec.length entities.pointers+isAliveIO (Entity (# !i', g #)) !entities = do+  let !i = I# (word2Int# i')+  !l <- Vec.length entities.pointers    if i < l     then do-      p <- Vec.unsafeRead entities.pointers i-      pure $ p /= entities.nullPtr+      (!g', !p) <- Vec.unsafeRead entities.pointers i+      pure $ p /= entities.nullPtr && g' == W# g     else pure False

@@ -12,33 +12,36 @@  instance Show Entity where   show :: Entity -> String-  show (Entity (# id, 0## #)) = show (W# id) ++ "v" ++ "."-  show (Entity (# id, gen #)) = show (W# id) ++ "v" ++ show (W# gen)+  show (Entity (# !id, 0## #)) = show (W# id) ++ "v" ++ "."+  show (Entity (# !id, !gen #)) = show (W# id) ++ "v" ++ show (W# gen)  instance Eq Entity where   (==) :: Entity -> Entity -> Bool-  (==) (Entity (# id1, gen1 #)) (Entity (# id2, gen2 #)) = isTrue# (eqWord# id1 id2) && isTrue# (eqWord# gen1 gen2)+  (==) (Entity (# !id1, !gen1 #)) (Entity (# !id2, !gen2 #)) = isTrue# (eqWord# id1 id2) && isTrue# (eqWord# gen1 gen2)  instance Ord Entity where   compare :: Entity -> Entity -> Ordering-  compare (Entity (# id1, gen1 #)) (Entity (# id2, gen2 #)) =+  compare (Entity (# !id1, !gen1 #)) (Entity (# !id2, !gen2 #)) =     case compareWord# id1 id2 of       EQ -> compareWord# gen1 gen2-      x -> x+      !x -> x  newtype Entity# = Entity# (# Word#, Word# #)  liftEntity :: Entity# -> Entity-liftEntity (Entity# a) = Entity a+liftEntity (Entity# !a) = Entity a  unliftEntity :: Entity -> Entity#-unliftEntity (Entity a) = Entity# a+unliftEntity (Entity !a) = Entity# a  eqEntity# :: Entity# -> Entity# -> Bool-eqEntity# (Entity# (# id1, gen1 #)) (Entity# (# id2, gen2 #)) = isTrue# (eqWord# id1 id2) && isTrue# (eqWord# gen1 gen2)+eqEntity# (Entity# (# !id1, !gen1 #)) (Entity# (# !id2, !gen2 #)) = isTrue# (eqWord# id1 id2) && isTrue# (eqWord# gen1 gen2)  compareEntity# :: Entity# -> Entity# -> Ordering-compareEntity# (Entity# (# id1, gen1 #)) (Entity# (# id2, gen2 #)) =+compareEntity# (Entity# (# !id1, !gen1 #)) (Entity# (# !id2, !gen2 #)) =   case compareWord# id1 id2 of     EQ -> compareWord# gen1 gen2-    x -> x+    !x -> x++nullEntity :: Entity+nullEntity = Entity (# 0##, 0## #)

@@ -1,51 +1,33 @@ module Mischief.ECS.Events where -import Control.Monad.IO.Class-import Control.Monad.Reader (MonadReader (..))-import Data.Data (Typeable)-import Data.Default (Default) import Data.Foldable (for_)-import Data.IORef (modifyIORef', readIORef, writeIORef)-import Data.List-import GHC.Generics (Generic)-import GHC.Records-import Mischief.ECS.Components-import Mischief.ECS.Components.Bundle-import Mischief.ECS.Components.Required (require) import Mischief.ECS.Entities import Mischief.ECS.EventDef import Mischief.ECS.Observer-import Mischief.ECS.Tables import Mischief.ECS.World import Mischief.ECS.World.Query import Mischief.ECS.World.Query.Markers-import Mischief.ECS.World.Query.Queryable -trigger :: (Event e) => e -> System ()-trigger event = do-  world <- unsafeGetWorld-  liftIO $ modifyIORef' world.events (++ [eraseEvent event])+trigger :: forall e. (Event e) => e -> System ()+trigger !event = do+  !observers <- query $ mkQuery (C @(Observer e), C @(EventProxy e))+  for_ observers $ \(!observer, _) -> do+    let Observer !f = observer+    f event -flushEvents :: System ()-flushEvents = do-  world <- unsafeGetWorld-  events <- liftIO $ readIORef world.events-  for_ events runEvent-  liftIO $ writeIORef world.events []+newtype OnSet c = OnSet {entity :: Entity}+  deriving anyclass (Event)+  deriving stock (Show) -runEvent :: ErasedEvent -> System ()-runEvent (ErasedEvent (event :: e)) = do-  observers' <- query (C @(Observer e), C @(EventProxy e), C @ObserverOrder)-  let observers = sortBy (\(_, _, a) (_, _, b) -> compare a b) observers'-  for_ observers $ \(observer, _, _) -> do-    let Observer f = value observer-    f event+data OnSetRel c = OnSetRel {entity :: Entity, target :: Entity}+  deriving anyclass (Event)+  deriving stock (Show) -newtype OnInsert c = OnInsert {entity :: Entity}+newtype OnAdd c = OnAdd {entity :: Entity}   deriving anyclass (Event)   deriving stock (Show) -data OnInsertRel c = OnInsertRel {entity :: Entity, target :: Entity}+data OnAddRel c = OnAddRel {entity :: Entity, target :: Entity}   deriving anyclass (Event)   deriving stock (Show) 

@@ -0,0 +1,12 @@+{-# OPTIONS_GHC -Wno-dodgy-exports #-}++module Mischief.ECS.Exports+  ( module Data.String.Interpolate,+    module Data.Default,+    module GHC.Generics,+  )+where++import Data.Default (Default (..))+import Data.String.Interpolate (i)+import GHC.Generics (Generic)

@@ -0,0 +1,108 @@+module Mischief.ECS.Fixed where++import Control.Monad+import Data.Data+import Data.Default+import Data.Foldable+import Data.Function+import Data.Maybe+import Mischief.ECS.App+import Mischief.ECS.App.Plugins+import Mischief.ECS.App.Schedules+import Mischief.ECS.Components+import Mischief.ECS.Relationships.Order (Before (..), orderEntities)+import Mischief.ECS.Resources+import Mischief.ECS.Systems+import Mischief.ECS.Time (Time (Time), TimePlugin, TimeTag (..), TimeTypePref, ToTime)+import Mischief.ECS.Time qualified as Time+import Mischief.ECS.World+import Mischief.ECS.World.Insert+import Mischief.ECS.World.Query+import Mischief.ECS.World.Query.Markers+import Mischief.ECS.World.Query.QueryFilter+import System.Clock (TimeSpec)++-- | Resource determining the frequency at which Fixed schedules are ran. Defaults to @0.03@ (30fps).+newtype FixedFrequency = FixedFrequency Float deriving anyclass (Component)++instance Default FixedFrequency where+  def = FixedFrequency 0.033333333++data FixedFirst deriving (Schedule, Show)++data FixedPreUpdate deriving (Schedule, Show)++data FixedUpdate deriving (Schedule, Show)++data FixedPostUpdate deriving (Schedule, Show)++data FixedLast deriving (Schedule, Show)++-- | Plugin that enables running systems in Fixed schedules such as 'FixedUpdate' and 'FixedPostUpdate'.+--+-- Overwrite the 'FixedFrequency' resource to change the frequency at which Fixed schedules are ran.+data FixedPlugin++instance Plugin FixedPlugin where+  init = do+    first <- scheduleEntity @FixedFirst+    pre <- scheduleEntity @FixedPreUpdate+    update <- scheduleEntity @FixedUpdate+    post <- scheduleEntity @FixedPostUpdate+    last <- scheduleEntity @FixedLast++    for_ [first, pre, update, post, last] $ insert FixedSchedule++    insert (Rel Before pre) first+    insert (Rel Before update) pre+    insert (Rel Before post) update+    insert (Rel Before last) post++    insertRes $ def @FixedFrequency+    insertRes $ FixedTime 0 0++    fixed <- scheduleEntity @Fixed+    last' <- scheduleEntity @Last+    post' <- scheduleEntity @PostUpdate++    insert UpdateSchedule fixed+    insert (Rel Before last') fixed+    insert (Rel Before fixed) post'++    systems runFixedLoop+      & schedule @Fixed++  deps = [dep @TimePlugin]++data Fixed deriving (Schedule)++data FixedTime = FixedTime+  { fixedElapsed :: TimeSpec,+    fixedDelta :: TimeSpec+  }+  deriving (Component)++instance ToTime FixedTime where+  toTime FixedTime {fixedElapsed, fixedDelta} = Time {elapsed = fixedElapsed, delta = fixedDelta}++newtype FixedExtra = FixedExtra Float deriving anyclass (Component)++runFixedLoop :: System ()+runFixedLoop = do+  FixedExtra extra <- fromMaybe (FixedExtra 0) <$> (res @FixedExtra)+  delta <- Time.delta+  Just (FixedFrequency freq) <- res @FixedFrequency++  let extra' = extra + delta+  let runs :: Int = floor $ extra' / freq++  schedules <- orderEntities =<< query (mkQuery' E (With (C @FixedSchedule)))++  setPref @TimeTypePref (TimeTag $ Proxy @FixedTime) $ do+    modifyRes' (\FixedTime {fixedElapsed} -> FixedTime {fixedElapsed, fixedDelta = Time.secsToSpec freq})++    replicateM_ runs $ do+      for_ schedules runSchedule'+      modifyRes' (\FixedTime {fixedElapsed, fixedDelta} -> FixedTime {fixedElapsed = fixedElapsed + fixedDelta, fixedDelta})++  insertRes $ FixedExtra $ extra' - (fromIntegral runs * freq)

@@ -0,0 +1,11 @@+module Mischief.ECS.Foreign where++import Control.Monad.IO.Class+import Foreign (Ptr, Storable)+import Foreign.Marshal.Alloc as A+import Mischief.ECS.World++alloca :: (Storable a) => (Ptr a -> System b) -> System b+alloca s = do+  x <- sysUnliftIO+  liftIO $ A.alloca $ x . s

@@ -1,92 +0,0 @@-{- HLINT ignore "Use second" -}-module Mischief.ECS.Graph where--import Control.Monad-import Data.Foldable-import Data.IORef-import Data.List qualified as List-import Data.Map (Map)-import Data.Map qualified as Map-import Data.Maybe-import Data.Set (Set)-import Data.Set qualified as Set-import Mischief.ECS.Vec (IOVec)-import Mischief.ECS.Vec qualified as Vec--data Graph a = Graph {nodes :: IORef (Map a Int), counter :: IORef Int, edges :: IOVec (Maybe a, Set Int)}--newGraph :: forall a. IO (Graph a)-newGraph = do-  nodes <- newIORef Map.empty-  counter <- newIORef 0-  edges <- Vec.new 16--  return Graph {nodes, counter, edges}--addNode :: (Ord a) => a -> Graph a -> IO Int-addNode node Graph {nodes, counter, edges} = do-  maybeNode <- tryGetNode node Graph {nodes, counter, edges}-  case maybeNode of-    Just x -> do-      setNode node x Graph {nodes, counter, edges}-      return x-    Nothing -> do-      index <- readIORef counter-      modifyIORef' counter (+ 1)-      Vec.pushBack edges (Just node, Set.empty)-      modifyIORef' nodes (Map.insert node index)-      return index--setNode :: a -> Int -> Graph a -> IO ()-setNode node index Graph {edges} = do-  Vec.modify_ edges index (\(_, x) -> (Just node, x))--tryGetNode :: (Ord a) => a -> Graph a -> IO (Maybe Int)-tryGetNode node graph = do-  nodes <- readIORef graph.nodes-  return $ Map.lookup node nodes---- data GetOrAddResult = AddedNode Int | GotNode Int--getOrAddNode :: (Ord a) => a -> Graph a -> IO Int-getOrAddNode node graph = do-  nodes' <- readIORef graph.nodes-  case Map.lookup node nodes' of-    Just x -> return x-    Nothing -> do-      index <- readIORef graph.counter-      modifyIORef' graph.counter (+ 1)-      Vec.pushBack graph.edges (Nothing, Set.empty)-      modifyIORef' graph.nodes (Map.insert node index)-      return index--addEdge :: (Ord a) => (a, a) -> Graph a -> IO ()-addEdge (a, b) graph = do-  a' <- getOrAddNode a graph-  b' <- getOrAddNode b graph-  Vec.modify_ graph.edges b' (\(x, l) -> (x, Set.insert a' l))--takeRemoveableNodes :: IOVec (Maybe a, Set Int) -> IO [a]-takeRemoveableNodes edges = do-  edgeList <- Vec.toList edges-  len <- Vec.length edges-  let nodes = concatMap unwrap (filter (\((a, x), _) -> null x && isJust a) (zip edgeList [0 :: Int ..]))-  for_ nodes $ \(_, i) -> Vec.modify_ edges i (\(_, l) -> (Nothing, l))-  for_ nodes $ \(_, i) -> for_ [0 .. len - 1] $ \j -> Vec.modify_ edges j (\(a, l) -> (a, Set.delete i l))-  return (map fst nodes)-  where-    unwrap ((Just a, _), i) = [(a, i)]-    unwrap _ = []--getNodes :: Graph a -> IO [[a]]-getNodes Graph {edges} = do-  edges' <- Vec.clone edges-  res <- newIORef []-  step res edges'-  readIORef res-  where-    step res edges' = do-      nodes <- takeRemoveableNodes edges'-      unless (null nodes) $ do-        modifyIORef' res (++ [nodes])-        step res edges'

@@ -12,4 +12,4 @@ hide = Hidden  unhide :: Hidden a -> a-unhide (Hidden a) = a+unhide (Hidden !a) = a

@@ -1,93 +1,10 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# OPTIONS_GHC -Wno-orphans #-}---- {-# OPTIONS_GHC -Wno-redundant-constraints #-}--module Mischief.ECS.Hooks-  ( relComplementary,-    relCleanup,-    relCleanupRemove,-    relCleanupDespawn,-  )-where+module Mischief.ECS.Hooks (hook, hookRel) where -import Control.Monad-import Data.Data-import Data.Foldable-import Data.Kind-import Data.Maybe-import Mischief.ECS.Collectable-import Mischief.ECS.Components-import Mischief.ECS.Components.Bundle-import Mischief.ECS.Components.Common import Mischief.ECS.Components.HooksDef-import Mischief.ECS.Entities-import Mischief.ECS.EventDef-import Mischief.ECS.Events-import Mischief.ECS.Log-import Mischief.ECS.Tables-import Mischief.ECS.Utils import Mischief.ECS.World-import Mischief.ECS.World.Insert-import Mischief.ECS.World.Query-import Mischief.ECS.World.Query.Markers-import Mischief.ECS.World.Query.Queryable-import Mischief.ECS.World.Remove-import Mischief.ECS.World.Spawn-import Mischief.ECS.World.Utils -instance (Event (e c)) => EraseIntoStorage (e c -> System ()) (Hooks c) where-  erase :: (e c -> System ()) -> Hooks c-  erase x = Hooks [ErasedHook x]--instance EraseIntoStorage (Hooks c) (Hooks c) where-  erase = id---- | When applied on a component @A@, this hook takes a function @(A -> B)@ and does two things:------ 1. When @'Rel' (A, y)@ is inserted on entity @x@, @'Rel' (B, x)@ will be inserted on @y@ (the value of @B@ obtained through the provided function).------ 2. When @'Rel' (a, y)@ is removed from an entity @x@, @'Rel' (B, x)@ will be removed from @y@.-relComplementary :: forall (a :: Type) b. (Component a, Component b) => (a -> b) -> Hooks a-relComplementary f = collect (insertComplementary f, removeComplementary @b @a)--insertComplementary :: forall (a :: Type) b. (Component b, Component a) => (a -> b) -> OnInsertRel a -> System ()-insertComplementary f event = do-  -- warn $ text event.target-  Just val <- get (R @a event.target) event.entity-  insert (Rel (f val.comp) event.entity) event.target--removeComplementary :: forall b a. (Component b) => OnRemoveRel a -> System ()-removeComplementary event = removeRel @b event.entity event.target--relCleanup :: forall (a :: Type). (Component a) => (CleanupRequest -> System ()) -> Hooks a-relCleanup f = collect (insertCleanupWatcher @a f, removeCleanupWatcher @a)--relCleanupRemove :: forall (a :: Type). (Component a) => Hooks a-relCleanupRemove = relCleanup (\r -> removeRel @a r.target r.entity)--relCleanupDespawn :: forall (a :: Type). (Component a) => Hooks a-relCleanupDespawn = relCleanup (\r -> despawn r.entity)--insertCleanupWatcher :: forall c. (Component c) => (CleanupRequest -> System ()) -> OnInsertRel c -> System ()-insertCleanupWatcher f e = insert (Rel (CleanupWatcher @c f) e.entity) e.target--removeCleanupWatcher :: forall c. (Component c) => OnRemoveRel c -> System ()-removeCleanupWatcher e = do-  insert (Rel (CleanupWatcher @c (pure . pure ())) e.entity) e.target-  removeRel @(CleanupWatcher c) e.entity e.target--newtype CleanupWatcher c = CleanupWatcher {function :: CleanupRequest -> System ()}--data CleanupRequest = CleanupRequest-  { entity :: Entity,-    target :: Entity-  }--instance (Component c) => Component (CleanupWatcher c) where-  hooks = collect $ triggerCleanup @c+hook :: (HookContext -> System ()) -> Hook a+hook = Hook -triggerCleanup :: forall c. (Component c) => OnRemoveRel (CleanupWatcher c) -> System ()-triggerCleanup e = do-  Just watcher <- get (R @(CleanupWatcher c) e.target) e.entity-  watcher.comp.function CleanupRequest {entity = e.target, target = e.entity}+hookRel :: (HookContextRel -> System ()) -> HookRel a+hookRel = HookRel

@@ -0,0 +1,115 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++module Mischief.ECS.HooksRel+  ( addOther,+    removeOther,+    addDespawnCleaner,+    addRemoveCleaner,+    addCleaner,+    removeCleaner,+  )+where++import Data.Kind+import Mischief.ECS.Components+import Mischief.ECS.Components.HooksDef+import Mischief.ECS.EntityDef+import Mischief.ECS.Hooks+import Mischief.ECS.World+import Mischief.ECS.World.Insert+import Mischief.ECS.World.Query+import Mischief.ECS.World.Query.Markers+import Mischief.ECS.World.Remove+import Mischief.ECS.World.Spawn++-- | Relationship Hook for @Component a@.+--+-- Takes a @a -> b@. If @a@ is a relationship from @x@ to @y@, this hook will add the corresponding @b@ from @y@ to @x@.+--+-- Example usage:+--+-- @+-- data After = After+-- data Before = Before+--+-- instance 'Component' Before where+--   onAddRel = [addOther ('const' After)]+--+-- instance 'Component' After where+--   onAddRel = [addOther ('const' Before)]+-- @+addOther :: forall (a :: Type) b. (Component a, Component b) => (a -> b) -> HookRel a+addOther f = hookRel $ insertComplementary f++-- | Relationship Hook for @Component a@.+--+-- Removes @b@ from the target entity of a relationship.+--+-- Example usage:+--+-- @+-- data Likes = Likes+-- data LikedBy = LikedBy deriving (Component)+--+-- instance 'Component' Likes where+--   onAddRel = [addOther ('const' Likes)]+--   onRemoveRel = [removeOther \@Likes]+-- @`+removeOther :: forall a b. (Component b) => HookRel a+removeOther = hookRel $ removeComplementary @b++insertComplementary :: forall (a :: Type) b. (Component b, Component a) => (a -> b) -> HookContextRel -> System ()+insertComplementary f event = do+  Just val <- single $ mkGet event.entity (R @a event.target)+  insert (Rel (f val.comp) event.entity) event.target++removeComplementary :: forall b. (Component b) => HookContextRel -> System ()+removeComplementary event = remove (R @b event.entity) event.target++addCleaner :: forall (a :: Type). (Component a) => (CleanupRequest -> System ()) -> HookRel a+addCleaner f = hookRel $ insertCleanupWatcher @a f++-- | Relationship Hook for @Component a@.+--+-- Adds a cleaner that will remove this relationship if the target is despawned.+--+-- Note that one component can have only one cleaner at a time.+addRemoveCleaner :: forall (a :: Type). (Component a) => HookRel a+addRemoveCleaner = addCleaner @a (\r -> removeRel @a r.target r.entity)++-- | Relationship Hook for @Component a@.+--+-- Adds a cleaner that will despawn this relationship's entity if the target of the relationship is despawned.+--+-- Note that one component can have only one cleaner at a time.+addDespawnCleaner :: forall (a :: Type). (Component a) => HookRel a+addDespawnCleaner = addCleaner @a (\r -> despawn r.entity)++insertCleanupWatcher :: forall c. (Component c) => (CleanupRequest -> System ()) -> HookContextRel -> System ()+insertCleanupWatcher f e = insert (Rel (CleanupWatcher @c f) e.entity) e.target++-- | Relationship Hook for @Component a@.+--+-- Removes the cleaner associated to this component, if any.+removeCleaner :: forall (a :: Type). (Component a) => HookRel a+removeCleaner = hookRel (removeCleanupWatcher @a)++removeCleanupWatcher :: forall c. (Component c) => HookContextRel -> System ()+removeCleanupWatcher e = do+  insert (Rel (CleanupWatcher @c (pure . pure ())) e.entity) e.target+  removeRel @(CleanupWatcher c) e.entity e.target++newtype CleanupWatcher c = CleanupWatcher {function :: CleanupRequest -> System ()}++data CleanupRequest = CleanupRequest+  { entity :: Entity,+    target :: Entity+  }++instance (Component c) => Component (CleanupWatcher c) where+  onRemoveRel = [hookRel (triggerCleanup @c)]++triggerCleanup :: forall c. (Component c) => HookContextRel -> System ()+triggerCleanup e = do+  Just watcher <- single $ mkGet e.entity (R @(CleanupWatcher c) e.target)+  watcher.comp.function CleanupRequest {entity = e.target, target = e.entity}

@@ -1,30 +0,0 @@-module Mischief.ECS.Interval (start, stop, Interval) where--import Control.Concurrent (threadDelay)-import Control.Concurrent.Async (async)-import Control.Concurrent.STM-import Control.Monad-import Control.Monad.IO.Class-import Data.IORef-import Mischief.ECS.World--newtype Interval = Interval (IORef Bool)--start :: (MonadSystem w m) => Int -> System () -> m Interval-start t s = do-  world <- unsafeGetWorld-  i <- Interval <$> liftIO (newIORef False)-  _ <- liftIO $ async $ run world i t s-  return i--run :: World -> Interval -> Int -> System () -> IO ()-run world (Interval break) t s = do-  b <- liftIO $ readIORef break-  unless b $ do-    liftIO $ threadDelay t--    liftIO $ atomically $ modifyTVar' world.deferredAsync (++ [s])-    run world (Interval break) t s--stop :: (MonadSystem w m) => Interval -> m ()-stop (Interval break) = liftIO $ writeIORef break True

@@ -3,34 +3,25 @@ import Colog qualified import Control.Monad.IO.Class import Data.Text (Text)-import Data.Text qualified as Text import GHC.Stack import Mischief.ECS.World  debug :: (HasCallStack) => (MonadSystem w m) => Text -> m ()-debug msg = withFrozenCallStack $ do-  world <- unsafeGetWorld+debug !msg = withFrozenCallStack $ do+  !world <- unsafeGetWorld   liftIO $ Colog.usingLoggerT world.logger $ Colog.logDebug msg  info :: (HasCallStack) => (MonadSystem w m) => Text -> m ()-info msg = withFrozenCallStack $ do-  world <- unsafeGetWorld+info !msg = withFrozenCallStack $ do+  !world <- unsafeGetWorld   liftIO $ Colog.usingLoggerT world.logger $ Colog.logInfo msg  warn :: (HasCallStack) => (MonadSystem w m) => Text -> m ()-warn msg = withFrozenCallStack $ do-  world <- unsafeGetWorld+warn !msg = withFrozenCallStack $ do+  !world <- unsafeGetWorld   liftIO $ Colog.usingLoggerT world.logger $ Colog.logWarning msg  err :: (HasCallStack) => (MonadSystem w m) => Text -> m ()-err msg = withFrozenCallStack $ do-  world <- unsafeGetWorld-  liftIO $ Colog.usingLoggerT world.logger $ Colog.logError msg--panic :: (HasCallStack) => (MonadSystem w m) => Text -> m ()-panic msg = withFrozenCallStack $ do-  err msg-  undefined--text :: (Show a) => a -> Text-text = Text.pack . show+err !msg = withFrozenCallStack $ do+  !world <- unsafeGetWorld+  liftIO $ Colog.usingLoggerT world.loggerErr $ Colog.logError msg

@@ -1,106 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}--module Mischief.ECS.Mappable where--import Mischief.ECS.Components-import Mischief.ECS.Entities-import Mischief.ECS.Tables--class Mappable flag a b | flag a -> b where-  mapTuple :: a -> b--class TryMapId flag flag' c out | flag flag' c -> out where-  tryMapId :: c -> out--data RelQueryOutput out = RelQueryOutput out | InvalidRelQueryOutput--type family MapIsId c where-  MapIsId (Maybe a) = False-  MapIsId (Result a) = False-  MapIsId (RelQueryOutput a) = False-  MapIsId [a] = False-  MapIsId a = True--data MapQueryVal--instance TryMapId True MapQueryVal a a where-  tryMapId = id--instance TryMapId False MapQueryVal (Result a) a where-  tryMapId = value--instance (TryMapId (MapIsId a) MapQueryVal a out) => TryMapId False MapQueryVal (Maybe a) (Maybe out) where-  tryMapId = fmap (tryMapId @(MapIsId a) @MapQueryVal)--instance (TryMapId (MapIsId a) MapQueryVal a out) => TryMapId False MapQueryVal [a] [out] where-  tryMapId = map (tryMapId @(MapIsId a) @MapQueryVal)--instance (TryMapId (MapIsId a) MapQueryVal a out) => TryMapId False MapQueryVal (RelQueryOutput a) (RelQueryOutput out) where-  tryMapId (RelQueryOutput a) = RelQueryOutput $ tryMapId @(MapIsId a) @MapQueryVal a-  tryMapId InvalidRelQueryOutput = InvalidRelQueryOutput--instance {-# OVERLAPPABLE #-} (TryMapId (MapIsId a) flag a out) => Mappable flag a out where-  mapTuple = tryMapId @(MapIsId a) @flag--data MapQueryValidity--instance TryMapId True MapQueryValidity a a where-  tryMapId = id--instance TryMapId False MapQueryValidity (Result a) (Result a) where-  tryMapId = id--instance (TryMapId (MapIsId a) MapQueryValidity a out) => TryMapId False MapQueryValidity (RelQueryOutput a) a where-  tryMapId (RelQueryOutput a) = a-  tryMapId InvalidRelQueryOutput = undefined--instance (TryMapId (MapIsId a) MapQueryValidity a out) => TryMapId False MapQueryValidity (Maybe a) (Maybe out) where-  tryMapId = fmap (tryMapId @(MapIsId a) @MapQueryValidity)--instance (TryMapId (MapIsId a) MapQueryValidity a out) => TryMapId False MapQueryValidity [a] [out] where-  tryMapId = map (tryMapId @(MapIsId a) @MapQueryValidity)---- instance {-# OVERLAPPABLE #-} (TryMapId (MapIsId a) MapQueryValidity a out) => Mappable flag a out where---   mapTuple = tryMapId @(MapIsId a) @MapQueryValidity--instance {-# OVERLAPPING #-} (Mappable flag a0 b0, Mappable flag a1 b1) => Mappable flag (a0, a1) (b0, b1) where-  mapTuple (a0, a1) = (mapTuple @flag a0, mapTuple @flag a1)--instance {-# OVERLAPPING #-} (Mappable flag a0 b0, Mappable flag a1 b1, Mappable flag a2 b2) => Mappable flag (a0, a1, a2) (b0, b1, b2) where-  mapTuple (a0, a1, a2) = (mapTuple @flag a0, mapTuple @flag a1, mapTuple @flag a2)--instance {-# OVERLAPPING #-} (Mappable flag a0 b0, Mappable flag a1 b1, Mappable flag a2 b2, Mappable flag a3 b3) => Mappable flag (a0, a1, a2, a3) (b0, b1, b2, b3) where-  mapTuple (a0, a1, a2, a3) = (mapTuple @flag a0, mapTuple @flag a1, mapTuple @flag a2, mapTuple @flag a3)--instance {-# OVERLAPPING #-} (Mappable flag a0 b0, Mappable flag a1 b1, Mappable flag a2 b2, Mappable flag a3 b3, Mappable flag a4 b4) => Mappable flag (a0, a1, a2, a3, a4) (b0, b1, b2, b3, b4) where-  mapTuple (a0, a1, a2, a3, a4) = (mapTuple @flag a0, mapTuple @flag a1, mapTuple @flag a2, mapTuple @flag a3, mapTuple @flag a4)--instance {-# OVERLAPPING #-} (Mappable flag a0 b0, Mappable flag a1 b1, Mappable flag a2 b2, Mappable flag a3 b3, Mappable flag a4 b4, Mappable flag a5 b5) => Mappable flag (a0, a1, a2, a3, a4, a5) (b0, b1, b2, b3, b4, b5) where-  mapTuple (a0, a1, a2, a3, a4, a5) = (mapTuple @flag a0, mapTuple @flag a1, mapTuple @flag a2, mapTuple @flag a3, mapTuple @flag a4, mapTuple @flag a5)--instance {-# OVERLAPPING #-} (Mappable flag a0 b0, Mappable flag a1 b1, Mappable flag a2 b2, Mappable flag a3 b3, Mappable flag a4 b4, Mappable flag a5 b5, Mappable flag a6 b6) => Mappable flag (a0, a1, a2, a3, a4, a5, a6) (b0, b1, b2, b3, b4, b5, b6) where-  mapTuple (a0, a1, a2, a3, a4, a5, a6) = (mapTuple @flag a0, mapTuple @flag a1, mapTuple @flag a2, mapTuple @flag a3, mapTuple @flag a4, mapTuple @flag a5, mapTuple @flag a6)--instance {-# OVERLAPPING #-} (Mappable flag a0 b0, Mappable flag a1 b1, Mappable flag a2 b2, Mappable flag a3 b3, Mappable flag a4 b4, Mappable flag a5 b5, Mappable flag a6 b6, Mappable flag a7 b7) => Mappable flag (a0, a1, a2, a3, a4, a5, a6, a7) (b0, b1, b2, b3, b4, b5, b6, b7) where-  mapTuple (a0, a1, a2, a3, a4, a5, a6, a7) = (mapTuple @flag a0, mapTuple @flag a1, mapTuple @flag a2, mapTuple @flag a3, mapTuple @flag a4, mapTuple @flag a5, mapTuple @flag a6, mapTuple @flag a7)--instance {-# OVERLAPPING #-} (Mappable flag a0 b0, Mappable flag a1 b1, Mappable flag a2 b2, Mappable flag a3 b3, Mappable flag a4 b4, Mappable flag a5 b5, Mappable flag a6 b6, Mappable flag a7 b7, Mappable flag a8 b8) => Mappable flag (a0, a1, a2, a3, a4, a5, a6, a7, a8) (b0, b1, b2, b3, b4, b5, b6, b7, b8) where-  mapTuple (a0, a1, a2, a3, a4, a5, a6, a7, a8) = (mapTuple @flag a0, mapTuple @flag a1, mapTuple @flag a2, mapTuple @flag a3, mapTuple @flag a4, mapTuple @flag a5, mapTuple @flag a6, mapTuple @flag a7, mapTuple @flag a8)--instance {-# OVERLAPPING #-} (Mappable flag a0 b0, Mappable flag a1 b1, Mappable flag a2 b2, Mappable flag a3 b3, Mappable flag a4 b4, Mappable flag a5 b5, Mappable flag a6 b6, Mappable flag a7 b7, Mappable flag a8 b8, Mappable flag a9 b9) => Mappable flag (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) (b0, b1, b2, b3, b4, b5, b6, b7, b8, b9) where-  mapTuple (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) = (mapTuple @flag a0, mapTuple @flag a1, mapTuple @flag a2, mapTuple @flag a3, mapTuple @flag a4, mapTuple @flag a5, mapTuple @flag a6, mapTuple @flag a7, mapTuple @flag a8, mapTuple @flag a9)--instance {-# OVERLAPPING #-} (Mappable flag a0 b0, Mappable flag a1 b1, Mappable flag a2 b2, Mappable flag a3 b3, Mappable flag a4 b4, Mappable flag a5 b5, Mappable flag a6 b6, Mappable flag a7 b7, Mappable flag a8 b8, Mappable flag a9 b9, Mappable flag a10 b10) => Mappable flag (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) (b0, b1, b2, b3, b4, b5, b6, b7, b8, b9, b10) where-  mapTuple (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) = (mapTuple @flag a0, mapTuple @flag a1, mapTuple @flag a2, mapTuple @flag a3, mapTuple @flag a4, mapTuple @flag a5, mapTuple @flag a6, mapTuple @flag a7, mapTuple @flag a8, mapTuple @flag a9, mapTuple @flag a10)--instance {-# OVERLAPPING #-} (Mappable flag a0 b0, Mappable flag a1 b1, Mappable flag a2 b2, Mappable flag a3 b3, Mappable flag a4 b4, Mappable flag a5 b5, Mappable flag a6 b6, Mappable flag a7 b7, Mappable flag a8 b8, Mappable flag a9 b9, Mappable flag a10 b10, Mappable flag a11 b11) => Mappable flag (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11) (b0, b1, b2, b3, b4, b5, b6, b7, b8, b9, b10, b11) where-  mapTuple (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11) = (mapTuple @flag a0, mapTuple @flag a1, mapTuple @flag a2, mapTuple @flag a3, mapTuple @flag a4, mapTuple @flag a5, mapTuple @flag a6, mapTuple @flag a7, mapTuple @flag a8, mapTuple @flag a9, mapTuple @flag a10, mapTuple @flag a11)--instance {-# OVERLAPPING #-} (Mappable flag a0 b0, Mappable flag a1 b1, Mappable flag a2 b2, Mappable flag a3 b3, Mappable flag a4 b4, Mappable flag a5 b5, Mappable flag a6 b6, Mappable flag a7 b7, Mappable flag a8 b8, Mappable flag a9 b9, Mappable flag a10 b10, Mappable flag a11 b11, Mappable flag a12 b12) => Mappable flag (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12) (b0, b1, b2, b3, b4, b5, b6, b7, b8, b9, b10, b11, b12) where-  mapTuple (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12) = (mapTuple @flag a0, mapTuple @flag a1, mapTuple @flag a2, mapTuple @flag a3, mapTuple @flag a4, mapTuple @flag a5, mapTuple @flag a6, mapTuple @flag a7, mapTuple @flag a8, mapTuple @flag a9, mapTuple @flag a10, mapTuple @flag a11, mapTuple @flag a12)--instance {-# OVERLAPPING #-} (Mappable flag a0 b0, Mappable flag a1 b1, Mappable flag a2 b2, Mappable flag a3 b3, Mappable flag a4 b4, Mappable flag a5 b5, Mappable flag a6 b6, Mappable flag a7 b7, Mappable flag a8 b8, Mappable flag a9 b9, Mappable flag a10 b10, Mappable flag a11 b11, Mappable flag a12 b12, Mappable flag a13 b13) => Mappable flag (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13) (b0, b1, b2, b3, b4, b5, b6, b7, b8, b9, b10, b11, b12, b13) where-  mapTuple (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13) = (mapTuple @flag a0, mapTuple @flag a1, mapTuple @flag a2, mapTuple @flag a3, mapTuple @flag a4, mapTuple @flag a5, mapTuple @flag a6, mapTuple @flag a7, mapTuple @flag a8, mapTuple @flag a9, mapTuple @flag a10, mapTuple @flag a11, mapTuple @flag a12, mapTuple @flag a13)--instance {-# OVERLAPPING #-} (Mappable flag a0 b0, Mappable flag a1 b1, Mappable flag a2 b2, Mappable flag a3 b3, Mappable flag a4 b4, Mappable flag a5 b5, Mappable flag a6 b6, Mappable flag a7 b7, Mappable flag a8 b8, Mappable flag a9 b9, Mappable flag a10 b10, Mappable flag a11 b11, Mappable flag a12 b12, Mappable flag a13 b13, Mappable flag a14 b14) => Mappable flag (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14) (b0, b1, b2, b3, b4, b5, b6, b7, b8, b9, b10, b11, b12, b13, b14) where-  mapTuple (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14) = (mapTuple @flag a0, mapTuple @flag a1, mapTuple @flag a2, mapTuple @flag a3, mapTuple @flag a4, mapTuple @flag a5, mapTuple @flag a6, mapTuple @flag a7, mapTuple @flag a8, mapTuple @flag a9, mapTuple @flag a10, mapTuple @flag a11, mapTuple @flag a12, mapTuple @flag a13, mapTuple @flag a14)

@@ -9,26 +9,18 @@ where  import Control.Monad.IO.Class-import Control.Monad.Reader (MonadReader (..)) import Data.Data (Typeable) import Data.IORef import Data.Kind import Data.Map (Map) import Data.Map qualified as Map-import Mischief.ECS.App import Mischief.ECS.App.SystemDef import Mischief.ECS.App.Systems import Mischief.ECS.Components-import Mischief.ECS.Log import Mischief.ECS.Resources-import Mischief.ECS.Tables-import Mischief.ECS.Utils import Mischief.ECS.World-import Mischief.ECS.World.Insert-import Mischief.ECS.World.Modify-import Mischief.ECS.World.Query (get)+import Mischief.ECS.World.Query (mkGet, single) import Mischief.ECS.World.Query.Markers-import Mischief.ECS.World.Query.Queryable import Prelude hiding (read)  -- | Message typeclass.@@ -50,7 +42,7 @@   case Map.lookup world.systemId m.readers of     Just r -> return r     Nothing -> do-      tick <- liftIO $ newIORef $ Tick (0, 0)+      tick <- liftIO $ newIORef $ Tick 0       insertRes $ (\Messages {messages, readers} -> Messages {messages, readers = Map.insert world.systemId (Reader tick) readers}) m       return $ Reader tick @@ -59,16 +51,17 @@ -- | Write a message. write :: forall m. (Message m) => m -> System () write !message = do-  messages <- resOrInsert $ newMessages @m+  messages <- resOrInsert (newMessages @m)   world <- unsafeGetWorld   frame <- liftIO $ readIORef world.frame    loc <- self-  Just currentSystemTick <- get (C @SystemTick) loc+  Just currentSystemTick <- single $ mkGet loc (C @SystemTick)    let message' = (frame, currentSystemTick.inner, message)-  modify messages (\Messages {messages, readers} -> Messages {messages = message' : messages, readers})-  clearOldMessages messages+  let newMessages = (\Messages {messages, readers} -> Messages {messages = message' : messages, readers}) messages+  insertRes newMessages+  clearOldMessages newMessages  -- | Read all the messages that haven't been read by the current system. read :: forall m. (Message m) => System [m]@@ -81,7 +74,7 @@       readerTick <- liftIO $ readIORef tick        loc <- self-      Just currentSystemTick <- get (C @SystemTick) loc+      Just currentSystemTick <- single $ mkGet loc (C @SystemTick)        let newMessages = map (\(_, _, x) -> x) $ filter (\(_, tick, _) -> tick < currentSystemTick.inner && tick > readerTick) m.messages       liftIO $ writeIORef tick currentSystemTick.inner@@ -92,8 +85,8 @@ add :: forall (m :: Type). (Message m) => System () add = insertRes $ newMessages @m -clearOldMessages :: (Message m) => Result (Messages m) -> System ()+clearOldMessages :: (Message m) => Messages m -> System () clearOldMessages !m = do   world <- unsafeGetWorld   frame <- liftIO $ readIORef world.frame-  modify m (\Messages {messages, readers} -> Messages {messages = filter (\(Frame x, _, _) -> Frame (x + 2) >= frame) messages, readers})+  insertRes $ (\Messages {messages, readers} -> Messages {messages = filter (\(Frame x, _, _) -> Frame (x + 2) >= frame) messages, readers}) m

@@ -10,11 +10,6 @@ newtype Observer e = Observer (e -> System ())  instance (Typeable e) => Component (Observer e) where-  required = require @(EventProxy e, ObserverOrder)--newtype ObserverOrder = ObserverOrder Int-  deriving (Show)-  deriving anyclass (Component)-  deriving newtype (Eq, Ord, Default)+  required = require @(EventProxy e)  data EventProxy e = EventProxy deriving (Component, Generic, Default)

@@ -1,10 +0,0 @@-module Mischief.ECS.Observers where--import Mischief.ECS.Entities-import Mischief.ECS.EventDef-import Mischief.ECS.Observer-import Mischief.ECS.World-import Mischief.ECS.World.Spawn qualified--spawn :: (Event e) => (e -> System ()) -> System Entity-spawn x = Mischief.ECS.World.Spawn.spawn $ Observer x

@@ -1,57 +0,0 @@-module Mischief.ECS.Prelude-  ( module Mischief.ECS.Components,-    module Mischief.ECS.Components.Required,-    module Mischief.ECS.Components.Common,-    module Mischief.ECS.Entities,-    module Mischief.ECS.World.Query,-    module Mischief.ECS.World.Query.QueryFilter,-    module Mischief.ECS.World.Query.Markers,-    module Mischief.ECS.World.Query.TH,-    module Mischief.ECS.World.Insert,-    module Mischief.ECS.World.Remove,-    module Mischief.ECS.World.Modify,-    module Mischief.ECS.World.Spawn,-    module Mischief.ECS.Resources,-    module Mischief.ECS.EventDef,-    module Mischief.ECS.World,-    module Mischief.ECS.Time,-    module Mischief.ECS.World.Defer,-    module Mischief.ECS.App,-    module Mischief.ECS.App.Plugins,-    module Mischief.ECS.App.Schedules,-    module Mischief.ECS.App.SystemConfig,-    module Mischief.ECS.Log,-    module Mischief.ECS.Utils,-    module Mischief.ECS.World.Utils,-    module Mischief.ECS.Events,-    module Mischief.ECS.World.Query.QueryType,-  )-where--import Mischief.ECS.App (newApp, runApp)-import Mischief.ECS.App.Plugins (Plugin (..), plug)-import Mischief.ECS.App.Schedules (First (..), PostStartup (..), PostUpdate (..), PreStartup (..), PreUpdate (..), Startup (..), Update (..))-import Mischief.ECS.App.SystemConfig (after, before)-import Mischief.ECS.Components (Component (..), Exclusivity (..), Rel (..))-import Mischief.ECS.Components.Common (Name (..))-import Mischief.ECS.Components.Required (require)-import Mischief.ECS.Entities (Entity)-import Mischief.ECS.EventDef (Event)-import Mischief.ECS.Events (trigger)-import Mischief.ECS.Log-import Mischief.ECS.Resources-import Mischief.ECS.Time (Time, TimePlugin (..), deltaSecs, deltaTime)-import Mischief.ECS.Utils (unwrap)-import Mischief.ECS.World (System)-import Mischief.ECS.World.Defer (defer, delay, runAfter)-import Mischief.ECS.World.Insert (insert, insertIfNeq, insertNew, set, setIfNeq, update)-import Mischief.ECS.World.Modify (modify, modify')-import Mischief.ECS.World.Query (get, get', query, query', single, single')-import Mischief.ECS.World.Query.Markers (Any (..), C (..), E (..), Has (..), HasR (..), M (..), MR (..), Q (..), R (..), Val (..))-import Mischief.ECS.World.Query.QueryFilter (Added (..), Changed (..), Check (..), CheckR (..), Not (..), With (..), Without (..), (|.))-import Mischief.ECS.World.Query.QueryType (QueryType)-import Mischief.ECS.World.Query.Queryable ()-import Mischief.ECS.World.Query.TH (g, q, s)-import Mischief.ECS.World.Remove (remove)-import Mischief.ECS.World.Spawn (despawn, spawn, spawnDefer)-import Mischief.ECS.World.Utils (expect)

@@ -1,7 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}--module Mischief.ECS.Relationships where--import Mischief.ECS.Components--data IsExclusiveRelationship = IsExclusiveRelationship deriving (Show, Component)

@@ -4,20 +4,18 @@ import Mischief.ECS.Entities import Mischief.ECS.Relationships.Graph import Mischief.ECS.World-import Mischief.ECS.World.Query-import Mischief.ECS.World.Query.Queryable  data ChildOf = ChildOf deriving (Show)  instance Component ChildOf where-  type RelExclusivity ChildOf = Exclusive+  type IsExclusiveRel ChildOf = True --- parent :: forall m w. (MonadSystem w m) => Entity -> m (Maybe Entity)--- parent entity = do---   p <- outgoing @ChildOf entity---   return $ case p of---     [p] -> Just p---     _ -> Nothing+parent :: forall m w. (MonadSystem w m) => Entity -> m (Maybe Entity)+parent !entity = do+  !p <- outgoing' @ChildOf entity+  pure $ case p of+    [!p] -> Just p+    _ -> Nothing --- children :: forall m w. (MonadSystem w m) => Entity -> m [Entity]--- children = outgoing @ChildOf+children :: forall m w. (MonadSystem w m) => Entity -> m [Entity]+children = outgoing' @ChildOf

@@ -3,21 +3,38 @@  module Mischief.ECS.Relationships.Graph where +import Data.List import Mischief.ECS.Components import Mischief.ECS.Components.BundleTypes import Mischief.ECS.Entities-import Mischief.ECS.Tables import Mischief.ECS.World import Mischief.ECS.World.Query-import Mischief.ECS.World.Query.QueryFilter-import Mischief.ECS.World.Query.Queryable+import Mischief.ECS.World.Query.Markers+import Mischief.ECS.World.Query.QueryFilter (QueryFilter (With)) --- outgoing :: forall c m w. (Component c, MonadSystem w m) => Entity -> m [Entity]--- outgoing entity = do---   next <- get (R @c Any) entity---   return $ case next of---     Nothing -> []---     Just next -> map (\x -> x.target) next+type family RelOutgoing b where+  RelOutgoing True = Maybe+  RelOutgoing False = List --- ingoing :: forall c m w. (Component c, BundleTypes c, MonadSystem w m) => Entity -> m [Entity]--- ingoing entity = query' E (With (R @c entity))+class ListToOutgoing b where+  listToOutgoing :: [Entity] -> b++instance ListToOutgoing (Maybe Entity) where+  listToOutgoing [!x] = Just x+  listToOutgoing _ = Nothing++instance ListToOutgoing [Entity] where+  listToOutgoing = id++outgoing' :: forall c m w. (Component c, MonadSystem w m) => Entity -> m [Entity]+outgoing' !entity = do+  !next <- single $ mkGet entity (R' @c Any)+  pure $ case next of+    Nothing -> []+    Just !next -> map (\x -> x.target) next++outgoing :: forall c m w. (Component c, MonadSystem w m, ListToOutgoing (RelOutgoing (IsExclusiveRel c) Entity)) => Entity -> m (RelOutgoing (IsExclusiveRel c) Entity)+outgoing !entity = listToOutgoing <$> outgoing' @c entity++incoming :: forall c m w. (Component c, BundleTypes c, MonadSystem w m) => Entity -> m [Entity]+incoming !entity = query $ mkQuery' E (With (R @c entity))

@@ -6,41 +6,36 @@ import Data.Set qualified as Set import Mischief.ECS.Components import Mischief.ECS.Entities-import Mischief.ECS.Log-import Mischief.ECS.Tables import Mischief.ECS.Utils import Mischief.ECS.World import Mischief.ECS.World.Insert import Mischief.ECS.World.Query import Mischief.ECS.World.Query.Markers import Mischief.ECS.World.Query.QueryFilter-import Mischief.ECS.World.Query.Queryable import Mischief.ECS.World.Remove-import Mischief.ECS.World.Spawn-import Mischief.ECS.World.Utils  data Before = Before deriving (Component)  data Visited = Visited deriving (Component)  orderEntities :: [Entity] -> System [Entity]-orderEntities entities = do-  res <- orderEntitiesStep (Set.fromList entities)+orderEntities !entities = do+  !res <- orderEntitiesStep (Set.fromList entities)   for_ entities $ remove (C @Visited)   -- err $ text res-  return res+  pure res  orderEntitiesStep :: Set Entity -> System [Entity]-orderEntitiesStep entities =+orderEntitiesStep !entities =   if null entities     then       return []     else do-      next <- expect "Attempted to Order Cyclic Graph!" =<< findM isAvailable entities+      !next <- expect "Attempted to Order Cyclic Graph!" <$> findM isAvailable entities       insert Visited next       (next :) <$> orderEntitiesStep (Set.delete next entities)  isAvailable :: Entity -> System Bool-isAvailable entity = do-  before <- query' E (With (R @Before entity))-  isNothing <$> findM ((not . unwrap <$>) . get (Has @Visited)) before+isAvailable !entity = do+  !before <- query $ mkQuery' E (With (R @Before entity))+  isNothing <$> findM (\(!x) -> (not . unwrap <$>) $ single $ mkGet x (Has @Visited)) before

@@ -8,31 +8,34 @@ import Mischief.ECS.Relationships.Graph import Mischief.ECS.World --- descendants :: forall c m w. (Component c, BundleTypes c, MonadSystem w m) => Entity -> m [Entity]--- descendants entity = do---   next <- ingoing @c entity---   next' <- mapM (descendants @c) next---   return $ next ++ concat next'+descendants :: forall c m w. (Component c, BundleTypes c, MonadSystem w m) => Entity -> m [Entity]+descendants !entity = do+  !next <- incoming @c entity+  !next' <- mapM (descendants @c) next+  pure $ next ++ concat next' --- anestors :: forall c m w. (Component c, MonadSystem w m) => Entity -> m [Entity]--- anestors entity = do---   next <- outgoing @c entity---   x <- mapM (anestors @c) next---   return $ concat (next : x)+ancestors' :: forall c m w. (Component c, MonadSystem w m) => Entity -> m [Entity]+ancestors' !entity = do+  !next <- outgoing' @c entity+  !x <- mapM (ancestors' @c) next+  pure $ concat (next : x) --- root :: forall c m w. (Component c, MonadSystem w m) => Entity -> m Entity--- root entity = do---   out <- outgoing @c entity---   case out of---     [] -> return entity---     [p] -> root @c p---     _ -> undefined+ancestors :: forall c m w. (Component c, MonadSystem w m, ListToOutgoing (RelOutgoing (IsExclusiveRel c) Entity)) => Entity -> m (RelOutgoing (IsExclusiveRel c) Entity)+ancestors !e = listToOutgoing <$> ancestors' @c e --- leaves :: forall c m w. (Component c, BundleTypes c, MonadSystem w m) => Entity -> m [Entity]--- leaves entity = do---   ing <- ingoing @c entity---   case ing of---     [] -> return [entity]---     l -> do---       l' <- mapM (leaves @c) l---       return $ concat l'+root :: forall c m w. (Component c, MonadSystem w m) => Entity -> m (Maybe Entity)+root !entity = do+  !out <- outgoing' @c entity+  case out of+    [] -> pure $ Just entity+    [!p] -> root @c p+    _ -> undefined++leaves :: forall c m w. (Component c, BundleTypes c, MonadSystem w m) => Entity -> m [Entity]+leaves !entity = do+  !ing <- incoming @c entity+  case ing of+    [] -> return [entity]+    !l -> do+      !l' <- mapM (leaves @c) l+      pure $ concat l'

@@ -0,0 +1,47 @@+module Mischief.ECS.Repeater (Repeater (..)) where++import Control.Concurrent (threadDelay)+import Control.Concurrent.Async (async)+import Control.Concurrent.STM+import Control.Monad+import Control.Monad.IO.Class+import Data.IORef+import GHC.Float (float2Int)+import Mischief.ECS.Components+import Mischief.ECS.Components.HooksDef+import Mischief.ECS.Hooks+import Mischief.ECS.World+import Mischief.ECS.World.Insert+import Mischief.ECS.World.Query+import Mischief.ECS.World.Query.Markers++data Repeater = Repeater Float (System ())++newtype RepeaterRef = RepeaterRef (IORef Bool) deriving anyclass (Component)++instance Component Repeater where+  onAdd =+    [ hook $ \(HookContext e) -> do+        i <- liftIO (newIORef False)+        Just (Repeater t s) <- single $ mkGet e (C @Repeater)+        insert (RepeaterRef i) e+        world <- unsafeGetWorld+        void $ liftIO $ async $ run world i (float2Int $ 1000000 * t) s+    ]++  onRemove =+    [ hook $ \(HookContext e) -> do+        break <- single $ mkGet e (C @RepeaterRef)+        case break of+          Nothing -> pure ()+          Just (RepeaterRef break) -> liftIO $ writeIORef break False+    ]++run :: World -> IORef Bool -> Int -> System () -> IO ()+run world break t s = do+  b <- liftIO $ readIORef break+  unless b $ do+    liftIO $ threadDelay t++    liftIO $ atomically $ modifyTVar' world.deferredAsync (++ [s])+    run world break t s

@@ -1,28 +1,70 @@-module Mischief.ECS.Resources where+module Mischief.ECS.Resources+  ( insertRes,+    res,+    resOrInsert,+    resOrInsertM,+    modifyRes,+    modifyRes',+  )+where +import Data.Maybe import Mischief.ECS.Components import Mischief.ECS.Components.Bundle import Mischief.ECS.Components.Spawn-import Mischief.ECS.Tables import Mischief.ECS.World import Mischief.ECS.World.Insert import Mischief.ECS.World.Query import Mischief.ECS.World.Query.Markers-import Mischief.ECS.World.Query.QueryType-import Mischief.ECS.World.Query.Queryable --- | Insert a resource into this world. If the resource already exists, its value will be overwritten.+-- | Insert a resource into the World. If the resource already exists, its value will be overwritten. insertRes :: forall r. (Component r, Bundle r) => r -> System () insertRes res = do   entity <- meta @r   insert res entity -res :: forall c. (QueryType c) => System (Maybe c)+-- | Get the value of a resource from the World.+res :: forall c m w. (MonadSystem w m) => (Component c) => m (Maybe c) res = do-  meta <- meta @c-  get (Val (C @c)) meta+  meta <- tryMeta @c+  case meta of+    Nothing -> pure Nothing+    Just meta -> do+      single $ mkGet meta (C @c) -resOrInsert :: forall r. (Component r, Updateable (Result r), Bundle r) => r -> System (Result r)+-- | Get the value of a resource, or insert a resource if it doesn't exist.+resOrInsert :: forall r. (Component r, Bundle r) => r -> System r resOrInsert r = do   meta <- meta @r-  getOrInsert r meta+  x <- single $ mkGet meta (C @r)+  case x of+    Nothing -> do+      insertRes r+      pure $! r+    Just x -> pure $! x++-- | Same as 'resOrInsert' but allows the default resource to be produced by a System.+resOrInsertM :: forall r. (Component r, Bundle r) => System r -> System r+resOrInsertM r = do+  meta <- meta @r+  x <- single $ mkGet meta (C @r)+  case x of+    Nothing -> do+      r <- r+      insertRes r+      pure r+    Just x -> pure x++-- | Modify the value of a resource if it exists, otherwise insert the result of the function.+modifyRes :: forall r. (Component r, Bundle r) => (Maybe r -> r) -> System ()+modifyRes f = do+  x <- res @r+  insertRes $ f x++-- | Modify the value of a resource if it exists, otherwise do nothing.+modifyRes' :: forall r. (Component r, Bundle r) => (r -> r) -> System ()+modifyRes' f = do+  x <- res @r+  case x of+    Nothing -> pure ()+    Just x -> insertRes $ f x

@@ -1,12 +1,15 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+ module Mischief.ECS.Schedules where +import Language.Haskell.TH (Extension (AllowAmbiguousTypes)) import Mischief.ECS.App import Mischief.ECS.App.Schedules import Mischief.ECS.Entities import Mischief.ECS.World -get :: (Schedule sc) => sc -> System Entity-get = scheduleEntity+get :: forall sc. (Schedule sc) => System Entity+get = scheduleEntity @sc -run :: (Schedule sc) => sc -> System ()-run = runSchedule+run :: forall sc. (Schedule sc) => System ()+run = runSchedule @sc

@@ -11,6 +11,7 @@   hSetBuffering stdin NoBuffering   hSetEcho stdin False +-- | Gets the characters inputted by the user into the terminal since the lasts call. Only to be used for examples and test applications. Make sure to call 'Mischief.ECS.Stdin.init' first. read :: System String read = do   ready <- liftIO $ hReady stdin@@ -21,6 +22,7 @@     else do       return [] +-- | Gets the last character inputted by the user into the terminal. Only to be used for examples and test applications. Make sure to call 'Mischief.ECS.Stdin.init' first. readLast :: System (Maybe Char) readLast = do   r <- read

@@ -1,73 +1,103 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+ -- | -- Module with utility functions for creating -- and scheduling systems. module Mischief.ECS.Systems where  import Data.Foldable-import Data.Kind-import GHC.Stack.Types import Mischief.ECS.App.Schedules-import Mischief.ECS.App.SystemConfig-import Mischief.ECS.App.Systems (ScheduledIn (ScheduledIn), SystemFunction (SystemFunction), removeSystemFromMap, systemEntity)+import Mischief.ECS.App.Systems (ScheduledIn, SystemFunction (SystemFunction), removeSystemFromMap, systemEntity) import Mischief.ECS.Collectable import Mischief.ECS.Components import Mischief.ECS.Entities-import Mischief.ECS.Mappable import Mischief.ECS.Relationships.Order import Mischief.ECS.World import Mischief.ECS.World.Insert import Mischief.ECS.World.Query import Mischief.ECS.World.Query.Markers import Mischief.ECS.World.Query.QueryFilter-import Mischief.ECS.World.Query.Queryable import Mischief.ECS.World.Remove import Mischief.ECS.World.Spawn import Mischief.ECS.World.Spawn qualified as Spawn-import Mischief.ECS.World.Utils -add :: (HasCallStack, Schedule sc, SystemConfig s) => sc -> s -> System ()-add schedule system = do-  let SystemConfigData {systems, edges} = systemConfigData system+data SystemConfig = SystemConfig+  { systems :: [System ()],+    edges :: [(System (), System ())]+  } -  for_ systems $ \system -> systemEntity schedule system+newtype Systems = Systems [System ()] deriving newtype (Semigroup) +instance EraseIntoStorage (System ()) Systems where+  erase a = Systems [a]++type ToSystems a = Collectable a Systems++systems :: (ToSystems a) => a -> SystemConfig+systems a =+  let Systems systems = collect a+   in SystemConfig {systems, edges = []}++after :: (ToSystems a) => a -> SystemConfig -> SystemConfig+after a s =+  let Systems systems = collect a+   in SystemConfig {systems = s.systems, edges = s.edges ++ zip systems s.systems}++before :: (ToSystems a) => a -> SystemConfig -> SystemConfig+before a s =+  let Systems systems = collect a+   in SystemConfig {systems = s.systems, edges = s.edges ++ zip s.systems systems}++schedule :: forall sc. (Schedule sc) => SystemConfig -> System ()+schedule SystemConfig {systems, edges} = do+  for_ systems $ \system -> systemEntity @sc system+   for_ edges $ \(s1, s2) -> do-    id1 <- systemEntity schedule s1-    id2 <- systemEntity schedule s2+    id1 <- systemEntity @sc s1+    id2 <- systemEntity @sc s2     insert (Rel Before id2) id1 -remove :: (Schedule sc, Collectable a [System ()]) => sc -> a -> System ()-remove schedule systems = do-  let y :: [System ()] = collect systems-  for_ y (removeOne schedule)--removeOne :: (Schedule sc) => sc -> System () -> System ()-removeOne schedule system = do-  s <- Mischief.ECS.Systems.get schedule system-  sch <- scheduleEntity schedule-  removeSystemFromMap (ScheduleId sch) system+order :: forall sc a b. (Schedule sc, ToSystems a, ToSystems b) => (a, b) -> System ()+order (s1, s2) = do+  let Systems systems1 = collect s1+  let Systems systems2 = collect s2 -  despawn s+  for_ systems1 $ \s1 -> for_ systems2 $ \s2 -> do+    s1 <- Mischief.ECS.Systems.get @sc s1+    s2 <- Mischief.ECS.Systems.get @sc s2 -  query' E (With (R @Before s))-    >>= traverse_ (removeRel @Before s)+    insert (Rel Before s2) s1  spawn :: System () -> System Entity spawn = Spawn.spawn . SystemFunction -get :: (Schedule sc) => sc -> System () -> System Entity-get = systemEntity+get :: forall sc. (Schedule sc) => System () -> System Entity+get = systemEntity @sc -schedule :: (Schedule sc) => sc -> System () -> System ()-schedule sch s = do-  s' <- Mischief.ECS.Systems.get sch s-  sch' <- scheduleEntity sch+-- | Disconnect a system from a schedule. This will keep the system's entity alive, as well as all its other relationships and data,+-- so that if scheduled again it will work the same as before. Use this if you plan to dynamically schedule and unschedule a system. Otherwise check 'unschedule''.+unschedule :: forall sc a. (Schedule sc, ToSystems a) => a -> System ()+unschedule s = do+  sch' <- scheduleEntity @sc -  insert (Rel ScheduledIn sch') s'+  let Systems systems = collect s+  for_ systems $ \s -> do+    s' <- Mischief.ECS.Systems.get @sc s -unschedule :: (Schedule sc) => sc -> System () -> System ()-unschedule sch s = do-  s' <- Mischief.ECS.Systems.get sch s-  sch' <- scheduleEntity sch+    removeRel @ScheduledIn sch' s' -  removeRel @ScheduledIn sch' s'+-- | Disconnect a system rom a schedule. This will despawn the system's entity, losing all its data such as ordering with other systems.+-- Use this if you want to disable a scheduled system for good. Otherwise check 'unschedule'.+unschedule' :: forall sc a. (Schedule sc, ToSystems a) => a -> System ()+unschedule' systems = do+  sch <- scheduleEntity @sc++  let Systems y = collect systems+  for_ y $ \system -> do+    s <- Mischief.ECS.Systems.get @sc system+    removeSystemFromMap (ScheduleId sch) system++    despawn s++    query (mkQuery' E (With (R @Before s)))+      >>= traverse_ (removeRel @Before s)

@@ -3,24 +3,19 @@ module Mischief.ECS.Tables where  import Control.Monad (forM, when)-import Data.Foldable (Foldable (toList), find, for_)+import Data.Bifunctor qualified+import Data.Foldable (Foldable (toList), for_) import Data.IORef-import Data.Kind import Data.List (transpose) import Data.Map (Map) import Data.Map qualified as Map-import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing)+import Data.Maybe (catMaybes) import Data.Traversable (for)-import Data.Typeable (Proxy (Proxy), eqT, typeRep, type (:~:) (Refl)) import Data.Vector qualified as Vector-import GHC.Base (Int (..), Word (W#), eqWord#, isTrue#)-import GHC.Records-import GHC.TypeLits+import GHC.Base (Int (..), eqWord#, isTrue#) import Mischief.ECS.Components import Mischief.ECS.Components.Bundle import Mischief.ECS.Entities-import Mischief.ECS.EntityDef (Entity# (Entity#), eqEntity#, liftEntity)-import Mischief.ECS.Utils import Mischief.ECS.Vec (IOVec) import Mischief.ECS.Vec qualified as Vec @@ -29,10 +24,11 @@ data Table = Table   { columns :: IORef (Map ComponentId Column),     components :: [ComponentId],+    ticks :: IORef (Map ComponentId ComponentTick),     entities :: IOVec (Entity, IORef EntityPointer)   } -newtype Column = Column (IOVec ComponentData)+newtype Column = Column (IOVec ErasedComponent)  baseline_entities_cap :: Int baseline_entities_cap = 64@@ -52,8 +48,9 @@    columns <- newIORef $ Map.fromList (toList cols)   entities <- Vec.new baseline_entities_cap+  ticks <- newIORef $ Map.fromList (map (,ComponentTick (Tick 0)) components) -  return $ Table {columns = columns, components, entities}+  return $ Table {columns = columns, components, entities, ticks}  tableIsEmpty :: Table -> IO Bool tableIsEmpty table = Vec.null table.entities@@ -81,26 +78,22 @@     tapMap map el.id $ \(Column col) ->       Vec.pushBack col el.component -insertComponentsIntoTable :: ProcessedBundleData -> Table -> IO ()-insertComponentsIntoTable bundle table = do+insertComponentsIntoTable :: ProcessedBundleData -> Tick -> ChangedComponents -> Table -> IO ()+insertComponentsIntoTable bundle tick changed table = do+  for_ changed $ \a -> modifyIORef' table.ticks (Map.insert a (ComponentTick tick))+   cols <- readIORef table.columns   insertComponentsIntoMap bundle cols  replaceComponentsIntoMap ::   ProcessedBundleData ->-  -- | The current tick that will be as the components' change tick.-  Maybe Tick ->   EntityPointer ->   Map ComponentId Column ->   IO ()-replaceComponentsIntoMap bundle tick (EntityPointer (# archetypeId, rowIndex #)) tableMap = do+replaceComponentsIntoMap bundle (EntityPointer (# _, rowIndex #)) tableMap = do   for_ bundle.elements $ \el ->     tapMap tableMap el.id $ \(Column col) ->-      case tick of-        Just tick ->-          Vec.modify_ col (I# rowIndex) (\ComponentData {value, ticks = ComponentTicks {changed, added}} -> ComponentData {value = el.component.value, ticks = ComponentTicks {changed = tick, added}})-        Nothing ->-          Vec.modify_ col (I# rowIndex) (\ComponentData {value, ticks} -> ComponentData {value = el.component.value, ticks})+      Vec.unsafeWrite col (I# rowIndex) el.component  --   foldl' modifyMap tableMap bundle.elements --  where@@ -117,10 +110,15 @@   Table ->   IO () replaceComponentsIntoTable bundle tick pointer table = do+  case tick of+    Nothing -> pure ()+    Just tick -> do+      for_ bundle.elements $ \a -> modifyIORef' table.ticks (Map.insert a.id (ComponentTick tick))+   cols <- readIORef table.columns-  replaceComponentsIntoMap bundle tick pointer cols+  replaceComponentsIntoMap bundle pointer cols -takeFromColumn :: EntityPointer -> Column -> IO ComponentData+takeFromColumn :: EntityPointer -> Column -> IO ErasedComponent takeFromColumn (EntityPointer (# _, rowIndex #)) (Column col) = Vec.takeSwap col (I# rowIndex)  takeComponentsFromTable :: EntityPointer -> Table -> IO ProcessedBundleData@@ -185,8 +183,12 @@  --     insertComponentsIntoTable bundle table -insertEntityIntoTables :: ProcessedBundleData -> Tables -> ArchetypeId -> (Entity, IORef EntityPointer) -> IO ()-insertEntityIntoTables bundle (Tables tables) archetype pointerRef =+type ChangedComponents = [ComponentId]++type AddedComponents = [ComponentId]++insertEntityIntoTables :: ProcessedBundleData -> Tick -> ChangedComponents -> Tables -> ArchetypeId -> (Entity, IORef EntityPointer) -> IO ()+insertEntityIntoTables bundle tick changed (Tables tables) archetype pointerRef =   do     table <- Vec.unsafeRead tables archetype.id @@ -197,15 +199,15 @@     let !(I# rowIndex') = rowIndex     writeIORef (snd pointerRef) $ EntityPointer (# archetype', rowIndex' #) -    insertComponentsIntoTable bundle table+    insertComponentsIntoTable bundle tick changed table  tryGetComponentFromColumn :: forall c. (Component c) => Column -> EntityPointer -> IO (Maybe c) tryGetComponentFromColumn (Column components) (EntityPointer (# _, rowIndex #)) = do   element <- Vec.unsafeRead components (I# rowIndex)-  pure $ tryGetComponent element.value+  pure $ tryGetComponent element -tryGetRelCollectionFromTable :: forall c. (Component c) => Table -> Entity -> EntityPointer -> ComponentId -> IO (Maybe [Result (Rel c)])-tryGetRelCollectionFromTable table entity pointer (ComponentId (# id, target #)) =+tryGetRelCollectionFromTable :: forall c. (Component c) => Table -> Entity -> EntityPointer -> ComponentId -> IO (Maybe [(Entity, Rel c)])+tryGetRelCollectionFromTable table entity pointer (ComponentId (# id, _ #)) =   do     columns <- readIORef table.columns     -- TODO: improve lookup performance for partial tuples@@ -224,7 +226,7 @@       then         return Nothing       else do-        return $ Just $ map (\(value, target) -> Result (Rel value target, entity)) $ catMaybes components'+        return $ Just $ map (\(value, target) -> (entity, Rel value target)) $ catMaybes components'  tryGetComponentFromTable :: forall c. (Component c) => Table -> EntityPointer -> ComponentId -> IO (Maybe c) tryGetComponentFromTable table pointer componentId =@@ -235,7 +237,7 @@       Nothing -> return Nothing       Just column -> tryGetComponentFromColumn column pointer -tryGetRelCollectionFromTables :: forall c. (Component c) => Tables -> Entity -> EntityPointer -> ComponentId -> IO (Maybe ([Result (Rel c)]))+tryGetRelCollectionFromTables :: forall c. (Component c) => Tables -> Entity -> EntityPointer -> ComponentId -> IO (Maybe [(Entity, Rel c)]) tryGetRelCollectionFromTables (Tables tables) entity (EntityPointer (# archetypeId, rowIndex #)) componentId =   do     table <- Vec.unsafeRead tables (I# archetypeId)@@ -247,63 +249,58 @@     table <- Vec.unsafeRead tables (I# archetypeId)     tryGetComponentFromTable table (EntityPointer (# archetypeId, rowIndex #)) componentId -tryGetTicksFromColumn :: Column -> IO [ComponentTicks]-tryGetTicksFromColumn (Column components) = do-  frozen <- Vec.freeze components-  let x = Vector.map (\x -> x.ticks) frozen-  return $ Vector.toList x+-- tryGetEntityTicksFromColumn :: Column -> EntityPointer -> IO ComponentTicks+-- tryGetEntityTicksFromColumn (Column components) (EntityPointer (# _, rowIndex #)) = (\x -> x.ticks) <$> Vec.unsafeRead components (I# rowIndex) -tryGetEntityTicksFromColumn :: Column -> EntityPointer -> IO ComponentTicks-tryGetEntityTicksFromColumn (Column components) (EntityPointer (# _, rowIndex #)) = (\x -> x.ticks) <$> Vec.unsafeRead components (I# rowIndex)+tryGetTicksFromTable :: Table -> ComponentId -> IO (Maybe ComponentTick)+tryGetTicksFromTable table componentId = do+  ticks <- readIORef table.ticks+  pure $ Map.lookup componentId ticks -tryGetTicksFromTable :: Table -> ComponentId -> IO [Maybe ComponentTicks]-tryGetTicksFromTable table componentId =-  do-    columns <- readIORef table.columns-    case Map.lookup componentId columns of-      Nothing -> do-        l <- Vec.length table.entities-        return $ map (const Nothing) [1 .. l]-      Just column -> do-        map Just <$> tryGetTicksFromColumn column+-- do+--   columns <- readIORef table.columns+--   case Map.lookup componentId columns of+--     Nothing -> do+--       l <- Vec.length table.entities+--       return $ map (const Nothing) [1 .. l]+--     Just column -> do+--       map Just <$> tryGetTicksFromColumn column -tryGetEntityTicksFromTable :: Table -> EntityPointer -> ComponentId -> IO (Maybe ComponentTicks)-tryGetEntityTicksFromTable table pointer componentId =-  do-    columns <- readIORef table.columns-    case Map.lookup componentId columns of-      Nothing -> return Nothing-      Just column -> Just <$> tryGetEntityTicksFromColumn column pointer+-- tryGetEntityTicksFromTable :: Table -> EntityPointer -> ComponentId -> IO (Maybe ComponentTicks)+-- tryGetEntityTicksFromTable table pointer componentId =+--   do+--     columns <- readIORef table.columns+--     case Map.lookup componentId columns of+--       Nothing -> return Nothing+--       Just column -> Just <$> tryGetEntityTicksFromColumn column pointer -tryGetTicksFromArchetype :: ArchetypeId -> IOVec Table -> ComponentId -> IO [Maybe ComponentTicks]+tryGetTicksFromArchetype :: ArchetypeId -> IOVec Table -> ComponentId -> IO (Maybe ComponentTick) tryGetTicksFromArchetype archetype tables componentId = do   table <- Vec.unsafeRead tables archetype.id   tryGetTicksFromTable table componentId -tryGetEntityTicksFromArchetype :: ArchetypeId -> IOVec Table -> EntityPointer -> ComponentId -> IO (Maybe ComponentTicks)-tryGetEntityTicksFromArchetype archetype tables pointer componentId = do-  table <- Vec.unsafeRead tables archetype.id-  tryGetEntityTicksFromTable table pointer componentId+-- tryGetEntityTicksFromArchetype :: ArchetypeId -> IOVec Table -> EntityPointer -> ComponentId -> IO (Maybe ComponentTicks)+-- tryGetEntityTicksFromArchetype archetype tables pointer componentId = do+--   table <- Vec.unsafeRead tables archetype.id+--   tryGetEntityTicksFromTable table pointer componentId -tryGetTicksFromTables :: Tables -> [ArchetypeId] -> ComponentId -> IO [Maybe ComponentTicks]+tryGetTicksFromTables :: Tables -> [ArchetypeId] -> ComponentId -> IO [Maybe ComponentTick] tryGetTicksFromTables (Tables tables) archetypes componentId =-  do-    results <- mapM (\archetype -> tryGetTicksFromArchetype archetype tables componentId) archetypes-    return $ concat results+  mapM (\archetype -> tryGetTicksFromArchetype archetype tables componentId) archetypes -tryGetEntityTicksFromTables :: Tables -> EntityPointer -> ComponentId -> IO (Maybe ComponentTicks)-tryGetEntityTicksFromTables (Tables tables) (EntityPointer (# archetypeId, rowIndex #)) componentId =-  do-    tryGetEntityTicksFromArchetype (ArchetypeId $ I# archetypeId) tables (EntityPointer (# archetypeId, rowIndex #)) componentId+-- tryGetEntityTicksFromTables :: Tables -> EntityPointer -> ComponentId -> IO (Maybe ComponentTicks)+-- tryGetEntityTicksFromTables (Tables tables) (EntityPointer (# archetypeId, rowIndex #)) componentId =+--   do+--     tryGetEntityTicksFromArchetype (ArchetypeId $ I# archetypeId) tables (EntityPointer (# archetypeId, rowIndex #)) componentId  tryGetComponentsFromColumn :: forall c. (Component c) => Column -> IO [c] tryGetComponentsFromColumn (Column components) = do   frozen <- Vec.freeze components-  let x = Vector.mapM (\x -> tryGetComponent x.value) frozen+  let x = Vector.mapM tryGetComponent frozen   pure $ maybe [] Vector.toList x -tryGetRelCollectionsFromTable :: forall c. (Component c) => Table -> ComponentId -> IO [(Entity, [Result (Rel c)])]-tryGetRelCollectionsFromTable table (ComponentId (# id, target #)) =+tryGetRelCollectionsFromTable :: forall c. (Component c) => Table -> ComponentId -> IO [(Entity, [Rel c])]+tryGetRelCollectionsFromTable table (ComponentId (# id, _ #)) =   do     -- let Just entity = componentId.entity     columns <- readIORef table.columns@@ -323,10 +320,10 @@     let components'' = zip (map fst entities) $ transpose $ catMaybes components'     return $       map-        (\(entity, components) -> (entity, map (\(value, target) -> Result (Rel value target, entity)) components))+        (Data.Bifunctor.second (map (uncurry Rel)))         components'' -tryGetComponentsFromTable :: forall c. (Component c) => Table -> ComponentId -> IO [(Entity, Result c)]+tryGetComponentsFromTable :: forall c. (Component c) => Table -> ComponentId -> IO [(Entity, c)] tryGetComponentsFromTable table componentId =   do     columns <- readIORef table.columns@@ -336,7 +333,7 @@         results <- tryGetComponentsFromColumn @c column         entities <- Vec.toList table.entities         let zipped = zip (map fst entities) results-        return $ map (\(e, r) -> (e, Result (r, e))) zipped+        return $ map (\(e, r) -> (e, r)) zipped  tryGetEntitiesFromTable :: Table -> IO [Entity] tryGetEntitiesFromTable table =@@ -344,7 +341,7 @@     entities <- Vec.toList table.entities     return $ map fst entities -tryGetComponentsFromTableMaybe :: forall c. (Component c) => Table -> ComponentId -> IO [(Entity, Maybe (Result c))]+tryGetComponentsFromTableMaybe :: forall c. (Component c) => Table -> ComponentId -> IO [(Entity, Maybe c)] tryGetComponentsFromTableMaybe table componentId =   do     columns <- readIORef table.columns@@ -355,14 +352,14 @@       Just column -> do         results <- tryGetComponentsFromColumn @c column         entities <- Vec.toList table.entities-        return $ zipWith (\x e -> (e, Just $ Result (x, e))) results (map fst entities)+        return $ zipWith (\x e -> (e, Just x)) results (map fst entities) -tryGetRelCollectionsFromArchetype :: forall c. (Component c) => ArchetypeId -> IOVec Table -> ComponentId -> IO [(Entity, [Result (Rel c)])]+tryGetRelCollectionsFromArchetype :: forall c. (Component c) => ArchetypeId -> IOVec Table -> ComponentId -> IO [(Entity, [Rel c])] tryGetRelCollectionsFromArchetype archetype tables componentId = do   table <- Vec.unsafeRead tables archetype.id   tryGetRelCollectionsFromTable table componentId -tryGetComponentsFromArchetype :: forall c. (Component c) => ArchetypeId -> IOVec Table -> ComponentId -> IO [(Entity, Result c)]+tryGetComponentsFromArchetype :: forall c. (Component c) => ArchetypeId -> IOVec Table -> ComponentId -> IO [(Entity, c)] tryGetComponentsFromArchetype archetype tables componentId = do   table <- Vec.unsafeRead tables archetype.id   tryGetComponentsFromTable table componentId@@ -372,18 +369,18 @@   table <- Vec.unsafeRead tables archetype.id   tryGetEntitiesFromTable table -tryGetComponentsFromArchetypeMaybe :: forall c. (Component c) => ArchetypeId -> IOVec Table -> ComponentId -> IO [(Entity, Maybe (Result c))]+tryGetComponentsFromArchetypeMaybe :: forall c. (Component c) => ArchetypeId -> IOVec Table -> ComponentId -> IO [(Entity, Maybe c)] tryGetComponentsFromArchetypeMaybe archetype tables componentId = do   table <- Vec.unsafeRead tables archetype.id   tryGetComponentsFromTableMaybe table componentId -tryGetRelCollectionsFromTables :: forall c. (Component c) => Tables -> [ArchetypeId] -> ComponentId -> IO [(Entity, [Result (Rel c)])]+tryGetRelCollectionsFromTables :: forall c. (Component c) => Tables -> [ArchetypeId] -> ComponentId -> IO [(Entity, [Rel c])] tryGetRelCollectionsFromTables (Tables tables) archetypes componentId =   do     results <- mapM (\archetype -> tryGetRelCollectionsFromArchetype archetype tables componentId) archetypes     return $ concat results -tryGetComponentsFromTables :: forall c. (Component c) => Tables -> [ArchetypeId] -> ComponentId -> IO [(Entity, Result c)]+tryGetComponentsFromTables :: forall c. (Component c) => Tables -> [ArchetypeId] -> ComponentId -> IO [(Entity, c)] tryGetComponentsFromTables (Tables tables) archetypes componentId =   do     results <- mapM (\archetype -> tryGetComponentsFromArchetype archetype tables componentId) archetypes@@ -395,53 +392,53 @@     results <- mapM (`tryGetEntitiesFromArchetype` tables) archetypes     return $ concat results -tryGetComponentsFromTablesMaybe :: forall c. (Component c) => Tables -> [ArchetypeId] -> ComponentId -> IO [(Entity, Maybe (Result c))]+tryGetComponentsFromTablesMaybe :: forall c. (Component c) => Tables -> [ArchetypeId] -> ComponentId -> IO [(Entity, Maybe c)] tryGetComponentsFromTablesMaybe (Tables tables) archetypes componentId =   do     results <- mapM (\archetype -> tryGetComponentsFromArchetypeMaybe archetype tables componentId) archetypes     return $ concat results -newtype Result c = Result (c, Entity)+-- newtype Result c = Result (c, Entity) -data ErasedResult where-  ErasedResult :: Result c -> ErasedResult+-- data ErasedResult where+--   ErasedResult :: Result c -> ErasedResult -value :: Result c -> c-value (Result (c, _)) = c+-- value :: Result c -> c+-- value (Result (c, _)) = c -type family IsComp a where-  IsComp (Rel a) = False-  IsComp a = True+-- type family IsComp a where+--   IsComp (Rel a) = False+--   IsComp a = True -entityOf :: Result c -> Entity-entityOf (Result (_, e)) = e+-- entityOf :: Result c -> Entity+-- entityOf (Result (_, e)) = e -instance (Show c) => Show (Result c) where-  show :: Result c -> String-  show = show . value+-- instance (Show c) => Show (Result c) where+--   show :: Result c -> String+--   show = show . value -instance (Eq c) => Eq (Result c) where-  (==) :: Result c -> Result c -> Bool-  (==) a b = value a == value b+-- instance (Eq c) => Eq (Result c) where+--   (==) :: Result c -> Result c -> Bool+--   (==) a b = value a == value b -instance (Ord c) => Ord (Result c) where-  compare :: Result c -> Result c -> Ordering-  compare a b = compare (value a) (value b)+-- instance (Ord c) => Ord (Result c) where+--   compare :: Result c -> Result c -> Ordering+--   compare a b = compare (value a) (value b) -instance (HasField a b c) => HasField a (Result b) c where-  getField a = getField @a (value a)+-- instance (HasField a b c) => HasField a (Result b) c where+--   getField a = getField @a (value a) -class DeepValue' flag c i | flag c -> i where-  deepValue' :: c -> i+-- class DeepValue' flag c i | flag c -> i where+--   deepValue' :: c -> i -instance DeepValue' True (Result c) c where-  deepValue' = value+-- instance DeepValue' True (Result c) c where+--   deepValue' = value -instance DeepValue' False (Result (Rel c)) c where-  deepValue' x = x.comp+-- instance DeepValue' False (Result (Rel c)) c where+--   deepValue' x = x.comp -class DeepValue c i | c -> i where-  deepValue :: c -> i+-- class DeepValue c i | c -> i where+--   deepValue :: c -> i -instance (DeepValue' (IsComp c) (Result c) i) => DeepValue (Result c) i where-  deepValue = deepValue' @(IsComp c)+-- instance (DeepValue' (IsComp c) (Result c) i) => DeepValue (Result c) i where+--   deepValue = deepValue' @(IsComp c)

@@ -1,47 +1,98 @@ module Mischief.ECS.Time where  import Control.Monad.IO.Class-import GHC.Records (HasField (getField))-import Mischief.ECS.App+import Data.Data+import Data.Function ((&))+import Data.Vector.Internal.Check (HasCallStack) import Mischief.ECS.App.Plugins import Mischief.ECS.App.Schedules import Mischief.ECS.Components import Mischief.ECS.Resources-import Mischief.ECS.Systems qualified as Systems-import Mischief.ECS.Tables+import Mischief.ECS.Systems import Mischief.ECS.Utils import Mischief.ECS.World-import Mischief.ECS.World.Insert-import Mischief.ECS.World.Modify import Mischief.ECS.World.Query-import Mischief.ECS.World.Query.Queryable+import Mischief.ECS.World.Query.Pipe import System.Clock +class ToTime t where+  toTime :: t -> Time+ data Time = Time   { delta :: TimeSpec,     elapsed :: TimeSpec   }++data VirtualTime = VirtualTime+  { virtualDelta :: TimeSpec,+    virtualElapsed :: TimeSpec+  }   deriving (Show, Component) -time :: System Time-time = unwrap <$> res @Time+data TimeTypePref -deltaTime :: System Float-deltaTime = deltaSecs <$> time+instance PrefType TimeTypePref TimeTag -deltaSecs :: Time -> Float-deltaSecs Time {delta} = fromIntegral delta.sec + fromIntegral delta.nsec / 1000000000+instance ToTime VirtualTime where+  toTime v = Time {delta = v.virtualDelta, elapsed = v.virtualElapsed} -data TimePlugin = TimePlugin deriving (Eq)+data TimeTag where+  TimeTag :: (Component t, ToTime t) => Proxy t -> TimeTag +time :: (HasCallStack) => (MonadSystem w m) => m Time+time = do+  pref <- getPref @TimeTypePref+  case pref of+    Nothing -> toTime . unwrap <$> res @VirtualTime+    Just (TimeTag (_ :: Proxy t)) -> toTime . unwrap <$> res @t++timeMaybe :: (MonadSystem w m) => m (Maybe Time)+timeMaybe = do+  pref <- getPref @TimeTypePref+  case pref of+    Nothing -> fmap toTime <$> res @VirtualTime+    Just (TimeTag (_ :: Proxy t)) -> fmap toTime <$> res @t++qtime :: (MonadSystem w m) => Query m Time+qtime = pure () & qtraverse (\_ _ -> time)++delta :: (HasCallStack) => (MonadSystem w m) => m Float+delta = do+  time <- time+  pure $ specToSecs time.delta++qdelta :: (MonadSystem w m) => Query m Float+qdelta = pure () & qtraverse (\_ _ -> delta)++elapsed :: (HasCallStack) => (MonadSystem w m) => m Float+elapsed = do+  time <- time+  pure $ specToSecs time.elapsed++qelapsed :: (MonadSystem w m) => Query m Float+qelapsed = pure () & qtraverse (\_ _ -> elapsed)++specToSecs :: TimeSpec -> Float+specToSecs a = fromIntegral a.sec + fromIntegral a.nsec / 1000000000++secsToSpec :: Float -> TimeSpec+secsToSpec s =+  let secs = floor s+   in TimeSpec secs $ floor ((s - fromIntegral secs) * 1000000000)++-- | Plugin that keeps track of time. Enables calling 'delta', 'elapsed', and so on.+--+-- Note that these methods are context-dependent. For instance, if used in a Fixed schedule, 'delta' will always return the time as inferred from the fixed frequency.+data TimePlugin+ instance Plugin TimePlugin where-  init _ = do+  init = do     currentTime <- liftIO $ getTime Monotonic-    insertRes $ Time {delta = TimeSpec {sec = 0, nsec = 0}, elapsed = currentTime}-    Systems.add First updateTime+    insertRes $ VirtualTime {virtualDelta = TimeSpec {sec = 0, nsec = 0}, virtualElapsed = currentTime}+    schedule @First (systems updateTime)  updateTime :: System () updateTime = do-  Just time <- res @Time+  Just time <- res @VirtualTime   currentTime <- liftIO $ getTime Monotonic-  insertRes Time {delta = currentTime - time.elapsed, elapsed = currentTime}+  insertRes VirtualTime {virtualDelta = currentTime - time.virtualElapsed, virtualElapsed = currentTime}

@@ -1,12 +1,16 @@ module Mischief.ECS.Timer where +-- | A type that can be used to keep track of time. data Timer = Timer {duration :: Float, elapsed :: Float, mode :: Mode} +-- | A mode for the 'Timer'. Being set to Repeat will mean the timer loops around once it finishes, while being set to Once will make it stop completely after one finish. data Mode = Once | Repeat +-- | Create a new Timer specifying its duration in seconds and its mode. new :: Float -> Mode -> Timer new duration mode = Timer {duration, mode, elapsed = 0} +-- | Tick a timer by a certain duration. Will return the new state of the timer, as well as a bool signaling whether it has just finished or not. tick :: Float -> Timer -> (Timer, Bool) tick _ timer | timer.elapsed >= timer.duration = (timer, False) tick x timer | timer.elapsed + x < timer.duration = (timer {elapsed = timer.elapsed + x}, False)

@@ -1,179 +0,0 @@-{-# OPTIONS_GHC -Wno-unused-imports #-}---- |--- Module: Systems Tutorial--- Description: Tutorial on using @Systems@------ This module contains a more in-depth look into the @Mischief App and Plugins@.------ It isn't as technically interesting as the other chapters of the tutorial, focusing more on organization and high-level logic.------ [Previous Chapter: Coding a Dungeon Game]("Mischief.ECS.Tutorial.Dungeon")------ [Next Chapter: Components]("Mischief.ECS.Tutorial.Components")------ [Main Page]("Mischief.ECS")-module Mischief.ECS.Tutorial.App-  ( -- * Learn You an ECS for Great Mischief! - 3. App and Plugins-    -- $intro--    -- * Modular Features-    -- $modular_features--    -- * Initialization-    -- $init--    -- * Plugin Resolution-    -- $resolution--    -- * [Next chapter: Components]("Mischief.ECS.Tutorial.Components")-  )-where--import Control.Monad.Reader-import Mischief.ECS---- $intro--- The @'App'@ is a thin wrapper around the @'World'@ that works as an interface for plugging in--- various behavior and features in modular fashion, via @Plugins@.------ A Mischief game / app usually starts by creating an app with a main plugin and then running it.------ @--- main :: 'IO' ()--- main = do---   app <- 'newApp' myPlugin---   'runApp' app------ data MainPlugin = MainPlugin deriving ('Eq')------ instance 'Plugin' MainPlugin where---   'Msichief.ECS.App.Plugins.init' _ = 'info' \"Hello!\"--- @------ From that initial plugin you can add other plugins, each adding new features to your game.------ A @Plugin p@ instance has two optional functions:------ 1. An initialization system that will be ran at the very beginning of the app.------ @--- 'Mischief.ECS.App.Plugins.init' :: p -> 'System' ()--- @------ 2. A collection of plugins that will be added along with this plugin.------ @--- 'plugins' :: p -> 'Plugins'--- @------ The collection of plugins can be created using the @plug@ helper function.------ @--- 'plugins' _ = 'plug' (FooPlugin, BarPlugin, BazPlugin)--- @------ Additionally, each @Plugin@ also requires an @Eq@ instance, which we'll talk about later.---- $modular_features--- Mischief is intended to let you cleanly separate and organize your logic.------ For instance, you may have a @PhysicsPlugin@ that adds physics to your game, a @RenderPlugin@ which renders objects, a @LevelPlugin@ that spawns your levels.------ @--- instance 'Plugin' MainPlugin where---   'plugins' _ = 'plug' (PhysicsPlugin, RenderPlugin, LevelPlugin)--- @------ Ideally, each of these plugins would add their own independent features. So, if you were to remove @physicsPlugin@, your entities simply wouldn't--- move and collide anymore, but the rest of the app would work just fine.------ Note that, internally, @PhsyicsPlugin@ could also be subdivided into its own plugins with separate roles:------ @--- data PhysicsPlugin = PhysicsPlugin deriving ('Eq')------ instance 'Plugin' PhysicsPlugin where---   'plugins' _ = 'collect' (CollisionPlugin, MovePlugin)--- @------ This also lets the various packages of @Mischief@ be modular, and makes it easy for third party library developers to create plugins that you just plug into your app with ease!---- $init--- So what exactly can you do within the @init@ function of a @Plugin@?------ The answer is, pretty much anything.------ As the name suggests, it is typically used for initializing some sort of logic or behavior within your app. This is--- usually done by scheduling systems, inserting some resource, and spawning important entities, such as observers.------ @--- 'Mischief.ECS.App.Plugins.init' _ = do---   [Systems]("Mischief.ECS.Systems").'Mischief.ECS.Systems.add' $ 'Update' foo '`after`' bar---   [Systems]("Mischief.ECS.Systems").'Mischief.ECS.Systems.add' $ 'Startup' baz------   'insertRes' $ SomeRes 5--- @------ Note that the initialization systems are guaranteed to run before everything else in the app, /but/ there is no guarantee of order between them.--- So, a Plugin should /never/ depend on another Plugin being added before it.------ Additionally, everything that can be done in @init@ can be done the same in a normal system. There's nothing making it unique!---- $resolution--- Have you noticed that the 'Plugin' typeclass requires the type to also derive 'Eq'? Let's dig into that.------ To give a practical example, think of an @SDLPlugin@ which initializes an @SDL@ program, opening--- an actual window and allowing for things such as collecting input and rendering stuff.------ @--- data SDLPlugin = SDLPlugin deriving ('Eq')------ instance 'Plugin' SDLPlugin where---   'Mischief.ECS.App.Plugins.init' _ = createSDLWindow (Resolution (500, 500))--- @------ Two separate Plugins exist, an @InputPlugin@ which handles reading input events, and a @RenderPlugin@ which handles processing shaders and rendering.--- Both those Plugins need @SDLPlugin@ to function properly.------ @--- data InputPlugin = InputPlugin deriving ('Eq')------ instance 'Plugin' InputPlugin where---   'plugins' _ = 'plug' SDLPlugin------ data RenderPlugin = RenderPlugin deriving ('Eq')------ instance 'Plugin' RenderPlugin where---   'plugins' _ = 'plug' SDLPlugin--- @------ So it's a handy feature to have multiple plugins depend on the same plugin. But what if @SDLPlugin@ looked like this:------ @--- data SDLPlugin = SDLPlugin {res :: ('Int', 'Int')} deriving ('Eq')------ instance 'Plugin' SDLPlugin where---   'Mischief.ECS.App.Plugins.init' (SDLPlugin {res}) = createSDLWindow (Resolution res)--- @------ @SDLPlugin@ now produces different effects based on its value. This means there is a possibility that the following happens:------ @--- data InputPlugin = InputPlugin deriving ('Eq')------ instance 'Plugin' InputPlugin where---   'plugins' _ = 'plug' (SDLPlugin (300, 300))------ data RenderPlugin = RenderPlugin deriving ('Eq')------ instance 'Plugin' RenderPlugin where---   'plugins' _ = 'plug' (SDLPlugin (500, 500))--- @------ What if you were to add both @InputPlugin@ and @RenderPlugin@ to your app? Which variant of @SDLPlugin@ would it pick?------ This conflict is why the @Plugin@ typeclass requires @Eq@. When the same plugin is added into the app twice,--- their two values will be compared and, if equal, the plugin will be added, otherwise the app will panic.------ This ensures a level of control over how plugins do their initialization, without forcing a plugin to only be added from one source.

@@ -1,573 +0,0 @@-{-# OPTIONS_GHC -Wno-unused-imports #-}---- |--- Module: Components Tutorial--- Description: Tutorial on using @Components@------ This module contains a more in-depth tutorial on @Mischief Components@.------ [Previous Chapter: App and Plugins]("Mischief.ECS.Tutorial.App")------ [Next Chapter: Relationships]("Mischief.ECS.Tutorial.Relationships")------ [Main Page]("Mischief.ECS")-module Mischief.ECS.Tutorial.Components-  ( -- * Learn You an ECS for Great Mischief! - 4. Components-    -- $introduction--    -- * The Name Component-    -- $name--    -- * Operations-    -- $ops--    -- * Query Results-    -- $results--    -- * Change Detection-    -- $change--    -- * Meta Components-    -- $meta--    -- * Resources-    -- $resources--    -- * Required Components-    -- $required--    -- * Registering Components-    -- $reg--    -- * Examples-    -- $examples--    -- * [Next Chapter: Relationship]("Mischief.ECS.Tutorial.Relationships")-  )-where--import Control.Monad (void)-import Data.Default (Default (def))-import Data.Foldable-import GHC.Generics (Generic)-import GHC.Records (HasField)-import Mischief.ECS---- $introduction--- A component is any type which derives the 'Component' typeclass. They can be both carriers of data or marker components used for querying (Tags from Flecs):------ Component that carries data.------ @--- data Health = Health 'Int' deriving ('Component')--- @------ Marker components.------ @--- data Player = Player deriving ('Component')--- data Enemy = Enemy deriving ('Component')--- @---- $name--- @Name@ is a special component provided by Mischief that is internally added to every spawned entity, based on its @Entity@ index,--- if none is provided on spawn. It can be, of course, changed at any time.------ @--- newtype Name = Name 'String' deriving ('Component')--- @------ Consider this system that prints the name of a given Entity:------ @--- printName :: 'Entity' -> 'System' ()--- printName e = 'info' . 'text' '=<<' 'get' ('C' \@'Name') e--- @------ Notice how the Names behave here:------ @--- foo <- 'spawn' ()--- printName foo------ insert ('Name' \"Foo\") foo--- printName foo------ bar <- 'spawn' ('Name' \"Bar\")--- printName bar--- @------ @--- >> [INFO] Just \"Entity 15v1\"--- >> [INFO] Just \"Foo\"--- >> [INFO] Just \"Bar\"--- @---- $ops------ Mischief offers various @operations@ for inserting and manipulating data into the ECS:------ * You can spawn entities as bundles of components:------ @--- player <- 'spawn' (Name \"Player\", Player)--- @------ * You can insert components on existing entities:------ @--- 'insert' (Name \"New Player Name\", Health 100)--- @------ * You can remove components:------ @--- 'remove' ('C' \@Health, 'C' \@Player) player--- @------ * You can despawn entities:------ @--- 'despawn' player--- @------ Additionally, @insert@ has a couple of variants:------ * @'insertNew'@ only inserts components that aren't already on the entity.--- * @'insertIfNeq'@ only insert components if they aren't on the entity of if their value differs from the current one.---- $results--- A @Result c@ is a wrapper around the component @c@ that's produced by a query. We will discuss querying itself more in the [Query Chapter]("Mischief.ECS.Tutorial.Queries").------ @--- health <- 'get' ('C' \@Health) player--- @------ @--- health :: 'Result' Health--- @------ There are a number of useful operations that can be done on a @Result@:------ * Set a new value for this component.------ @--- 'set' health (Health 100)--- @------ * Modify the value of this component.------ @--- 'modify' health (\(Health x) -> Health (x + 1))--- @------ * Remove the component from the entity.------ @--- 'delete' health--- @------ Note that these functions just call the @insert@, @remove@, etc. operations.------ So these two are equivalent, performance-wise:------ @--- health <- 'query' ('C' \@Health)------ 'for_' health $ \(health) -> do---   'modify' health $ \(Health x) -> Health (x + 1)--- @------ @--- health <- 'query' ('C' \@Health, 'E')------ 'for_' health $ \((Health x), entity) -> dox---   'insert' (Health (x + 1)) entity--- @------ Or, if you prefer compact code:------ @--- 'query' ('C' \@Health) '>>=' 'traverse_' ('`modify`' (\(Health x) -> Health (x + 1)))--- @------ You can use the @value@ function to obtain the inner value of a Result.------ @--- 'value' :: 'Result' c -> c--- @------ For instance:------ @--- 'Just' name <- 'get' ('C' \@Name) e--- let name' = 'value' name--- @------ @--- name  :: 'Result' Name--- name' :: Name--- @------ You can also use @Val@ to automatically unwrap the value of a Result:------ @--- 'Just' name <- 'get' ('C' \@Name) e--- @------ @--- name :: Name--- @------ If the component has record fields, every field will be inherited by the 'Result' (via a 'HasField' instance)------ @--- data Pos = Pos {x :: 'Float', y :: 'Float'}--- @------ @--- 'Just' pos <- 'get' @Pos e--- let x = pos.x--- let y = pos.y--- @------ @--- pos :: 'Result' Pos--- x   :: 'Float'--- y   :: 'Float'--- @------ Some typeclasses, namely 'Show', 'Eq', 'Ord' are also implemented for a @Result c@ if they are for the underlying @c@.------ Note that the value of a @Result@ is the value gotten at the time of querying. It could be outdated, in case the live value--- was changed after querying. You can use @update@ to get the live value for a Result:------ @--- name <- 'update' name--- @---- $meta--- Each component has a corresponding entity in the World.--- The components on that entity store information about the component itself. Such as which archetypes it is part of.------ A component's entity can be accessed by using @meta@.------ Getting the entities of the @Name@ and @Player@ components:------ @--- x <- 'meta' \@Name--- y <- 'meta' \@Player--- @------ Most users should avoid tinkering with Meta Components unless they have a good reason to,--- and should absolutely never remove or change any components added to them by the @ECS@.---- $resources--- @Resources@ are singleton components that can be easily accessed and modified from any system.------ Any component can be used as a resource.------ @--- data MyRes = MyRes 'Int' deriving ('Component')--- @------ You can insert a resource into the World using @insertRes@.------ @--- 'insertRes' $ MyRes 5--- @------ And you can query for the value of a resource using @res@:------ @--- 'Just' myRes <- 'res' \@MyRes--- @------ @res r@ returns a @'Maybe' r@ because it's possible for the resource to not have been inserted yet.------ Resources are implemented by inserting a component's value on its own meta entity.------ @'res' \@MyRes@ is the same as doing:------ @--- m <- 'meta' \@MyRes--- 'get' ('C' \@MyRes) m--- @---- $required--- Each component can @require@ a bundle of other components.------ @--- data Player = Player------ instance 'Component' Player where---   'required' = 'require' \@(Position, Health)--- @------ This means that each time @Player@ is added to an entity, a /default/ @Position@ and @Health@ will also be inserted, if they aren't already present.------ In order for a component to be required by another, it must instance the @Default@ typeclass, either through a @Generic@ derive or a custom instance.------ @--- data Position = Position 'Int' 'Int' deriving ('Component', 'Generic', 'Default')--- @------ @--- data Health = Health 'Int' deriving ('Component')------ instance 'Default' Health where---   'def' = Health 100--- @------ Requirements are transitive (if @A requires B@ and @B requires C@, then @A requires C@) and /can/ contain cycles.------ A requirement is added to the ECS as a @'RequiredBy'@ \/ @'Requires'@ relationship between the components' entities.---- $reg--- @Registering@ a component involves spawning its meta entity and adding the corresponding data.------ Each component is registered automatically the first time it is inserted on an Entity, so you don't usually--- have to worry about registration.------ Queries are also smart about components; if you query or filter for a component hasn't been registered yet, they will just--- assume that component can't be be on any Entity. Queries can't perform registration themselves, because they're not allowed to mutate--- the world in any way------ However, there may be /extremely/ niche situations where you want to register components earlier than normal, which is where manual registration comes in:------ @--- 'register' \@(Player, Health, Position)--- @------ One such situation could be wanting to check the requirements in-between multiple components.--- If a component hasn't been registered yet, it won't show up when you query for components that require a specific component.---- $change--- @Change detection@ can be done in two ways: @Observers@ and @Filters@.------ === Observers------ Observers can listen to the @'OnInsert'@ and @'OnRemove'@ event:------ * @OnInsert c@ is triggered each time @c@ is inserted on an entity. This event is also triggered when a--- component is re-inserted / changed, meaning this isn't a reliable way to determine if a component was just added.------ @--- onNameInsert :: 'OnInsert' 'Name' -> 'System' ()--- @------ * @OnRemove@ is triggered when a component is removed from an entity.------ @--- onNameRemove :: 'OnRemove' 'Name' -> 'System' ()--- @------ Both events have a @.entity@ field you can use to obtain the entity which it happened on.------ @--- onNameRemove :: 'OnRemove' 'Name' -> 'System' ()--- onNameRemove event = 'info' $ show event.entity <> \" has their name removed!\"--- @------ Don't forget to spawn an Observer to listen to each event.------ @--- import "Mischief.ECS.Observers" qualified as [Observers]("Mischief.ECS.Observers")--- @------ @--- 'void' $ [Observers]("Mischief.ECS.Observers").'Mischief.ECS.Observers.spawn' onNameInsert--- 'void' $ [Observers]("Mischief.ECS.Observers").'Mischief.ECS.Observers.spawn' onNameRemove--- @------ @OnInsert@ is always triggered /after/ a component has been inserted, while @OnRemove@ is triggered /before/. This--- allows you to query for the component and get its value.------ You can find more details on Observers and Events in the corresponding [Chapter]("Mischief.ECS.Tutorial.Events")------ === Filters------ Now for the other way of doing change detection: the @'Changed'@ and @'Added'@ query filters.------ With the following query:------ @--- 'query' ('C' \@'Name') ('Added' ('C' \@Player))--- @------ You will only obtain the name of entities which had the @Player@ component added to them since the current (scheduled) system last ran.------ @Added c@ will catch entities that just had @c@ added to them, while @Changed c@ will catch any insertion, similar to @OnInsert@.--- If you wish to query for entities that have had a component changed but it wasn't just added, you can do:------ @--- 'query' ('C' \@'Name') ('Changed' ('C' \@Player), 'Not' ('Added' ('C' \@Player)))--- @------ === Note on listening to changes------ One essential detail to be aware of here is that insertion (@OnInsert@ or @Changed@) doesn't necessarily mean a component's value has been changed!------ The following @insert@ /will/ trigger change detection:------ @--- p <- 'spawn' (Health 100)--- 'insert' (Health 100) p--- @------ To avoid this, you can derive 'Eq' on your components and use @'insertIfNeq'@ and @'setIfNeq'@, which will only perform insertion if the value of the component is different--- from the current one.---- $hooks--- @Component hooks@ are events associated directly to a Component instance.------ @--- instance Component Foo where---   hooks :: 'Hooks' Foo---   hooks = 'collect' (onInsertFoo, onRemoveFoo, customFoo)------ onInsertFoo :: 'OnInsert' Foo -> 'System' ()--- onInsertFoo = ...------ onRemoveFoo :: 'OnRemove' Foo -> 'System' ()--- onRemoveFoo = ...------ data SomeCustomEvent a deriving ('Event')--- customFoo :: SomeCustomEvent Foo -> 'System' ()--- customFoo = ...--- @------ A Hook on component @c@ can be any function that looks like @('Event' e) => e c -> 'System' ()@.------ Hooks are registered along with their respective component.---- $examples------ This section contains a few chunkier examples that combine the notions from this entire chapter.------ === __Example 1__--------- An example showing different operations that spawn and alter entities.------ @--- import "Mischief.ECS.Prelude"------ data CompA = CompA 'Int' 'Int' deriving ('Component', 'Show')------ data CompB = CompB 'String' deriving ('Component', 'Show')------ data CompC = CompC deriving ('Component', 'Show')------ main :: 'IO' ()--- main = do---   app <- 'newApp' MainPlugin---   'runApp' app------ data MainPlugin = MainPlugin deriving ('Eq')------ instance 'Plugin' MainPlugin where---   'Mischief.ECS.App.Plugins.init' _ = do---     foo <- 'spawn' (Name \"Foo\", CompA 10 10, CompB \"Component B on Foo\", CompC)---     bar <- 'spawn' (Name \"Bar\", CompA 15 3,  CompB \"Component B on Bar\")---     baz <- 'spawn' (Name \"Baz\", CompA 0 0,   CompB \"Component B on Baz\", CompC)------     'info' . 'text' '=<<' 'query' ('C' \@Name, 'C' \@CompA, 'M' \@CompB, 'M' \@CompC)------     'insert' (Name \"Foo2\", CompA 100 100, CompC) foo---     'remove' ('C' \@CompC, 'C' \@CompB) baz---     'despawn' bar------     'info' . 'text' '=<<' 'query' ('C' \@Name, 'C' \@CompA, 'M' \@CompB, 'M' \@CompC)--- @------ @--- >> [Info] [---   (\"Foo\", CompA 10 10, Just CompB \"Component B on Foo\", Just CompC),---   (\"Baz\", CompA 0 0,   Just CompB \"Component B on Baz\", Just CompC),---   (\"Bar\", CompA 15 3,  Just CompB \"Component B on Bar\", Nothing)--- ]------ >> [Info] [---   ("\Foo2\", CompA 100 100, Just CompB \"Component B on Foo\", Just CompC),---   (\"Baz\",  CompA 0 0,     Nothing, Nothing)--- ]--- @------ === __Example 2__------ This example shows you how to make a resource that independently tracks the number of Players in the World.------ @--- data PlayerCount = PlayerCount 'Int' deriving ('Component', 'Show')------ changeCount :: 'Int' -> PlayerCount -> PlayerCount--- changeCount n (PlayerCount x) = PlayerCount (x + n)--- @------ We need to write a system that queries all entities that have had a @Player@ component added to them and updates @PlayerCount@ accordingly:------ @--- updateCount :: 'System' ()--- updateCount = do---   x <- 'query'' 'E' ('Added' \@Player)------   count <- 'res' \@PlayerCount---   'modify' count $ changeCount ('length' x)--- @------ We couldn't have used an observer for this since 'OnInsert' also catches re-insertions.------ We'll also make an Observer that listens to the @OnRemove@ event to update @PlayerCount@:------ @--- handlePlayerRemove :: 'OnRemove' Player -> 'System' ()--- handlePlayerRemove _ = do---   count <- 'res' \@PlayerCount---   'modify' count $ changecount (-1)--- @------ I also wrote this system that spawns 3 Players and despawns one of them each frame, to make sure both the previous sytems works fine.------ @--- spawnPlayers :: 'System' ()--- spawnPlayers = do---   ('info' . 'text') '=<<' 'res' \@PlayerCount------   p <- 'spawn' Player---   'void' $ 'spawn' Player---   'void' $ 'spawn' Player------   'despawn' p--- @------ Now let's write a a simple app that makes use of these systems:------ @--- import "Mischief.ECS.Systems" qualified as [Systems]("Mischief.ECS.Systems")--- import "Mischief.ECS.Observers" qualified as [Observers]("Mischief.ECS.Observers")------ data Player = Player deriving ('Component')------ main :: 'IO' ()--- main = do---   app <- 'newApp' MainPlugin---   'runApp' app------ data MainPlugin = MainPlugin deriving ('Eq')------ instance 'Plugin' MainPlugin where---   'Mischief.ECS.App.Plugins.init' _ = do---     'insertRes' $ PlayerCount 0---     [Systems]("Mischief.ECS.Systems").'Mischief.ECS.Systems.add' 'Update' (updateCount, spawnPlayers)---     'void' $ [Observers]("Mischief.ECS.Observers").'Mischief.ECS.Observers.spawn' handlePlayerRemove--- @------ Running it will result in:------ @--- [INFO] Just (PlayerCount 0)--- [INFO] Just (PlayerCount 2)--- [INFO] Just (PlayerCount 4)--- ...--- @

@@ -1,1229 +0,0 @@-{-# OPTIONS_GHC -Wno-unused-imports #-}---- |--- Module: Components Tutorial--- Description: Introductory Tutorial------ This module walks the user through creating a small game in the terminal.------ [Previous Chapter: Startup Guide]("Mischief.ECS.Tutorial.Startup")------ [Next Chapter: App and Plugins]("Mischief.ECS.Tutorial.App")------ [Main Page]("Mischief.ECS")-module Mischief.ECS.Tutorial.Dungeon-  ( -- * Learn You an ECS for Great Mischief! - 2. Coding a Dungeon Game-    -- $intro--    -- * Creating an App-    -- $creation--    -- * Spawning the Grid-    -- $grid--    -- * Traversing the Grid-    -- $traversing--    -- * Spawning the Player-    -- $player--    -- * Adding Walls-    -- $walls--    -- * Moving the Player-    -- $move--    -- * Displaying the Grid-    -- $display--    -- * Generating Random Positions-    -- $rand--    -- * Adding Enemies-    -- $enemies--    -- * Moving Enemies-    -- $moveE--    -- * Enemy Collision-    -- $collision--    -- * Health-    -- $health--    -- * Quitting-    -- $quit--    -- * Taking Damage-    -- $dmg--    -- * Spawning Coins-    -- $coins--    -- * Collecting Coins-    -- $collect--    -- * Next Steps-    -- $next--    -- * [Next Chapter: App and Plugins]("Mischief.ECS.Tutorial.App")-  )-where--import Control.Monad (unless, void, when)-import Control.Monad.IO.Class (MonadIO (liftIO))-import Data.Default (Default)-import Data.Foldable (for_)-import Data.List ((!?))-import Data.Traversable (for)-import Mischief.ECS-import System.Exit (exitSuccess)---- $intro--- This module will walk you through creating a simple terminal-based dungeon crawler in Mischief.--- The goal is to have a player which we can freely move on a 2D grid, as well as various objects placed on tiles,--- such as enemies, coins, obstacles, etc.------ If you'd rather go straight to learning about particular features rather than learning by example, feel free to skip to the next chapters.--- You can always come back to this one once you have a better understanding of things.------ Each section in this chapter adds its own isolated mechanics to the game, so there's no harm in reading up to a point and taking a break or--- starting another chapter.---- $creation--- Let's start by creating our App and a Main Plugin which will serve as the starting point of all our logic.------ @--- import "Mischief.ECS.Prelude"------ main :: 'IO' ()--- main = do---   app <- 'newApp' MainPlugin---   'runApp' app------ data MainPlugin = MainPlugin deriving ('Eq')------ instance 'Plugin' MainPlugin where---   'Mischief.ECS.App.Plugins.init' _ = 'info' \"Hello World!\"--- @------ If you run this program you should see \"Hello World!\" logged to the terminal.---- $grid--- The game will play out on a small 2D grid. There are many ways of representing this Mischief, the way I've chosen to do it--- is by having each tile of the grid be an entity, and the full list of entities stored in a global resource.------ The @Tile@ component will be used to mark which entities are tiles:------ @--- data Tile = Tile deriving ('Component')--- @------ Each tile will also have a @Pos@ component containing it's position on the grid:------ @--- data Pos = Pos ('Int', 'Int') deriving ('Component')--- @------ @Grid@ will be the resource containing the (bidimensional) list of all tile entities:------ @--- data Grid = Grid [['Entity']] deriving ('Component')--- @------ I've written two functions returning the width and height of the grid:------ @--- gridH :: 'Int'--- gridH = 10------ gridW :: 'Int'--- gridW = 20--- @------ Let's write a system that spawns the tiles and initializes the grid resource:------ @--- spawnGrid :: 'System' ()--- spawnGrid = do---   tiles \<----     'for' [0 .. gridH - 1] $ \\i -\>---       'for' [0 .. gridW - 1] $ \\j -\>---         'spawn' (Tile, Pos (i, j))------   'insertRes' $ Grid tiles--- @------ @insertRes@ inserts the component as a singleton resource into the ECS. We can grab its value at any time by using @res \@Grid@.------ Now we just need to modify @MainPlugin@ so that it schedules @spawnGrid@ to happen when the app starts.------ @--- import "Mischief.ECS.Systems" qualified as [Systems]("Mischief.ECS.Systems")------ instance 'Plugin' MainPlugin where---   'Mischief.ECS.App.Plugins.init' _ = [Systems]("Mischief.ECS.Systems").'Mischief.ECS.Systems.add' 'Startup' spawnGrid--- @---- $traversing--- Next, we need to code a way for traversing between adjacent tiles. Having a tile entity, we should have easy access to the entities found above, below, to the left and right of it.------ First, I've written this function which gets an entity by position:------ @--- getTile :: ('Int', 'Int') -> 'System' ('Maybe' 'Entity')--- getTile (x, y) = do---   grid <- 'res' @Grid---   'pure' $ do---     Grid tiles <- grid---     line <- tiles '!?' x---     line '!?' y--- @------ Now we can write a function that gets the position of a given tile and finds tiles offset by a certain amount:------ @--- moveBy :: ('Int', 'Int') -> 'Entity' -> 'System' ('Maybe' 'Entity')--- moveBy (x, y) entity = do---   'Just' pos <- 'get' ('C' \@Pos) entity---   let (Pos (x', y')) = 'value' pos---   getTile (x' + x, y' + y)--- @------ Queries will be explained in-depth later, but what happens essentially is that, our query returns a @Result Pos@ for the given entity, and--- we get and unwrap the inner @Pos@ value using the @'value'@ function.------ We can completely bypass this by just using the @Val@ query transformer which unwraps the @Result@ for us:------ @--- moveBy (x, y) entity = do---   'Just' (Pos (x', y')) <- 'get' ('Val' ('C' \@Pos)) entity---   getTile (x' + x, y' + y)--- @------ We can compress the code even further by using @quasi-queries@. They are macros which allow us to write queries in faster, easier ways.--- They will be explained in a further chapter, but should be pretty easy to understand at an intuitive level. For instance, we can replace--- the above @get@ with the @g@ quasi-query:------ @--- moveBy (x, y) entity = do---   'Just' (Pos (x', y')) <- ['g'|*Pos|] entity---   getTile (x' + x, y' + y)--- @------ The @*@ is the quasi equivalent of @Val@, although it can also just be written as @Val@ or @val@ if you prefer.---- $player--- Our game needs a player, so we should have a component that uniquely identifies it:------ @--- data Player = Player deriving ('Component')--- @------ We should also have a relationship to associate an entity to a tile, teling us that it's currently placed on that tile.------ @--- data OnTile = OnTile deriving ('Component')--- @------ Additionally, an entity should only be able to be on a single tile at a time. Mischief has a convenient way of doing this hidden in the @Component@ class:------ @--- instance 'Component' OnTile where---   'isExclusiveRel' = True--- @------ This means that if we insert a new @OnTile@ relationship to the player, the old one will be automatically removed.------ Anyway, it's finally time to spawn our player:------ @--- spawnPlayer :: 'System' ()--- spawnPlayer = do---   'Just' tile <- getTile (5, 5)---   _ <- 'spawn' (Player, 'Rel' OnTile tile)---   'pure' ()--- @------ @Rel OnTile tile@ inserts the @(OnTile, tile)@ relationship on the player.------ We can avoid the @pure@ by just using @void@ to consume the value of @spawn@:------ @--- spawnPlayer = do---   'Just' tile <- getTile (5, 5)---   'void' $ 'spawn' (Player, 'Rel' OnTile tile)--- @------ Now we can add the player spawning logic to @Startup@:------ @--- instance 'Plugin' MainPlugin where---   'Mischief.ECS.App.Plugins.init' _ = do---     [Systems]("Mischief.ECS.Systems").'Mischief.ECS.Systems.add' 'Startup' spawnPlayer---     [Systems]("Mischief.ECS.Systems").'Mischief.ECS.Systems.add' 'Startup' spawnGrid--- @------ Except there's something really wrong in the logic above!--- If we run the app, we will get an error pointing us to the @Just tile <-@ in @spawnPlayer@.--- That system assumes @getTile@ will produce a valid result, but that will only happen if the grid is already initialized. Which means we want--- to guarantee that @spawnPlayer@ happens /after/ @spawnGrid@.------ We can do this by providing an explicit order when scheduling:------ @--- instance 'Plugin' MainPlugin where---   'Mischief.ECS.App.Plugins.init' _ = do---     [Systems]("Mischief.ECS.Systems").'Mischief.ECS.Systems.add' 'Startup' $ spawnPlayer '`after`' spawnGrid---     [Systems]("Mischief.ECS.Systems").'Mischief.ECS.Systems.add' 'Startup' spawnGrid--- @------ The app should now run without issues!---- $walls--- Our game will also have Walls which can block the player's movement.------ @--- data Wall = Wall deriving ('Component')--- @------ I've written a system which spawns walls and places them on the tiles around the edge of the grid:------ @--- spawnWall :: ('Int', 'Int') -> 'System' 'Entity'--- spawnWall pos = do---   'Just' tile <- getTile pos---   'spawn' (Wall, 'Rel' OnTile tile)------ spawnWalls :: 'System' ()--- spawnWalls = do---   'for_' [0 .. gridW - 1] $ \i -> spawnWall (0, i)---   'for_' [0 .. gridW - 1] $ \i -> spawnWall (gridH - 1, i)---   'for_' [1 .. gridH - 2] $ \i -> spawnWall (i, 0)---   'for_' [1 .. gridH - 2] $ \i -> spawnWall (i, gridW - 1)--- @------ The system also needs to be scheduled to run, so @MainPlugin@ now looks like this:------ @--- instance 'Plugin' MainPlugin where---   'Mischief.ECS.App.Plugins.init' _ = do---     [Systems]("Mischief.ECS.Systems").'Mischief.ECS.Systems.add' 'Startup' spawnPlayer '`after`' spawnGrid---     [Systems]("Mischief.ECS.Systems").'Mischief.ECS.Systems.add' 'Startup' (spawnGrid, spawnWalls)--- @------ Additionally, I wrote a system which checks if a given tile has a wall on it:------ @--- hasWall :: 'Entity' -> 'System' 'Bool'--- hasWall tile = do---   walls <- 'query'' 'E' ('With' ('C' \@Wall, 'R' \@OnTile tile))---   'pure' $ 'not' $ 'null' walls--- @------ @E@ just grabs the Entity of all queried entities. @With@ is a query filter that makes it so the query only iterates over entities which have those components (in this case,--- they must have @Wall@ and must have a @OnTile@ relationship to this precise tile).--- Note that @query'@ is the filtered version of @query@.------ Here's the same system but in quasi-notation:------ @--- hasWall tile = do---   walls <- ['q'|Entity / With (Wall, OnTile -\> tile)|]---   'pure' $ 'not' $ 'null' walls--- @------ We can compress it even further using @\<$\>@:------ @--- hasWall tile = 'not' . 'null' '<$>' ['q'|Entity / With (Wall, OnTile -\> tile)|]--- @---- $move--- Next, we should write a system which moves the player from one tile to another.------ First, let's write the actual logic for moving in a certain direction:------ @--- movePlayerBy :: ('Int', 'Int') -> 'System' ()--- movePlayerBy dir = do---   'Just' player <- 'single'' E ('With' ('C' \@Player))------   'Just' rel <- 'get' ('R' \@OnTile 'Any') player---   let tile = rel.target------   newTile <- moveBy dir tile------   'for_' newTile $ \t -> do---     wall <- hasWall t---     'unless' wall $ 'insert' ('Rel' OnTile t) player--- @------ Let's break it down line-by-line.--------- First, we get the entity of the player:------ @--- 'Just' player <- 'single'' E ('With' ('C' \@Player))--- @------ @single@ is a variant of @query@ which returns a @Maybe@ based on whether there is exactly one entity matching the query or not. We know there is exactly one player, and--- we know by this point it should be spawned, so doing the @Just player <-@ unwrapping is fine.------ The query could also be writtten as:------ @--- ['s'|Entity / With Player|]--- @------ Next, we get the entity of the current tile the player is on:------ @--- 'Just' rel <- 'get' ('R' \@OnTile 'Any') player--- let tile = rel.target--- @------ Querying for @R \OnTile Any@ will give us a list of all @OnTile@ relationships of the player. However, because earlier we set @OnTile@--- to be @Exclusive@, Mischief knows to only return a single relationship.------ We then use @rel.target@ to get the target entity of the relationship, which, in this case, is the tile we are looking for.------ The @get@ could also be written as:------ @--- ['g'|OnTile -\> *|] player--- @------ After, we use the earlier @moveDir@ system to get the new tile the player will be on:------ @--- newTile <- moveBy dir tile--- @------ And finally, we unwrap it (@moveBy@ returns a @Maybe Entity@), check if there is a Wall on it, and if there isn't, move the player to it.------ @--- 'for_' newTile $ \t -> do---   wall <- hasWall t---   'unless' wall $ 'insert' ('Rel' OnTile t) player--- @------ This could also be written as:------ @--- 'for_' newTile $ \t ->---  hasWall t '>>=' 'flip' 'unless' ('insert' ('Rel' OnTile t) player)--- @------ We also need to somehow get input from the user. Mischief exposes some useful functions for this in the following module:------ @--- import "Mischief.ECS.Stdin" qualified as [Stdin]("Mischief.ECS.Stdin")--- @------ These functions are useful for the purpose of this tutorial but should probably never be used in a released game. Instead, you should import a dedicated--- haskell input library, or use @mischief-input@ which is based on SDL.------ In order to read input we'll need to add @Stdin.init@ to a plugin, which you'll see a bit later.------ For now, we can just use the @Stdin.readLast@ to empty the input buffer and get the last character typed by the user, if any.------ @--- movePlayer :: 'System' ()--- movePlayer = do---   c <- [Stdin]("Mischief.ECS.Stdin").'Mischief.ECS.Stdin.readLast'---   'for_' c $ \case---     \'w\' -> movePlayerBy (-1, 0)---     \'s\' -> movePlayerBy (1, 0)---     \'a\' -> movePlayerBy (0, -1)---     \'d\' -> movePlayerBy (0, 1)---     _ -> 'pure' ()--- @------ The @for_@ just /'iterates/' over the @Maybe@, applying the function if it has a value, and doing nothing otherwise.------ At this point the codebase is starting to grow, so I have decided to create a new @PlayerPlugin@ which handles all the player logic (including the new movement system),--- and make it a dependency of @MainPlugin@:------ @--- data MainPlugin = MainPlugin deriving ('Eq')------ instance 'Plugin' MainPlugin where---   'Mischief.ECS.App.Plugins.init' _ = do---     [Stdin]("Mischief.ECS.Stdin").'Mischief.ECS.Stdin.init'---     [Systems]("Mischief.ECS.Systems").'Mischief.ECS.Systems.add' 'Startup' (spawnGrid, spawnWalls)------   'plugins' _ = 'plug' PlayerPlugin------ data PlayerPlugin = PlayerPlugin deriving ('Eq')------ instance 'Plugin' PlayerPlugin where---   'Mischief.ECS.App.Plugins.init' _ = do---     [Systems]("Mischief.ECS.Systems").'Mischief.ECS.Systems.add' 'Startup' $ spawnPlayer '`after`' spawnGrid---     [Systems]("Mischief.ECS.Systems").'Mischief.ECS.Systems.add' 'Update' movePlayer--- @---- $display--- It's finally time to actually display our game's grid in the terminal!------ You may remember earlier we wrote a system which checks if there is a wall on a given tile.------ @--- hasWall :: 'Entity' -> 'System' 'Bool'--- hasWall tile = 'not' . 'null' '<$>' ['q'|Entity / With (Wall, OnTile -\> tile)|]--- @------ It'd be useful to have something similar but for any arbitrary type of entity. We can write a generic variant of it like this:------ @--- tileHas :: forall c. ('QueryType' c) => 'Entity' -> 'System' 'Bool'--- tileHas tile = 'not' . 'null' '<$>' ['q'|Entity / With (c, OnTile -> tile)|]--- @------ @QueryType@ is a sort of catch-all constraint that makes sure @c@ is a component and can be queried (so nothing weird like it being a tuple).------ Make sure to add @{-# LANGUAGE AllowAmbiguousTypes #-}@ at the top of your .hs file, otherwise the type system will not like that @c@ can not be inferred from the--- function's signature (alternatively you can just pass a @Proxy c@ as a workaround but I personally prefer the other way).------ We can now write @hasWall@ as just:------ @--- hasWall = tileHas \@Wall--- @------ Now it should be easy to write a system that receives a tile and returns a character to represent it:------ @--- showTile :: 'Entity' -> 'System' 'Char'--- showTile tile = do---   player <- tileHas \@Player tile---   wall <- tileHas \@Wall tile------   'pure' $---     if---       | player -> \'@\'---       | wall -> \'#\'---       | otherwise -> \'.\'--- @------ This requires the @MultiWayIf@ language extension, but there are many ways to write it without it, it's just a personal preference.------ Next, I've written a system which produces a String for the whole grid by calling the previous function on each tile:------ @--- showGrid :: 'System' 'String'--- showGrid = do---   'Just' (Grid tiles) <- 'res' \@Grid---   lines <- 'for' tiles $ 'traverse' showTile---   'pure' $ 'unlines' lines--- @------ All that's left is to write a system that prints the string, and schedule it to happen each frame. We'll do the actual--- printing via the @printClear@ function of "Mischief.ECS.Stdout", which automatically clears the terminal.------ @--- printGrid :: 'System' ()--- printGrid = 'Mischief.ECS.Stdout.printClear' '=<<' showGrid--- @------ @--- instance 'Plugin' MainPlugin where---   'Mischief.ECS.App.Plugins.init' _ = do---     [Stdin]("Mischief.ECS.Stdin").'Mischief.ECS.Stdin.init'---     [Systems]("Mischief.ECS.Systems").'Mischief.ECS.Systems.add' 'Startup' (spawnGrid, spawnWalls)---     [Systems]("Mischief.ECS.Systems").'Mischief.ECS.Systems.add' 'Update' printGrid--- @------ If you run the app now, you should see the game's grid and we able to use @wasd@ to move the player around!------ @--- ####################--- \#..................#--- \#..................#--- \#..................#--- \#..................#--- \#....\@.............#--- \#..................#--- \#..................#--- \#..................#--- ####################--- @---- $rand--- For some of the next sections, an ability to choose random tiles would be very useful. So let's work on that.------ I've chosen to use the @random@ package, so just add it as a dependency to your project and import it:------ @--- import System.Random--- import System.Random.Stateful--- @------ We need some sort of mutable generator, so I'll create a resource to hold it:------ @--- data Rand = Rand (IOGenM StdGen) deriving ('Component')------ newGen :: 'System' Rand--- newGen = Rand \<$\> (newIOGenM =<< initStdGen)--- @------ Don't forget to insert the resource!------ @--- instance 'Plugin' MainPlugin where---   'Mischief.ECS.App.Plugins.init' _ = do---     [Stdin]("Mischief.ECS.Stdin").'Mischief.ECS.Stdin.init'---     [Systems]("Mischief.ECS.Systems").'Mischief.ECS.Systems.add' 'Startup' (spawnGrid, spawnWalls)---     [Systems]("Mischief.ECS.Systems").'Mischief.ECS.Systems.add' 'Update' printGrid------     'insertRes' '=<<' newGen--- @------ Now it's possible to write a system that generates a random position on the grid:------ @--- randomPos :: 'System' ('Int', 'Int')--- randomPos = do---   'Just' (Rand gen) <- res @Rand---   i <- applyIOGen (uniformR (0, gridH - 1)) gen---   j <- applyIOGen (uniformR (0, gridW - 1)) gen---   return (i, j)--- @------ And a system that uses it to get the Entity of a random tile:------ @--- randomTile :: 'System' 'Entity'--- randomTile = 'unwrap' \<$\> getTile randomPos--- @------ @unwrap@ is a utility function provided by Mischief that just grabs the value out of a @Maybe@, or panics if there is no value. But in this case,--- we know there will be a value since the provided position is valid.---- $enemies--- It would be a pretty boring game if there were no obstacles. For that reason, we're going to add some enemies.------ Here's the marker component that will be used to identify them:------ @--- data Enemy = Enemy deriving ('Component')--- @------ I'll use this system to spawn an enemy, using the @randomTile@ function defined earlier:------ @--- spawnEnemy :: 'System' Entity--- spawnEnemy = do---   tile <- randomTile---   'spawn' (Enemy, 'Rel' OnTile tile)--- @------ And this as a driver to handle all enemy spawning (it just spawns 5 enemies):------ @--- spawnEnemies :: 'System' ()--- spawnEnemies = 'for_' [0 .. 4] $ 'const' spawnEnemy--- @------ I've also modified the @showTile@ system to take enemies into account:------ @------ showTile :: 'Entity' -> 'System' 'Char'--- showTile tile = do---   player <- tileHas \@Player tile---   enemy <- tileHas \@Enemy tile---   wall <- tileHas \@Wall tile------   'pure' $---     if---       | player -> \'@\'---       | wall -> \'#\'---       | enemy -> \'!\'---       | otherwise -> \'.\'--- @------ Finally, we need a to schedule the enemy spawning, so I've created a new @EnemyPlugin@:------ @--- data EnemyPlugin = EnemyPlugin deriving ('Eq')------ instance 'Plugin' EnemyPlugin where---   'Mischief.ECS.App.Plugins.init' _ = [Systems]("Mischief.ECS.Systems").'Mischief.ECS.Systems.add' 'Startup' spawnEnemies--- @------ And added it to the list of plugins added by @MainPlugin@:------ @--- instance 'Plugin' MainPlugin where---   'Mischief.ECS.App.Plugins.init' _ = ...------   'plugins' = 'plug' (PlayerPlugin, EnemyPlugin)--- @------ You should now see something like this when running the app:------ @--- ####################--- \#..................#--- \#..!...............#--- \#....!.!...........#--- \#..................#--- \#....\@.............#--- \#..................#--- \#..................#--- \#........!.!.......#--- ####################--- @---- $moveE--- Right now the enemies just sit there. Let's make them move!------ But first, I'd like to present you a new concept: @transitive queries@.------ Up until now, if we wanted the position of the tile of the player we'd do somehing like:------ @--- 'Just' tile <- 'single'' ('R' \@OnTile 'Any') ('With' ('C' \@Player))--- 'Just' pos <- 'get' ('Val' ('C' \@Pos)) tile.target--- @------ We'd do a query to get the player's relationship to the tile, then do another query on the actual tile to get its position.------ But this could also be written as:------ @--- 'Just' pos <- 'single'' ('R' \@OnTile ('Q' ('Val' ('C' \@Pos)))) ('With' ('C' \@Player))--- @------ Instead of getting all relationship, we use the @Q@ marker to run the given query on each target of the relationship. So we transitively--- get the position of the tile through its relationship to the player.------ If you think this is uglier than just the two queries earlier, don't worry, the quasi notation looks much better:------ @--- 'Just' pos \<- ['s'|OnTile -\> (*Pos) / With Player|]--- @------ Don't forget to put the @()@ around @*Pos@!------ You should now be able to understand this system that handles the movement of the enemies:------ @--- moveEnemies :: 'System' ()--- moveEnemies = do---   'Just' pos \<- ['s'|OnTile -\> (*Pos) / With Player|]------   enemies \<- ['q'|Entity, OnTile -\> (Entity, *Pos) / With Enemy|]---   'for_' enemies $ \(enemy, (enemyTarget, enemyPos)) -> do------   diff <- decideEnemyDir enemyPos pos------   newTile <- moveBy diff enemyTile---   'for_' newTile $ \t -> do---     'insert' ('Rel' OnTile t) enemy--- @------ With this helper function for deciding which direction to move on, based on the player's position.------ @--- decideEnemyDir :: Pos -> Pos -> 'System' ('Int', 'Int')--- decideEnemyDir (Pos (ex, ey)) (Pos (px, py)) = do---   'pure' $---     if---       | ex > px -> (-1, 0)---       | ey > py -> (0, -1)---       | ex < px -> (1, 0)---       | ey < py -> (0, 1)---       | otherwise -> (0, 0)--- @------ And don't forget to schedule it:------ @--- instance 'Plugin' EnemyPlugin where---   'Mischief.ECS.App.Plugins.init' _ = do---     [Systems]("Mischief.ECS.Systems").'Mischief.ECS.Systems.add' 'Startup' spawnEnemies---     [Systems]("Mischief.ECS.Systems").'Mischief.ECS.Systems.add' 'Update' moveEnemies--- @------ Except there's a small problem. If you run the app now, you may notice you don't see any enemies!------ That's because they all already got to the player and are hiding behind it! We've set @moveEnemies@--- to happen every frame, and our frames are happening almost instantly. So we need to add some sort of timing to the enemy's movement.------ There are many cleaner high-level solutions to fix this, some of them even using async systems, but instead, I'll take the opportunity to introduce you to an important notion, Time!------ In order to use @Time@ utilities, you need to add the @'TimePlugin'@ to your app, so I'll add it to our @MainPlugin@:------ @--- 'plugins' = 'plug' (PlayerPlugin, EnemyPlugin, TimePlugin)--- @------ In any system you can use the @deltaTime@ function to get the number of seconds passed since the last frame.------ Mischief also provides a hnady way of keeping track of time via the @Timer@.------ @--- import "Mischief.ECS.Timer" ('Mischief.ECS.Timer.Timer')--- import "Mischief.ECS.Timer" qualified as [Timer]("Mischief.ECS.Timer")--- @------ We can now create a @Cooldown@ component which stores a Timer.------ @--- data Cooldown = Cooldown {timer :: 'Mischief.ECS.Timer'} deriving ('Component')--- @------ We want this to always be on every Enemy, so we can make it a required component of the @Enemy@ component.------ @--- instance 'Component' Enemy where---   'required' = 'require' \@Cooldown--- @------ In order to have that compile, we also need to provide a @Default@ instance for @Cooldown@:------ @--- instance 'Default' Cooldown where---   'def' = [Timer]("Mischief.ECS.Timer").'Mischief.ECS.Timer.new' 1 [Timer]("Mischief.ECS.Timer").'Mischief.ECS.Timer.Repeat'--- @------ @Timer.new@ takes a Float (the duration of the timer), and a @Mode@ which is either @Repeat@ or @Once@.------ @Cooldown@ should now automatically be on every enemy.------ We can use the @Timer.tick@ function to advance the state of a timer. It returns the new state, along with a Bool that tells us whether the timer has just finished or not.------ All that's left is to put all of this together:------ @--- moveEnemies :: 'System' ()--- moveEnemies = do---   'Just' pos \<- ['s'|OnTile -\> (*Pos) / With Player|]---   delta <- 'deltaTime'------   enemies \<- ['q'|Entity, OnTile -\> (Entity, *Pos), Cooldown / With Enemy|]---   'for_' enemies $ \(enemy, (enemyTile, enemyPos), cooldown) -> do---     let (timer, finished) = [Timer]("Mischief.ECS.Timer").'Mischief.ECS.Timer.tick' delta cooldown.timer---     'set' cooldown $ Cooldown timer------     'when' finished $ do---       diff <- decideEnemyDir enemyPos pos------       newTile <- moveBy diff enemyTile---       'for_' newTile $ \t -> do---         'insert' ('Rel' OnTile t) enemy--- @------ Each frame, we tick the cooldown timer of each enemy, and only move them if that timer has just finished. This means every enemy will now move only once per 0.5 seconds.------ Don't forget to use the @set@ to pass the new timer back into the ECS! In Mischief, all variables you use are @immutable@, so you need to explicitly order mutations.------ You can now run your app and see the enemies chasing you!---- $collision--- Right now the enemies just kinda overlap each other and go under the player. We can fix that by preventing them to move.------ Now, let's write a function that tells us whether a certain tile is free to move on or not:------ @--- tileIsFree :: 'Entity' -> 'System' Bool--- tileIsFree tile = do---   wall <- tileHas \@Wall tile---   enemy <- tileHas \@Enemy tile---   player <- tileHas \@Player tile---   pure $ not (wall || enemy || player)--- @------ Plus, an extra one which takes the tile's position directly rather than the entity:------ @--- tileAtPosIsFree :: ('Int', 'Int') -> 'System' 'Bool'--- tileAtPosIsFree pos = do---   tile <- getTile pos---   'maybe' ('pure' False) tileIsFree tile--- @------ And let's integrate it into the system which decides the enemy's movement direction:------ @--- decideEnemyDir :: Pos -> Pos -> 'System' ('Int', 'Int')--- decideEnemyDir (Pos (ex, ey)) (Pos (px, py)) = do---   left <- tileAtPosIsFree (ex - 1, ey)---   up <- tileAtPosIsFree (ex, ey - 1)---   right <- tileAtPosIsFree (ex + 1, ey)---   down <- tileAtPosIsFree (ex, ey + 1)------   'pure' $---     if---       | ex \> px && left -\> (-1, 0)---       | ey \> py && up -\> (0, -1)---       | ex \< px && right -\> (1, 0)---       | ey \< py && down -\> (0, 1)---       | otherwise -> (0, 0)--- @------ (There are definitely /much/ better ways to write this but I can't really be bothered, feel free to make it cleaner at home)------ I've also replaced the @hasWall@ in the @movePlayerBy@ function with @tileIsFree@, so the player can collide with enemies as well--- (make sure to also replace the @'unless'@ with @'when'@!).------ The game should now have fullly working collision and feel much more solid!---- $health--- Here's a simple one: let's add a @Health@ component to the player and have it be displayed under the grid each frame.------ I'll also give it a @Default@ instance so it can be required by the @Player@ component.------ @--- data Health = Health {hp :: 'Int'} deriving ('Component')------ instance 'Default' Health where---   'def' = Health 100--- @------ @--- instance 'Component' Player where---   'required' = 'require' \@Health--- @------ I've written a system that returns a string for the health:------ @--- showHealth :: 'System' 'String'--- showHealth = do---   'Just' health <- ['s'|Health / With Player|]---   'pure' $ "Health: " ++ 'show' health.hp--- @------ And I added it to the printing system:------ @--- printGrid :: 'System' ()--- printGrid = do---   grid <- showGrid---   health <- showHealth---   'Mischief.ECS.Stdout.printClear' $ health ++ \"\\n\" ++ grid--- @------ In case you're thinking about it, yes, Health could just be a resource, I just decided to make it a component.------ Your game should now print the health at the top:------ @--- Health: 100--- ####################--- \#............!.....#--- \#.....!............#--- \#..................#--- \#..................#--- \#....\@!......!..!..#--- \#..................#--- \#..................#--- \#..................#--- ####################--- @---- $dmg--- Let's add behavior for enemies damaging the player. I'll also take this opportunity to introduce you to Events.------ We can create a damage event like this:------ @--- data Damage = Damage deriving ('Event')--- @------ We also need an observer system for it:------ @--- onDamage :: Damage -> 'System' ()--- onDamage dmg = do---   'Just' health <- ['s'|Health / With Player|]---   'modify' health $ \(Health x) -> Health $ 'max' (x - dmg.amount) 0--- @------ In order to activate the system when the event is triggered, we need to spawn an observer for it. I'll do it in the @PlayerPlugin@:------ @--- import "Mischief.ECS.Observers" as [Observers]("Mischief.ECS.Observers")--- @------ @--- instance 'Plugin' PlayerPlugin where---   'Mischief.ECS.App.Plugins.init' _ = do---     [Systems]("Mischief.ECS.Systems").'Mischief.ECS.Systems.add' 'Startup' $ spawnPlayer '`after`' spawnGrid---     [Systems]("Mischief.ECS.Systems").'Mischief.ECS.Systems.add' 'Update' movePlayer---     'void' $ [Observers]("Mischief.ECS.Observers").'Mischief.ECS.Observers.spawn' onDamage--- @------ The last thing we need is a way for enemies to trigger the event. I made a system which checks if an enemy is adjacent to the player and triggers the event:------ @--- tryDamage :: 'System' ()--- tryDamage = do---   'Just' player \<- ['s'|OnTile -\> (*Pos) / With Player|]---   enemies \<- ['q'|OnTile -\> (*Pos) / With Enemy|]------   'for_' enemies $ \pos -> do---     'when' (isAdjacent pos player) $ do---       'trigger' (Damage 5)--- @------ With this helper function:------ @--- isAdjacent :: Pos -> Pos -> 'Bool--- isAdjacent (Pos (x1, y1)) (Pos (x2, y2)) =---   let dx = abs (x1 - x2)---       dy = abs (y1 - y2)---    in (dx == 1 && dy == 0) || (dx == 0 && dy == 1)--- @------ I've scheduled @tryDamage@ to happen every frame, after both the player and enemies have moved:------ @--- instance 'Plugin' EnemyPlugin where---   'Mischief.ECS.App.Plugins.init' _ = do---     [Systems]("Mischief.ECS.Systems").'Mischief.ECS.Systems.add' 'Startup' spawnEnemies---     [Systems]("Mischief.ECS.Systems").'Mischief.ECS.Systems.add' 'Update' moveEnemies---     [Systems]("Mischief.ECS.Systems").'Mischief.ECS.Systems.add' 'Update' $ tryDamage '`after`' moveEnemies '`after`' movePlayer--- @------ This now /technically/ works, except that the enemies almost instantly kill the player on contact. That's because they deal damage every frame,--- the same issue we had when they were moving each frame.------ I'll show you a different way to solve this problem. We can add an @Invincible@ component on the player after being hit once,--- which causes it to not receive damage, and which is removed after a delay.------ @--- data Invincible = Invincible deriving ('Component')--- @------ I'll modify the @onDamage@ observer like so:------ @--- onDamage :: Damage -> 'System' ()--- onDamage dmg = do---   player <- ['s'|(Entity, Health) / With Player, Without Invincible|]------   'for_' player $ \(entity, health) -> do---     'modify' health $ \(Health x) -> Health $ max (x - dmg.amount) 0------     'insert' Invincible entity---     'delay' 1000000 $ 'remove' ('C' \@Invincible) entity--- @------ Let's analyze it.------ This line queries the player's Entity and Health, but only if they don't have the @Invincible@ component.------ @--- player <- ['s'|(Entity, Health) / With Player, Without Invincible|]--- @------ If the query returned something (if the player isn't invincible), it will take damage.------ @--- 'modify' health $ \(Health x) -\> Health $ max (x - dmg.amount) 0--- @------ Then the @Invincible@ component will be inserted on the player.------ @--- 'insert' Invincible entity--- @------ And finally, we use the @delay@ async function to tell Mischief to run remove the component after a delay (in miliseconds):------ @--- 'delay' 1000000 $ 'remove' ('C' \@Invincible) entity--- @------ Now, the player will only be able to take damage once per second!---- $quit--- It feels weird that the player can reach 0 health but the game just keeps running. So let's add some logic for quitting:--------- @--- onDamage :: Damage -> 'System' ()--- onDamage dmg = do---   player <- ['s'|(Entity, Health) / With Player, Without Invincible|]------   'for_' player $ \(entity, health) -> do---     'modify' health $ \(Health x) -> Health $ max (x - dmg.amount) 0------     'insert' Invincible entity---     'delay' 1000000 $ 'remove' ('C' \@Invincible) entity------     'when' (health.hp == 0) $ 'liftIO' 'exitSuccess'--- @------ But you may notice, the player actually takes an extra hit before that condition is triggered. That's because the @health@ variable is immutable.--- When we call @modify@, we update the live value of the component, but our local variable stays as it is.------ We can use @update@ to get the live value:------ @--- 'Just' health <- 'update' health--- 'when' (health.hp == 0) $ 'liftIO' 'exitSuccess'--- @------ The logic should now work as expected.---- $coins--- Now, for our last bit of logic, we should add a reason for the player to not die. Let's spawn a bunch of coins!------ First, we need a marker component for the coins:------ @--- data Coin = Coin deriving ('Component')--- @------ Second, here's a system that spawns a coin on a random free tile:------ @--- spawnCoin :: 'System' ()--- spawnCoin = do---   tile <- randomTile---   free <- tileIsFree tile---   if free---     then---       'void' $ 'spawn' (Coin, 'Rel' OnTile tile)---     else---       spawnCoin--- @------ (If the tile is not free, it will just keep looping and generating tiles until it finds one that is).------ Third, we can use intervals to make the system repeat every two seconds.------ @--- import "Mischief.ECS.Interval" qualified as [Interval]("Mischief.ECS.Interval")--- @--------- @--- instance 'Plugin' MainPlugin where---   'Mischief.ECS.App.Plugins.init' _ = do---     [Stdin]("Mischief.ECS.Stdin").'Mischief.ECS.Stdin.init'---     [Systems]("Mischief.ECS.Systems").'Mischief.ECS.Systems.add' 'Startup' (spawnGrid, spawnWalls)---     [Systems]("Mischief.ECS.Systems").'Mischief.ECS.Systems.add' 'Update' printGrid------     interval <- [Interval]("Mischief.ECS.Interval").'Mischief.ECS.Interval.start' 2000000 spawnCoin------     'insertRes' '=<<' newGen--- @------ You can also use @Interval.stop@ on the returned value to stop the interval at any point, but I won't be doing that here.------ Finally, we should display the coins:------ @--- showTile :: 'Entity' -> 'System' 'Char'--- showTile tile = do---   player <- tileHas \@Player tile---   enemy <- tileHas \@Enemy tile---   wall <- tileHas \@Wall tile---   coin <- tileHas \@Coin tile------   'pure' $---     if---       | player -> \'@\'---       | wall -> \'#\'---       | enemy -> \'!\'---       | coin -> \'$\'---       | otherwise -> \'.\'--- @---- $collect--- All that's left is letting the player collect coins and keeping track of how many they got.------ I'll do this via a resource this time.------ @--- data Coins = Coins 'Int' deriving ('Component')--- @------ I'll insert the resource in @MainPlugin@:------ @--- instance 'Plugin' MainPlugin where---   'Mischief.ECS.App.Plugins.init' _ = do---     [Stdin]("Mischief.ECS.Stdin").'Mischief.ECS.Stdin.init'---     [Systems]("Mischief.ECS.Systems").'Mischief.ECS.Systems.add' 'Startup' (spawnGrid, spawnWalls)---     [Systems]("Mischief.ECS.Systems").'Mischief.ECS.Systems.add' 'Update' printGrid------     interval <- [Interval]("Mischief.ECS.Interval").'Mischief.ECS.Interval.start' 2000000 spawnCoin------     'insertRes' '=<<' newGen---     'insertRes' $ Coins 0--- @------ And I'll update the display to also show the number of coins:------ @--- showCoins :: 'System' 'String'--- showCoins = do---   'Just' (Coins c) <- 'res' \@Coins---   'pure' $ \"Coins: \" ++ show c--- @------ @--- printGrid :: 'System' ()--- printGrid = do---   grid <- showGrid---   health <- showHealth---   coins <- showCoins---   'Mischief.ECS.Stdout.printClear' $ health ++ \"\\n\" ++ grid ++ \"\\n\" ++ coins ++ \"\\n\"--- @------ And now finally, a system that checks if there are any coins on the same tile as the player, despawns them, and increments the resource:------ @--- collectCoins :: 'System' ()--- collectCoins = do---   'Just' playerTile <- ['s'|OnTile -> (Entity) / With Player|]---   coins <- ['q'|Entity / With OnTile -> playerTile, With Coin|]------   'Just' (Coins c) <- 'res' \@Coins---   'insertRes' $ Coins $ c + 'length' coins------   'for_' coins despawn--- @------ And I'll schedule it:------ @--- instance 'Plugin' PlayerPlugin where---   'Mischief.ECS.App.Plugins.init' _ = do---     [Systems]("Mischief.ECS.Systems").'Mischief.ECS.Systems.add' 'Startup' $ spawnPlayer '`after`' spawnGrid---     [Systems]("Mischief.ECS.Systems").'Mischief.ECS.Systems.add' 'Update' movePlayer---     [Systems]("Mischief.ECS.Systems").'Mischief.ECS.Systems.add' 'Update' $ collectCoins '`after`' movePlayer------     'void' $ [Observers]("Mischief.ECS.Observers").'Mischief.ECS.Observers.spawn' onDamage--- @------ And that's it! Out player should now be able to collect coins!------ @--- Health: 5--- ####################--- \#..................#--- \#..................#--- \#$....!!!!!\@...$...#--- \#$.................#--- \#..................#--- \#......$...........#--- \#.$................#--- \#..................#--- ####################--- Coins: 16--- @---- $nextf--- Don't worry if there are various details that you haven't fully understood yet. The next chapters will go into detail over the many aspects of the ECS. This chapter was just meant--- to give you a general idea of working with Mischief. You can find the whole code for this example [here](https://github.com/PVDoriginal/mischief/blob/main/mischief-ecs/examples/Dungeon.hs).