packages feed

mischief-ecs (empty) → 0.1.0.0

raw patch · 84 files changed

+12253/−0 lines, 84 filesdep +ansi-terminaldep +asyncdep +base

Dependencies added: ansi-terminal, async, base, binary, bytestring, clock, co-log, containers, criterion, data-default, deepseq, hashable, hashtables, haskell-src-meta, megaparsec, mischief-ecs, mtl, primitive, random, stm, template-haskell, text, time, transformers, vector

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for mischief++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,29 @@+Copyright (c) 2026, Damon+++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of the copyright holder nor the names of its+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ benchmarks/bench-insert.hs view
@@ -0,0 +1,53 @@+module Main where++import Control.DeepSeq (NFData (rnf))+import Control.Monad+import Criterion+import Criterion.Main+import Criterion.Types+import Data.Foldable+import Data.Traversable+import Mischief.ECS++main :: IO ()+main =+  defaultMainWith+    defaultConfig {reportFile = Just "/home/pvd/GameRepos/mischief/benches/insert.html"}+    [ benchInsert 10,+      benchInsert 100,+      benchInsert 1000,+      benchInsert 10000,+      benchInsert 100000+    ]++benchInsert :: Int -> Benchmark+benchInsert n = bgroup (show n ++ " Entities") [env (mkEs n) benchF]++benchF :: (Es, W) -> Benchmark+benchF a = bench "" $ nfIO $ benchI a++benchI :: (Es, W) -> IO ()+benchI (Es es, W w) = runSystem (insertComponents es) w++mkEs :: Int -> IO (Es, W)+mkEs n = do+  app <- newApp P+  es <- runSystem (replicateM n (spawn ())) app.world+  pure (Es es, W app.world)++data P = P deriving (Eq, Plugin)++data Comp1 = Comp1 deriving (Component)++newtype Es = Es [Entity]++newtype W = W World++instance NFData Es where+  rnf _ = ()++instance NFData W where+  rnf _ = ()++insertComponents :: [Entity] -> System ()+insertComponents = traverse_ (insert Comp1)
+ benchmarks/bench-spawn.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ImportQualifiedPost #-}++module Main where++import Control.DeepSeq+import Control.Monad+import Criterion.Main+import Criterion.Types+import Data.Foldable+import GHC.Generics (Generic, type (:.:) (Comp1))+import Mischief.ECS++flame :: IO ()+flame = do+  app <- newApp P+  runSystem (spawnEntities 100000 2 5) app.world++main :: IO ()+main =+  -- flame+  defaultMainWith+    defaultConfig {reportFile = Just "/home/pvd/GameRepos/mischief/benches/spawn.html"}+    [ bgroup+        "Spawn"+        [ benchSpawnEntities 10,+          benchSpawnEntities 100,+          benchSpawnEntities 1000,+          benchSpawnEntities 10000,+          benchSpawnEntities 100000+        ]+    ]++benchSpawnEntities :: Int -> Benchmark+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]]++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+  pure $ W app.world++newtype W = W World++instance NFData W where+  rnf _ = ()++-- The first Int indicates how many entities will be spawned. The second how many components each entity will have. The third how many archetypes the entities will be divided in.+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)++data Comp21 = Comp21 deriving (Component)++data Comp31 = Comp31 deriving (Component)++data Comp41 = Comp41 deriving (Component)++data Comp51 = Comp51 deriving (Component)++data Comp12 = Comp12 deriving (Component)++data Comp22 = Comp22 deriving (Component)++data Comp32 = Comp32 deriving (Component)++data Comp42 = Comp42 deriving (Component)++data Comp52 = Comp52 deriving (Component)++data Comp13 = Comp13 deriving (Component)++data Comp23 = Comp23 deriving (Component)++data Comp33 = Comp33 deriving (Component)++data Comp43 = Comp43 deriving (Component)++data Comp53 = Comp53 deriving (Component)++data Comp14 = Comp14 deriving (Component)++data Comp24 = Comp24 deriving (Component)++data Comp34 = Comp34 deriving (Component)++data Comp44 = Comp44 deriving (Component)++data Comp54 = Comp54 deriving (Component)++data Comp15 = Comp15 deriving (Component)++data Comp25 = Comp25 deriving (Component)++data Comp35 = Comp35 deriving (Component)++data Comp45 = Comp45 deriving (Component)++data Comp55 = Comp55 deriving (Component)++spawn' :: Int -> Int -> System Entity+spawn' 1 1 = spawn Comp11+spawn' 1 2 = spawn Comp12+spawn' 1 3 = spawn Comp13+spawn' 1 4 = spawn Comp14+spawn' 1 5 = spawn Comp15+spawn' 2 1 = spawn (Comp11, Comp21)+spawn' 2 2 = spawn (Comp12, Comp22)+spawn' 2 3 = spawn (Comp13, Comp23)+spawn' 2 4 = spawn (Comp14, Comp24)+spawn' 2 5 = spawn (Comp15, Comp25)+spawn' 3 1 = spawn (Comp11, Comp21, Comp31)+spawn' 3 2 = spawn (Comp12, Comp22, Comp32)+spawn' 3 3 = spawn (Comp13, Comp23, Comp33)+spawn' 3 4 = spawn (Comp14, Comp24, Comp34)+spawn' 3 5 = spawn (Comp15, Comp25, Comp35)+spawn' 4 1 = spawn (Comp11, Comp21, Comp31, Comp41)+spawn' 4 2 = spawn (Comp12, Comp22, Comp32, Comp42)+spawn' 4 3 = spawn (Comp13, Comp23, Comp33, Comp43)+spawn' 4 4 = spawn (Comp14, Comp24, Comp34, Comp44)+spawn' 4 5 = spawn (Comp15, Comp25, Comp35, Comp45)+spawn' 5 1 = spawn (Comp11, Comp21, Comp31, Comp41, Comp51)+spawn' 5 2 = spawn (Comp12, Comp22, Comp32, Comp42, Comp52)+spawn' 5 3 = spawn (Comp13, Comp23, Comp33, Comp43, Comp53)+spawn' 5 4 = spawn (Comp14, Comp24, Comp34, Comp44, Comp54)+spawn' 5 5 = spawn (Comp15, Comp25, Comp35, Comp45, Comp55)+spawn' _ _ = undefined++spawnEntities :: Int -> Int -> Int -> System ()+spawnEntities ne nc na =+  -- forkPrefs (supressEvents True) $+  for_ [1 .. na] $ \a ->+    replicateM_ (ne `div` na) $+      spawn' nc a
+ benchmarks/bench-update.hs view
@@ -0,0 +1,51 @@+module Main where++import Control.DeepSeq (NFData (rnf))+import Control.Monad (replicateM_)+import Criterion.Main+import Criterion.Types+import Data.Foldable+import Mischief.ECS++main :: IO ()+main =+  defaultMainWith+    defaultConfig {reportFile = Just "/home/pvd/GameRepos/mischief/benches/update.html"}+    [ benchEntities 10,+      benchEntities 100,+      benchEntities 1000,+      benchEntities 10000,+      benchEntities 100000+    ]++benchEntities :: Int -> Benchmark+benchEntities a = bgroup (show a ++ " Entities") $ [env (mkWorld a) $ benchUpdates a b | b <- [1, 4, 8]]++benchUpdates :: Int -> Int -> W -> Benchmark+benchUpdates a b w = bench (show b ++ " Updates") $ nfIO $ benchUpdate a b w++benchUpdate :: Int -> Int -> W -> IO ()+benchUpdate _ b (W w) = replicateM_ b (runSystem up w)++data Comp1 = Comp1 deriving (Component)++newtype W = W World++instance NFData W where+  rnf _ = ()++mkWorld :: Int -> IO W+mkWorld n = do+  app <- newApp P+  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
+ examples/Dungeon.hs view
@@ -0,0 +1,332 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE MultiWayIf #-}++{- HLINT ignore "Use newtype instead of data" -}++module Main where++import Control.Monad (void, when)+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.Timer qualified as Timer+import Mischief.ECS.World.Query.QueryType+import System.Exit+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+  runApp app++data MainPlugin = MainPlugin deriving (Eq)++instance Plugin MainPlugin where+  init _ = do+    Stdin.init+    Systems.add Startup (spawnGrid, spawnWalls)+    Systems.add Update printGrid++    interval <- Interval.start 2000000 spawnCoin++    insertRes =<< newGen+    insertRes $ Coins 0++  plugins _ = plug (PlayerPlugin, EnemyPlugin, TimePlugin)++data PlayerPlugin = PlayerPlugin deriving (Eq)++instance Plugin PlayerPlugin where+  init _ = do+    Systems.add Startup $ spawnPlayer `after` spawnGrid+    Systems.add Update movePlayer+    Systems.add Update $ collectCoins `after` movePlayer++    void $ Observers.spawn onDamage++data EnemyPlugin = EnemyPlugin deriving (Eq)++instance Plugin EnemyPlugin where+  init _ = do+    Systems.add Startup spawnEnemies+    Systems.add Update moveEnemies+    Systems.add Update $ tryDamage `after` movePlayer `after` moveEnemies++data Tile = Tile deriving (Component)++newtype Pos = Pos {pos :: (Int, Int)} deriving (Component, Show)++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++gridW :: Int+gridW = 20++spawnGrid :: System ()+spawnGrid = do+  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)++data Player = Player++instance Component Player where+  required = require @Health++data OnTile = OnTile++instance Component OnTile where+  type RelExclusivity OnTile = Exclusive++spawnPlayer :: System ()+spawnPlayer = do+  Just tile <- getTile (5, 5)+  void $ spawn (Player, Rel OnTile tile)++data Wall = Wall deriving (Component)++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)++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 -> '.'++showGrid :: System String+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++printGrid :: System ()+printGrid = do+  grid <- showGrid+  health <- showHealth+  coins <- showCoins+  printClear $ health ++ "\n" ++ grid ++ "\n" ++ coins ++ "\n"++movePlayer :: System ()+movePlayer = do+  c <- Stdin.readLast+  for_ c $ \case+    'w' -> movePlayerBy (-1, 0)+    's' -> movePlayerBy (1, 0)+    'a' -> movePlayerBy (0, -1)+    '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+newGen = Rand <$> (newIOGenM =<< initStdGen)++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+  return (i, j)++randomTile :: System Entity+randomTile = unwrap <$> (getTile =<< randomPos)++spawnEnemy :: System Entity+spawnEnemy = do+  tile <- randomTile+  spawn (Enemy, Rel OnTile tile)++spawnEnemies :: System ()+spawnEnemies = for_ [0 .. 4] $ const spawnEnemy++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)++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.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++tileHas :: forall c. (QueryType c) => Entity -> System Bool+tileHas tile = not . null <$> [q|Entity / With (c, OnTile -> tile)|]++tileAtPosIsFree :: (Int, Int) -> System Bool+tileAtPosIsFree pos = do+  tile <- getTile pos+  maybe (pure False) tileIsFree tile++tileIsFree :: Entity -> System Bool+tileIsFree tile = do+  wall <- tileHas @Wall tile+  enemy <- tileHas @Enemy tile+  player <- tileHas @Player tile+  pure $ not (wall || enemy || player)++data Health = Health {hp :: Int} deriving (Component)++instance Default Health where+  def = Health 100++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++    insert Invincible entity+    delay 1000000 $ remove (C @Invincible) entity++    Just health <- update health+    when (health.hp == 0) $ liftIO exitSuccess++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)++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)++spawnCoin :: System ()+spawnCoin = do+  tile <- randomTile+  free <- tileIsFree tile+  if free+    then+      void $ spawn (Coin, Rel OnTile tile)+    else+      spawnCoin++data Coins = Coins Int deriving (Component)++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
+ mischief-ecs.cabal view
@@ -0,0 +1,333 @@+cabal-version: 3.0+-- The cabal-version field refers to the version of the .cabal specification,+-- and can be different from the cabal-install (the tool) version and the+-- Cabal (the library) version you are using. As such, the Cabal (the library)+-- version used must be equal or greater than the version stated in this field.+-- Starting from the specification version 2.2, the cabal-version field must be+-- the first thing in the cabal file.+-- Initial package description 'mischief' generated by+-- 'cabal init'. For further documentation, see:+--   http://haskell.org/cabal/users-guide/+--+-- The name of the package.+name: mischief-ecs+-- The package version.+-- See the Haskell package versioning policy (PVP) for standards+-- guiding when and how versions should be incremented.+-- https://pvp.haskell.org+-- PVP summary:     +-+------- breaking API changes+--                  | | +----- non-breaking API additions+--                  | | | +--- code changes with no API change+version: 0.1.0.0+-- A short (one-line) description of the package.+synopsis: An opinionated archetype ECS engine built in Haskell.+-- 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.++category: Game Engine, ECS, Game, Control, Data, Framework+-- The license under which the package is released.+license: BSD-3-Clause+-- The file containing the license text.+license-file: LICENSE+-- The package author(s).+author: Damon+-- An email address to which users can send suggestions, bug reports, and patches.+maintainer: pvdoriginal2019@gmail.com+-- A copyright notice.+-- 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 source files to be distributed with the package, such as examples, or a tutorial module.+-- extra-source-files:+common warnings+  ghc-options:+    "-Wall,"+    -Wno-name-shadowing++library+  -- Import common warning flags.+  import: warnings+  -- Modules exported by the library.+  exposed-modules:+    Mischief.ECS+    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+    Mischief.ECS.Archetypes.Graph+    Mischief.ECS.Collectable+    Mischief.ECS.Components+    Mischief.ECS.Components.Bundle+    Mischief.ECS.Components.BundleTypes+    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.Hooks+    Mischief.ECS.Interval+    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.Resources+    Mischief.ECS.Schedules+    Mischief.ECS.Stdin+    Mischief.ECS.Stdout+    Mischief.ECS.Systems+    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.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.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.+  -- other-modules:+  other-modules:+    Mischief.ECS.Hidden++  -- LANGUAGE extensions used by modules in this package.z+  default-extensions:+    DefaultSignatures+    DeriveAnyClass+    DuplicateRecordFields+    FunctionalDependencies+    ImportQualifiedPost+    MagicHash+    NoFieldSelectors+    OverloadedRecordDot+    OverloadedStrings+    QuasiQuotes+    RequiredTypeArguments+    TemplateHaskell+    TypeFamilyDependencies+    UnboxedSums+    UnboxedTuples+    UndecidableInstances+    UnliftedDatatypes+    UnliftedNewtypes++  -- other-extensions:+  -- Other library packages from which modules are imported.+  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,+    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,+    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,+    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,++  -- Directories containing source files.+  hs-source-dirs:+    src++  -- Base language which the package is written in.+  default-language:+    GHC2024++  ghc-options: -fno-omit-yields++test-suite mischief-test+  -- Import common warning flags.+  import: warnings+  ghc-options: -fno-omit-yields+  -- Base language which the package is written in.+  default-language: GHC2024+  -- Modules included in this executable, other than Main.+  -- other-modules:+  -- LANGUAGE extensions used by modules in this package.+  default-extensions:+    DeriveAnyClass+    DuplicateRecordFields+    NoFieldSelectors+    NoGeneralizedNewtypeDeriving+    OverloadedRecordDot+    OverloadedStrings+    QuasiQuotes+    RequiredTypeArguments+    TypeFamilyDependencies++  -- other-extensions:+  -- The interface type and version of the test suite.+  type: exitcode-stdio-1.0+  -- Directories containing source files.+  hs-source-dirs: test+  -- The entrypoint to the test suite.+  main-is: Main.hs+  other-modules: Relationships+  -- Test dependencies.+  build-depends:+    base ^>=4.21.0.0,+    containers,+    data-default,+    mischief-ecs,+    primitive,+    random,+    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,+    random >=1.3.1 && <1.4,+    transformers >=0.6.1 && <0.7,++  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,+    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,++  default-extensions:+    DeriveAnyClass+    DuplicateRecordFields+    NoFieldSelectors+    NoGeneralizedNewtypeDeriving+    OverloadedRecordDot+    OverloadedStrings+    QuasiQuotes+    RequiredTypeArguments+    TemplateHaskell+    TypeFamilyDependencies++benchmark bench-insert+  type: exitcode-stdio-1.0+  main-is: bench-insert.hs+  hs-source-dirs: benchmarks+  default-language: GHC2024+  build-depends:+    base >=4.21.0 && <4.22,+    containers >=0.7 && <0.8,+    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,++  default-extensions:+    DeriveAnyClass+    DuplicateRecordFields+    NoFieldSelectors+    NoGeneralizedNewtypeDeriving+    OverloadedRecordDot+    OverloadedStrings+    QuasiQuotes+    RequiredTypeArguments+    TemplateHaskell+    TypeFamilyDependencies++benchmark bench-update+  type: exitcode-stdio-1.0+  main-is: bench-update.hs+  hs-source-dirs: benchmarks+  default-language: GHC2024+  build-depends:+    base >=4.21.0 && <4.22,+    containers >=0.7 && <0.8,+    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,++  default-extensions:+    DeriveAnyClass+    DuplicateRecordFields+    NoFieldSelectors+    NoGeneralizedNewtypeDeriving+    OverloadedRecordDot+    OverloadedStrings+    QuasiQuotes+    RequiredTypeArguments+    TemplateHaskell+    TypeFamilyDependencies
+ src/Mischief/ECS.hs view
@@ -0,0 +1,197 @@+{-# OPTIONS_GHC -Wno-unused-top-binds #-}++-- |+--+-- Module: ECS+-- Description: The ECS standing at the core of Mischief.+--+-- 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!+    -- $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.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.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.Remove,+    module Mischief.ECS.World.Spawn,+    module Mischief.ECS.World.Utils,+    TestTest (..),+  )+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 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.++-- $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:+--+-- * __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..+--+--+-- == Performance+--+-- 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:+--+-- (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")
+ src/Mischief/ECS/App.hs view
@@ -0,0 +1,173 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++module Mischief.ECS.App where++-- import Data.Map+-- import Data.Map qualified as Map++import Control.Monad (forever, void)+import Control.Monad.IO.Class (MonadIO (liftIO))+import Control.Monad.Reader (MonadReader (..), asks)+import Control.Monad.Trans.Reader (ReaderT (..))+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 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.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++data App = App+  { world :: World,+    systems :: Systems+  }++newApp :: (Plugin p) => p -> IO App+newApp plugin = do+  world <- newWorld getTools+  systems <- Systems.newSystems++  let app = App {world, systems}++  runSystem appInit app.world+  runSystem (Systems.add Init $ runPluginRec plugin) app.world++  return 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))++  liftIO $ runSchedules startups+  liftIO $ runSchedulesLoop updates+  where+    runSchedulesLoop schedules = do+      forever $ do+        runSchedules schedules+        modifyIORef' app.world.frame (\(Frame x) -> Frame $ x + 1)++    runSchedules schedules =+      for_ schedules $ \schedule -> do+        runSystem (runSchedule' schedule) app.world++runSchedule :: (Schedule sch) => sch -> System ()+runSchedule sch = scheduleEntity sch >>= runSchedule'++runSchedule' :: Entity -> System ()+runSchedule' schedule = do+  world <- unsafeGetWorld+  systems <- orderEntities =<< query' E (With (R @ScheduledIn schedule))++  for_ systems $ \systemId -> do+    Just (systemFunction, lastSystemTick) <- get (C @SystemFunction, C @SystemTick) systemId+    currentSystemTick <- liftIO $ readIORef world.tick++    set lastSystemTick (SystemTick currentSystemTick)+    insert (LastSystemTick lastSystemTick.inner) systemId++    Control.Monad.Reader.local (hide . setSystemId (SystemId systemId) . unhide) $ do+      systemFunction.inner+      flush+      flushAsync+      flushEvents+      tick++appInit :: System ()+appInit = do+  insertRes $ def @Schedules++  systems <- liftIO Systems.newSystems+  insertRes systems++  init <- scheduleEntity Init+  pre <- scheduleEntity PreStartup+  startup <- scheduleEntity Startup+  post <- scheduleEntity PostStartup++  for_ [init, 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++  for_ [first, pre, update, post] $ insert UpdateSchedule++  insert (Rel Before pre) first+  insert (Rel Before update) pre+  insert (Rel Before post) update++register :: forall c. (Runnable c) => System ()+register = runFor @c registerComponent++registerComponent :: forall c. (Component c) => Proxy c -> System ()+registerComponent c = do+  _ <- getOrAddComponentId (ComponentType c)+  return ()++getTools :: SystemTools+getTools =+  SystemTools+    { get = toolsGet,+      getRAny = toolsGetRAny,+      set = toolsSet,+      spawnByInsert = toolsSpawnByInsert+    }++toolsGet :: forall c m w. (MonadSystem w m, QueryType c) => Proxy c -> Entity -> m (Maybe c)+toolsGet _ = get (Val (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))++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)++-- | Increment the World's Tick.+tick :: System ()+tick = do+  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
+ src/Mischief/ECS/App/Plugins.hs view
@@ -0,0 +1,56 @@+{- HLINT ignore "Use newtype instead of data" -}+module Mischief.ECS.App.Plugins where++import Data.Foldable+import Data.Map (Map)+import Data.Map qualified as Map+import Data.Typeable+import Mischief.ECS.Collectable+import Mischief.ECS.Components.Bundle+import Mischief.ECS.Components.Common+import Mischief.ECS.World+import Unsafe.Coerce++class (Typeable p, Eq p) => Plugin p where+  plugins :: p -> Plugins+  plugins _ = collect ()++  init :: p -> System ()+  init _ = pure ()++data ErasedPlugin where+  ErasedPlugin :: (Plugin p, Eq p) => p -> ErasedPlugin++getInit :: ErasedPlugin -> System ()+getInit (ErasedPlugin p) = Mischief.ECS.App.Plugins.init p++newtype Plugins = Plugins {inner :: [ErasedPlugin]} deriving newtype (Semigroup, Monoid)++instance (Plugin p) => EraseIntoStorage p Plugins where+  erase p = Plugins [ErasedPlugin p]++instance {-# OVERLAPPING #-} EraseIntoStorage () Plugins where+  erase _ = Plugins []++newtype PluginData = PluginData {inner :: Map TypeRep ErasedPlugin}++instance Show PluginData where+  show p = show $ map fst $ Map.toList p.inner++plug :: (Collectable p Plugins) => p -> Plugins+plug = collect++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++plugAll :: (Plugin p) => p -> PluginData+plugAll p = addErasedRec (ErasedPlugin p) (PluginData Map.empty)++runPluginRec :: (Plugin p) => p -> System ()+runPluginRec p = for_ (map snd $ Map.toList (plugAll p).inner) getInit
+ src/Mischief/ECS/App/Schedules.hs view
@@ -0,0 +1,64 @@+module Mischief.ECS.App.Schedules where++import Data.Data+import Data.Default+import Data.Map (Map)+import Data.Map qualified as Map+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}+  deriving stock (Eq, Ord, Show)+  deriving anyclass (Component)++class (Typeable s) => Schedule s++data Init = Init deriving (Schedule, Show)++data PreStartup = PreStartup deriving (Schedule)++data Startup = Startup deriving (Schedule, Show)++data PostStartup = PostStartup deriving (Schedule)++data First = First deriving (Schedule, Show)++data Update = Update deriving (Schedule, Show)++data PreUpdate = PreUpdate deriving (Schedule)++data PostUpdate = PostUpdate deriving (Schedule)++data StartupSchedule = StartupSchedule deriving (Component)++data UpdateSchedule = UpdateSchedule deriving (Component)++newtype ScheduleId = ScheduleId {id :: Entity} deriving (Ord, Eq, Show)++newtype Schedules = Schedules {inner :: Map TypeRep ScheduleId}+  deriving stock (Generic)+  deriving anyclass (Component, Default)++getScheduleId :: ScheduleLabel -> System ScheduleId+getScheduleId sch = do+  Just schedules <- res @Schedules+  case Map.lookup sch.rep schedules.inner of+    Just x -> return x+    Nothing -> do+      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+  return id++-- runSystemsIn :: (Schedule sch) => sch -> System ()
+ src/Mischief/ECS/App/SystemConfig.hs view
@@ -0,0 +1,42 @@+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}
+ src/Mischief/ECS/App/SystemDef.hs view
@@ -0,0 +1,14 @@+module Mischief.ECS.App.SystemDef where++import Data.Default+import GHC.Generics+import Mischief.ECS.Components+import Mischief.ECS.World++newtype SystemTick = SystemTick {inner :: Tick}+  deriving stock (Generic)+  deriving anyclass (Component, Default)++newtype LastSystemTick = LastSystemTick {inner :: Tick}+  deriving stock (Generic)+  deriving anyclass (Component, Default)
+ src/Mischief/ECS/App/Systems.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++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+  { systemMap :: IORef (Map (ScheduleId, Int) (IORef [(StableName (System ()), SystemId)]))+  }+  deriving anyclass (Component)++newtype SystemFunction = SystemFunction {inner :: System ()}++instance Component SystemFunction where+  required = require @(SystemTick, LastSystemTick)++newSystems :: IO Systems+newSystems = do+  systemMap <- newIORef Map.empty+  return Systems {systemMap}++getSystemId' :: (HasCallStack) => ScheduleId -> System () -> StableName (System ()) -> IORef [(StableName (System ()), SystemId)] -> System SystemId+getSystemId' schedule system stableName list = do+  list' <- liftIO $ readIORef list+  case find (\x -> fst x `eqStableName` stableName) list' of+    Just (_, x) -> return x+    Nothing -> do+      index <- spawn (SystemFunction system, Rel ScheduledIn schedule.id)+      liftIO $ modifyIORef' list (++ [(stableName, SystemId index)])+      return $ SystemId index++getSystemId :: (HasCallStack) => ScheduleId -> System () -> System SystemId+getSystemId sch system = do+  Systems {systemMap} <- unwrap <$> (res @Systems)++  stableName <- liftIO $ makeStableName system+  systemMap' <- liftIO $ readIORef systemMap++  case Map.lookup (sch, hashStableName stableName) systemMap' of+    Just x -> getSystemId' sch system stableName x+    Nothing -> do+      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+  liftIO $ modifyIORef' list $ filter (\x -> not $ fst x `eqStableName` stableName)++removeSystemFromMap :: ScheduleId -> System () -> System ()+removeSystemFromMap sch system = do+  Systems {systemMap} <- unwrap <$> (res @Systems)++  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++self :: forall m w. (MonadSystem w m) => m Entity+self = do+  world <- unsafeGetWorld+  let (SystemId sys) = world.systemId+  return sys++data ScheduledIn = ScheduledIn deriving (Component)++getSystemTicks :: World -> IO (Tick, Tick)+getSystemTicks world = do+  let (SystemId sys) = world.systemId+  runSystem+    ( do+        Just (a, b) <- get (C @LastSystemTick, C @SystemTick) sys+        return (a.inner, b.inner)+    )+    world
+ src/Mischief/ECS/Archetypes.hs view
@@ -0,0 +1,45 @@+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+import Mischief.ECS.Vec+import Mischief.ECS.Vec qualified as Vec++newtype Archetypes = Archetypes {graph :: ArchetypeGraph}++data ArchetypeGraph = ArchetypeGraph {nodes :: IOVec ArchetypeNode, lookup :: IORef (Map (Set ComponentId) Int), counter :: IORef Int}++newArchetypeGraph :: IO ArchetypeGraph+newArchetypeGraph = do+  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}++data ArchetypeNode = ArchetypeNode+  { archetype :: ArchetypeData,+    insert :: Map ComponentId Int,+    remove :: Map ComponentId Int+  }++data ArchetypeData = ArchetypeData+  { id :: ArchetypeId,+    components :: Set ComponentId+  }++-- Construct an empty 'Archetypes'.+emptyArchetypes :: IO Archetypes+emptyArchetypes =+  Archetypes <$> newArchetypeGraph
+ src/Mischief/ECS/Archetypes/Graph.hs view
@@ -0,0 +1,267 @@+module Mischief.ECS.Archetypes.Graph where++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)+import Data.Set qualified as Set+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+  modifyIORef' counter (+ 1)+  return x++createNode :: Set ComponentId -> System Int+createNode components = do+  world <- unsafeGetWorld+  let Archetypes {graph} = world.archetypes++  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}++  -- comps <-+  --   mapM+  --     ( \(ComponentId (# id, _ #)) -> do+  --         t <- worldGet (Proxy @ComponentType) (Entity (# id, 0## #))+  --         return $ fmap getRep t+  --     )+  --     (Set.toList components)++  -- debug $ "archetype " <> text id <> " = " <> text (catMaybes comps)++  let Tables tables = world.tables+  Vec.pushBack tables =<< liftIO (newTable $ Set.toList components)++  for_ components $ \(ComponentId (# id', target' #)) -> do+    case target' of+      -- Component isn't a pair.+      Nothing -> do+        set <- worldGet (Proxy @ComponentArchetypes) (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+        set <- worldGet (Proxy @ComponentPairs) (Entity (# id', 0## #))+        for_ set $ \set -> do+          let ComponentPairs {any, pairs} = set+          flip worldSet (Entity (# id', 0## #)) $+            ComponentPairs+              { any = Set.insert (ArchetypeId id) any,+                pairs =+                  Map.alter+                    ( \case+                        Nothing -> Just $ Set.singleton $ ArchetypeId id+                        Just s -> Just $ Set.insert (ArchetypeId id) s+                    )+                    e+                    pairs+              }++  return id++getOrCreateNode :: Set ComponentId -> System Int+getOrCreateNode components = do+  world <- unsafeGetWorld+  let Archetypes {graph} = world.archetypes++  lookup <- liftIO $ readIORef graph.lookup+  case Map.lookup components lookup of+    Just x -> return x+    Nothing -> createNode components++addEdge :: Int -> Int -> ComponentId -> System ()+addEdge a b component = do+  world <- unsafeGetWorld+  let Archetypes {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+  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+  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++  node <- Vec.read graph.nodes id++  case Map.lookup component node.remove of+    Just x -> do+      newNode <- Vec.read graph.nodes x+      return newNode.archetype+    Nothing -> do+      let components = node.archetype.components+      -- TODO: check if another component requires this one!++      let newComponents = Set.delete component components+      newId <- getOrCreateNode newComponents+      addEdgeR newId id component++      newNode <- Vec.read graph.nodes newId+      return newNode.archetype++getArchetypeOnInsertSingle :: ArchetypeId -> ComponentId -> System ArchetypeData+getArchetypeOnInsertSingle (ArchetypeId id) component = do+  world <- unsafeGetWorld+  let Archetypes {graph} = world.archetypes++  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+    Nothing -> do+      components <- do+        let components = node.archetype.components++        let !(ComponentId (# id, _ #)) = component++        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+          _ ->+            return components++      requirements <- getRequirements component++      let newComponents = Set.union (Set.insert component components) requirements++      newId <- getOrCreateNode newComponents+      addEdgeI id newId component++      newNode <- Vec.read graph.nodes newId+      return newNode.archetype++getArchetypeOnInsert :: ArchetypeId -> [ComponentId] -> System ArchetypeData+getArchetypeOnInsert archetype components =+  do+    world <- unsafeGetWorld+    let Archetypes {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 x xs graph++newtype ArchetypeRemovalResult = ArchetypeRemovalResult {removed :: [ComponentId]}++getArchetypeOnRemove :: ArchetypeId -> [ComponentId] -> System (ArchetypeData, [ComponentId])+getArchetypeOnRemove archetype components =+  do+    world <- unsafeGetWorld+    let Archetypes {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++      (a, b) <- f x xs graph+      if x.id /= archetype.id+        then return (a, b ++ [component])+        else return (a, b)++getArchetypeOnSpawn :: [ComponentId] -> System ArchetypeData+getArchetypeOnSpawn components =+  do+    world <- unsafeGetWorld+    let Archetypes {graph} = world.archetypes++    regs <- mapM getRequirements components++    let allComps = foldr' (flip Set.union) (Set.fromList components) regs+    node <- getOrCreateNode allComps++    nodeData <- Vec.read graph.nodes node++    return nodeData.archetype++getRequirements :: ComponentId -> System (Set ComponentId)+getRequirements (ComponentId (# id, _ #)) = do+  x <- worldGetRAny (Proxy @Requires) (Entity (# id, 0## #))+  return $ case x of+    Nothing -> Set.empty+    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 [] _ = allArchetypes+findMatchingArchetypes components Archetypes {graph} = do+  archetypes'' <- forM components $ \(ComponentId (# id, target #), q) -> do+    case q of+      ComponentQuery -> do+        Just x <- worldGet (Proxy @ComponentArchetypes) (Entity (# id, 0## #))+        return x.inner+      RelationshipQueryAny -> do+        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## #))+            return $ fromMaybe undefined $ Map.lookup target x.pairs++  case map Set.toList archetypes'' of+    [] -> return []+    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)+        )+        archetypes++allArchetypes :: forall m w. (MonadSystem w m) => m [([ComponentId], ArchetypeId)]+allArchetypes = do+  world <- unsafeGetWorld+  map (\x -> (Set.toList x.archetype.components, x.archetype.id)) <$> Vec.toList world.archetypes.graph.nodes
+ src/Mischief/ECS/Collectable.hs view
@@ -0,0 +1,54 @@+module Mischief.ECS.Collectable where++class Idk x y++class (Semigroup s) => EraseIntoStorage v s where+  erase :: v -> s++class Collectable v storage where+  collect :: v -> storage++instance (EraseIntoStorage v storage) => Collectable v storage where+  collect = erase++instance {-# OVERLAPPING #-} (Semigroup s, Collectable a0 s, Collectable a1 s) => Collectable (a0, a1) s where+  collect (a0, a1) = foldr (<>) (collect a0) [collect a1]++instance {-# OVERLAPPING #-} (Semigroup s, Collectable a0 s, Collectable a1 s, Collectable a2 s) => Collectable (a0, a1, a2) s where+  collect (a0, a1, a2) = foldr (<>) (collect a0) [collect a1, collect a2]++instance {-# OVERLAPPING #-} (Semigroup s, Collectable a0 s, Collectable a1 s, Collectable a2 s, Collectable a3 s) => Collectable (a0, a1, a2, a3) s where+  collect (a0, a1, a2, a3) = foldr (<>) (collect a0) [collect a1, collect a2, collect a3]++instance {-# OVERLAPPING #-} (Semigroup s, Collectable a0 s, Collectable a1 s, Collectable a2 s, Collectable a3 s, Collectable a4 s) => Collectable (a0, a1, a2, a3, a4) s where+  collect (a0, a1, a2, a3, a4) = foldr (<>) (collect a0) [collect a1, collect a2, collect a3, collect a4]++instance {-# OVERLAPPING #-} (Semigroup s, Collectable a0 s, Collectable a1 s, Collectable a2 s, Collectable a3 s, Collectable a4 s, Collectable a5 s) => Collectable (a0, a1, a2, a3, a4, a5) s where+  collect (a0, a1, a2, a3, a4, a5) = foldr (<>) (collect a0) [collect a1, collect a2, collect a3, collect a4, collect a5]++instance {-# OVERLAPPING #-} (Semigroup s, Collectable a0 s, Collectable a1 s, Collectable a2 s, Collectable a3 s, Collectable a4 s, Collectable a5 s, Collectable a6 s) => Collectable (a0, a1, a2, a3, a4, a5, a6) s where+  collect (a0, a1, a2, a3, a4, a5, a6) = foldr (<>) (collect a0) [collect a1, collect a2, collect a3, collect a4, collect a5, collect a6]++instance {-# OVERLAPPING #-} (Semigroup s, Collectable a0 s, Collectable a1 s, Collectable a2 s, Collectable a3 s, Collectable a4 s, Collectable a5 s, Collectable a6 s, Collectable a7 s) => Collectable (a0, a1, a2, a3, a4, a5, a6, a7) s where+  collect (a0, a1, a2, a3, a4, a5, a6, a7) = foldr (<>) (collect a0) [collect a1, collect a2, collect a3, collect a4, collect a5, collect a6, collect a7]++instance {-# OVERLAPPING #-} (Semigroup s, Collectable a0 s, Collectable a1 s, Collectable a2 s, Collectable a3 s, Collectable a4 s, Collectable a5 s, Collectable a6 s, Collectable a7 s, Collectable a8 s) => Collectable (a0, a1, a2, a3, a4, a5, a6, a7, a8) s where+  collect (a0, a1, a2, a3, a4, a5, a6, a7, a8) = foldr (<>) (collect a0) [collect a1, collect a2, collect a3, collect a4, collect a5, collect a6, collect a7, collect a8]++instance {-# OVERLAPPING #-} (Semigroup s, Collectable a0 s, Collectable a1 s, Collectable a2 s, Collectable a3 s, Collectable a4 s, Collectable a5 s, Collectable a6 s, Collectable a7 s, Collectable a8 s, Collectable a9 s) => Collectable (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) s where+  collect (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) = foldr (<>) (collect a0) [collect a1, collect a2, collect a3, collect a4, collect a5, collect a6, collect a7, collect a8, collect a9]++instance {-# OVERLAPPING #-} (Semigroup s, Collectable a0 s, Collectable a1 s, Collectable a2 s, Collectable a3 s, Collectable a4 s, Collectable a5 s, Collectable a6 s, Collectable a7 s, Collectable a8 s, Collectable a9 s, Collectable a10 s) => Collectable (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) s where+  collect (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) = foldr (<>) (collect a0) [collect a1, collect a2, collect a3, collect a4, collect a5, collect a6, collect a7, collect a8, collect a9, collect a10]++instance {-# OVERLAPPING #-} (Semigroup s, Collectable a0 s, Collectable a1 s, Collectable a2 s, Collectable a3 s, Collectable a4 s, Collectable a5 s, Collectable a6 s, Collectable a7 s, Collectable a8 s, Collectable a9 s, Collectable a10 s, Collectable a11 s) => Collectable (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11) s where+  collect (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11) = foldr (<>) (collect a0) [collect a1, collect a2, collect a3, collect a4, collect a5, collect a6, collect a7, collect a8, collect a9, collect a10, collect a11]++instance {-# OVERLAPPING #-} (Semigroup s, Collectable a0 s, Collectable a1 s, Collectable a2 s, Collectable a3 s, Collectable a4 s, Collectable a5 s, Collectable a6 s, Collectable a7 s, Collectable a8 s, Collectable a9 s, Collectable a10 s, Collectable a11 s, Collectable a12 s) => Collectable (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12) s where+  collect (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12) = foldr (<>) (collect a0) [collect a1, collect a2, collect a3, collect a4, collect a5, collect a6, collect a7, collect a8, collect a9, collect a10, collect a11, collect a12]++instance {-# OVERLAPPING #-} (Semigroup s, Collectable a0 s, Collectable a1 s, Collectable a2 s, Collectable a3 s, Collectable a4 s, Collectable a5 s, Collectable a6 s, Collectable a7 s, Collectable a8 s, Collectable a9 s, Collectable a10 s, Collectable a11 s, Collectable a12 s, Collectable a13 s) => Collectable (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13) s where+  collect (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13) = foldr (<>) (collect a0) [collect a1, collect a2, collect a3, collect a4, collect a5, collect a6, collect a7, collect a8, collect a9, collect a10, collect a11, collect a12, collect a13]++instance {-# OVERLAPPING #-} (Semigroup s, Collectable a0 s, Collectable a1 s, Collectable a2 s, Collectable a3 s, Collectable a4 s, Collectable a5 s, Collectable a6 s, Collectable a7 s, Collectable a8 s, Collectable a9 s, Collectable a10 s, Collectable a11 s, Collectable a12 s, Collectable a13 s, Collectable a14 s) => Collectable (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14) s where+  collect (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14) = foldr (<>) (collect a0) [collect a1, collect a2, collect a3, collect a4, collect a5, collect a6, collect a7, collect a8, collect a9, collect a10, collect a11, collect a12, collect a13, collect a14]
+ src/Mischief/ECS/Components.hs view
@@ -0,0 +1,305 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++module Mischief.ECS.Components+  ( -- * Component+    Component (..),+    ComponentId (..),+    Exclusivity (..),++    -- * Meta+    ComponentArchetypes (..),+    ComponentPairs (..),+    DefaultValue (..),+    Requires (..),+    RequiredBy (..),+    ComponentType (..),++    -- * Erasure+    ErasedComponent (..),+    tryGetComponent,+    DefaultComponentType (..),++    -- * Archetypes+    ArchetypeId (..),++    -- * Bundles+    BundleData (..),+    BundleElement (..),++    -- * Tables+    ComponentTicks (..),+    ComponentData (..),++    -- * Storage+    Components (..),+    emptyComponents,+    getComponentId,++    -- * Utils+    Pair (..),+    Rel (..),+    ComponentRep (..),+    Tick (..),+    ErasedComponentEq (..),+    IsExclusive (..),+    isPair,+    setCompIdTarget,+  )+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 GHC.Base (Word (W#), Word#, compareWord#, eqWord#, isTrue#)+import GHC.Generics+import Mischief.ECS.Collectable+import Mischief.ECS.Components.HooksDef+import Mischief.ECS.EntityDef+import Mischief.ECS.Utils++data Exclusivity = Inclusive | Exclusive++-- | The @Component@ typeclass.+class (Typeable c, IsExclusive (RelExclusivity c)) => Component c where+  -- | List of components required by this one.+  -- All required components must be 'Default'+  --+  -- Example+  --+  -- @+  -- data A = A+  -- instance 'Component' A where+  --   'required' = 'Mischief.ECS.Components.Required.require' @(B, C)+  --+  -- data B = B 'Int' deriving ('Component', 'Generic', 'Default')+  --+  -- data C = C 'String' deriving ('Component')+  -- instance 'Default' C where+  --   'def' = C "Default String"+  -- @+  required :: Set DefaultComponentType+  required = Set.empty++  type RelExclusivity c :: Exclusivity+  type RelExclusivity c = Inclusive++  hooks :: Hooks c+  hooks = Hooks []++class IsExclusive (e :: Exclusivity) where+  isExclusive :: Bool++instance IsExclusive Inclusive where+  isExclusive = False++instance IsExclusive Exclusive where+  isExclusive = True++-- | Unique id for components and component pairs.+data ComponentId = ComponentId (# Word#, Maybe Entity #)++instance Eq ComponentId where+  (==) :: ComponentId -> ComponentId -> Bool+  (==) (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 #))) =+    case compareWord# a x of+      EQ -> compare b y+      x -> x++-- { -- | The component's entity.+--   id :: Entity,+--   -- | Optional target entity in case this is a pair / relationship.+--   entity :: Maybe Entity+-- }+-- deriving (Show, Eq, Ord)++isPair :: ComponentId -> Bool+isPair (ComponentId (# _, Just _ #)) = True+isPair _ = False++setCompIdTarget :: Maybe Entity -> ComponentId -> ComponentId+setCompIdTarget Nothing (ComponentId (# a, _ #)) = ComponentId (# a, Nothing #)+setCompIdTarget (Just e) (ComponentId (# a, _ #)) = ComponentId (# a, Just e #)++newtype Pair = Pair (ComponentType, Entity)++type HashMap k v = H.BasicHashTable k v++-- | Contains data and methods for assigning 'ComponentId's to new components (via their 'TypeRep').+newtype Components = Components+  { -- | Maps 'TypeRep's to Ints, to be used as the first half of a 'ComponentId'.+    components :: HashMap TypeRep Word+  }++-- | @Meta@ component with a set of all archetypes that a components is part of.+newtype ComponentArchetypes = ComponentArchetypes {inner :: Set ArchetypeId}+  deriving anyclass (Component)+  deriving newtype (Default)+  deriving stock (Show)++-- | @Meta@ component with a set of all archetypes containing pairs made with this component.+data ComponentPairs = ComponentPairs+  { -- | Archetypes that contain any pair formed with this component.+    any :: Set ArchetypeId,+    -- | Specific archetypes between this component and a particular entity.+    pairs :: Map Entity (Set ArchetypeId)+  }+  deriving anyclass (Component, Default)+  deriving stock (Show, Generic)++-- | Construct an empty 'Components'.+emptyComponents :: IO Components+emptyComponents = Components <$> H.new++-- | 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+    Nothing -> 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')) =+  case eqT @c @c' of+    Just Refl -> Just s+    Nothing -> Nothing++instance {-# OVERLAPPING #-} EraseIntoStorage () (BundleData ErasedComponent) where+  erase _ = BundleData 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}++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}++instance (Component c, Eq c) => EraseIntoStorage c (BundleData ErasedComponentEq) where+  erase c =+    BundleData $ Set.singleton BundleElement {rep = ComponentRep $ ComponentType $ Proxy @c, component = ErasedComponentEq c}++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}++-- | Unique id corresponding to an archetype.+newtype ArchetypeId = ArchetypeId+  { id :: Int+  }+  deriving (Show, Eq, Ord)++-- | Data extracted from a 'Mischief.ECS.Components.Bundle.Bundle'.+newtype BundleData e = BundleData {elements :: Set (BundleElement e)} deriving newtype (Semigroup)++instance Show (BundleData e) where+  show BundleData {elements} = mconcat ["BundleData e [", List.intercalate ", " ts, "]"]+    where+      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}++-- | Type used for querying and inserting relationships.+data Rel c = Rel {comp :: c, target :: Entity} deriving (Show)++-- | @Meta@ component with the /erased/ default value of this component. Added to components required by other components.+newtype DefaultValue = DefaultValue ErasedComponent deriving anyclass (Component)++instance Component ComponentType where+  required = Set.fromList [DefaultComponentType $ Proxy @ComponentArchetypes, DefaultComponentType $ Proxy @ComponentPairs]++-- | @Meta@ relationship.+data RequiredBy = RequiredBy deriving (Component)++-- | @Meta@ relationship.+data Requires = Requires deriving (Component)++-- | Type for component erasure.+data ErasedComponent where+  ErasedComponent :: (Component c) => c -> ErasedComponent++data ErasedComponentEq where+  ErasedComponentEq :: (Component c, Eq c) => c -> ErasedComponentEq++data ComponentRep = ComponentRep ComponentType | PairRep (ComponentType, Entity) deriving (Show, Eq, Ord)++-- | Element of a 'BundleData e'.+data BundleElement e = BundleElement {rep :: ComponentRep, component :: e}++instance Show (BundleElement a) where+  show :: BundleElement a -> String+  show e = show e.rep++instance Eq (BundleElement a) where+  (==) :: BundleElement a -> BundleElement a -> Bool+  (==) 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++-- @Meta@ component containing the erased type of this component.+data ComponentType where+  ComponentType :: forall (c :: Type). (Component c) => (Proxy c) -> ComponentType++instance Show ComponentType where+  show :: ComponentType -> String+  show x = show $ getRep x++instance Eq ComponentType where+  (==) :: ComponentType -> ComponentType -> Bool+  (==) a b = getRep a == getRep b++instance Ord ComponentType where+  compare :: ComponentType -> ComponentType -> Ordering+  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++instance Eq DefaultComponentType where+  (==) :: DefaultComponentType -> DefaultComponentType -> Bool+  (==) a b = getRep a == getRep b++instance Ord DefaultComponentType where+  compare :: DefaultComponentType -> DefaultComponentType -> Ordering+  compare a b = compare (getRep a) (getRep b)++instance GetRep ComponentType where+  getRep :: ComponentType -> TypeRep+  getRep (ComponentType (_ :: (Proxy t))) = typeRep $ Proxy @t++instance GetRep ErasedComponent where+  getRep :: ErasedComponent -> TypeRep+  getRep (ErasedComponent (_ :: c)) = typeRep $ Proxy @c++instance GetRep DefaultComponentType where+  getRep :: DefaultComponentType -> TypeRep+  getRep (DefaultComponentType (_ :: (Proxy t))) = typeRep $ Proxy @t++newtype Tick = Tick (Int, Int)+  deriving stock (Show, Eq, Ord)+  deriving newtype (Default)
+ src/Mischief/ECS/Components/Bundle.hs view
@@ -0,0 +1,41 @@+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++module Mischief.ECS.Components.Bundle where++import Data.Set qualified as Set+import Data.Typeable+import Mischief.ECS.Collectable (Collectable (collect))+import Mischief.ECS.Components++newtype ProcessedBundleData = ProcessedBundleData {elements :: [ProcessedBundleElement]}++data ProcessedBundleElement = ProcessedBundleElement {id :: ComponentId, component :: ComponentData}++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)}++instance Eq ProcessedBundleElement where+  (==) :: ProcessedBundleElement -> ProcessedBundleElement -> Bool+  (==) 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++type Bundle b = Collectable b (BundleData ErasedComponent)++bundleData :: (Bundle b) => b -> BundleData ErasedComponent+bundleData = 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
+ src/Mischief/ECS/Components/BundleTypes.hs view
@@ -0,0 +1,55 @@+module Mischief.ECS.Components.BundleTypes where++import Data.Data+import Data.Set (Set)+import Data.Set qualified as Set+import Mischief.ECS.Components++class BundleTypes t where+  types :: Proxy t -> Set TypeRep++instance {-# OVERLAPPABLE #-} (Component c) => BundleTypes c where+  types :: Proxy c -> Set TypeRep+  types = Set.singleton . typeRep++instance {-# OVERLAPPING #-} (BundleTypes t0, BundleTypes t1) => BundleTypes (t0, t1) where+  types _ = Set.unions [types $ Proxy @t0, types $ Proxy @t1]++instance {-# OVERLAPPING #-} (BundleTypes t0, BundleTypes t1, BundleTypes t2) => BundleTypes (t0, t1, t2) where+  types _ = Set.unions [types $ Proxy @t0, types $ Proxy @t1, types $ Proxy @t2]++instance {-# OVERLAPPING #-} (BundleTypes t0, BundleTypes t1, BundleTypes t2, BundleTypes t3) => BundleTypes (t0, t1, t2, t3) where+  types _ = Set.unions [types $ Proxy @t0, types $ Proxy @t1, types $ Proxy @t2, types $ Proxy @t3]++instance {-# OVERLAPPING #-} (BundleTypes t0, BundleTypes t1, BundleTypes t2, BundleTypes t3, BundleTypes t4) => BundleTypes (t0, t1, t2, t3, t4) where+  types _ = Set.unions [types $ Proxy @t0, types $ Proxy @t1, types $ Proxy @t2, types $ Proxy @t3, types $ Proxy @t4]++instance {-# OVERLAPPING #-} (BundleTypes t0, BundleTypes t1, BundleTypes t2, BundleTypes t3, BundleTypes t4, BundleTypes t5) => BundleTypes (t0, t1, t2, t3, t4, t5) where+  types _ = Set.unions [types $ Proxy @t0, types $ Proxy @t1, types $ Proxy @t2, types $ Proxy @t3, types $ Proxy @t4, types $ Proxy @t5]++instance {-# OVERLAPPING #-} (BundleTypes t0, BundleTypes t1, BundleTypes t2, BundleTypes t3, BundleTypes t4, BundleTypes t5, BundleTypes t6) => BundleTypes (t0, t1, t2, t3, t4, t5, t6) where+  types _ = Set.unions [types $ Proxy @t0, types $ Proxy @t1, types $ Proxy @t2, types $ Proxy @t3, types $ Proxy @t4, types $ Proxy @t5, types $ Proxy @t6]++instance {-# OVERLAPPING #-} (BundleTypes t0, BundleTypes t1, BundleTypes t2, BundleTypes t3, BundleTypes t4, BundleTypes t5, BundleTypes t6, BundleTypes t7) => BundleTypes (t0, t1, t2, t3, t4, t5, t6, t7) where+  types _ = Set.unions [types $ Proxy @t0, types $ Proxy @t1, types $ Proxy @t2, types $ Proxy @t3, types $ Proxy @t4, types $ Proxy @t5, types $ Proxy @t6, types $ Proxy @t7]++instance {-# OVERLAPPING #-} (BundleTypes t0, BundleTypes t1, BundleTypes t2, BundleTypes t3, BundleTypes t4, BundleTypes t5, BundleTypes t6, BundleTypes t7, BundleTypes t8) => BundleTypes (t0, t1, t2, t3, t4, t5, t6, t7, t8) where+  types _ = Set.unions [types $ Proxy @t0, types $ Proxy @t1, types $ Proxy @t2, types $ Proxy @t3, types $ Proxy @t4, types $ Proxy @t5, types $ Proxy @t6, types $ Proxy @t7, types $ Proxy @t8]++instance {-# OVERLAPPING #-} (BundleTypes t0, BundleTypes t1, BundleTypes t2, BundleTypes t3, BundleTypes t4, BundleTypes t5, BundleTypes t6, BundleTypes t7, BundleTypes t8, BundleTypes t9) => BundleTypes (t0, t1, t2, t3, t4, t5, t6, t7, t8, t9) where+  types _ = Set.unions [types $ Proxy @t0, types $ Proxy @t1, types $ Proxy @t2, types $ Proxy @t3, types $ Proxy @t4, types $ Proxy @t5, types $ Proxy @t6, types $ Proxy @t7, types $ Proxy @t8, types $ Proxy @t9]++instance {-# OVERLAPPING #-} (BundleTypes t0, BundleTypes t1, BundleTypes t2, BundleTypes t3, BundleTypes t4, BundleTypes t5, BundleTypes t6, BundleTypes t7, BundleTypes t8, BundleTypes t9, BundleTypes t10) => BundleTypes (t0, t1, t2, t3, t4, t5, t6, t7, t8, t9, t10) where+  types _ = Set.unions [types $ Proxy @t0, types $ Proxy @t1, types $ Proxy @t2, types $ Proxy @t3, types $ Proxy @t4, types $ Proxy @t5, types $ Proxy @t6, types $ Proxy @t7, types $ Proxy @t8, types $ Proxy @t9, types $ Proxy @t10]++instance {-# OVERLAPPING #-} (BundleTypes t0, BundleTypes t1, BundleTypes t2, BundleTypes t3, BundleTypes t4, BundleTypes t5, BundleTypes t6, BundleTypes t7, BundleTypes t8, BundleTypes t9, BundleTypes t10, BundleTypes t11) => BundleTypes (t0, t1, t2, t3, t4, t5, t6, t7, t8, t9, t10, t11) where+  types _ = Set.unions [types $ Proxy @t0, types $ Proxy @t1, types $ Proxy @t2, types $ Proxy @t3, types $ Proxy @t4, types $ Proxy @t5, types $ Proxy @t6, types $ Proxy @t7, types $ Proxy @t8, types $ Proxy @t9, types $ Proxy @t10, types $ Proxy @t11]++instance {-# OVERLAPPING #-} (BundleTypes t0, BundleTypes t1, BundleTypes t2, BundleTypes t3, BundleTypes t4, BundleTypes t5, BundleTypes t6, BundleTypes t7, BundleTypes t8, BundleTypes t9, BundleTypes t10, BundleTypes t11, BundleTypes t12) => BundleTypes (t0, t1, t2, t3, t4, t5, t6, t7, t8, t9, t10, t11, t12) where+  types _ = Set.unions [types $ Proxy @t0, types $ Proxy @t1, types $ Proxy @t2, types $ Proxy @t3, types $ Proxy @t4, types $ Proxy @t5, types $ Proxy @t6, types $ Proxy @t7, types $ Proxy @t8, types $ Proxy @t9, types $ Proxy @t10, types $ Proxy @t11, types $ Proxy @t12]++instance {-# OVERLAPPING #-} (BundleTypes t0, BundleTypes t1, BundleTypes t2, BundleTypes t3, BundleTypes t4, BundleTypes t5, BundleTypes t6, BundleTypes t7, BundleTypes t8, BundleTypes t9, BundleTypes t10, BundleTypes t11, BundleTypes t12, BundleTypes t13) => BundleTypes (t0, t1, t2, t3, t4, t5, t6, t7, t8, t9, t10, t11, t12, t13) where+  types _ = Set.unions [types $ Proxy @t0, types $ Proxy @t1, types $ Proxy @t2, types $ Proxy @t3, types $ Proxy @t4, types $ Proxy @t5, types $ Proxy @t6, types $ Proxy @t7, types $ Proxy @t8, types $ Proxy @t9, types $ Proxy @t10, types $ Proxy @t11, types $ Proxy @t12, types $ Proxy @t13]++instance {-# OVERLAPPING #-} (BundleTypes t0, BundleTypes t1, BundleTypes t2, BundleTypes t3, BundleTypes t4, BundleTypes t5, BundleTypes t6, BundleTypes t7, BundleTypes t8, BundleTypes t9, BundleTypes t10, BundleTypes t11, BundleTypes t12, BundleTypes t13, BundleTypes t14) => BundleTypes (t0, t1, t2, t3, t4, t5, t6, t7, t8, t9, t10, t11, t12, t13, t14) where+  types _ = Set.unions [types $ Proxy @t0, types $ Proxy @t1, types $ Proxy @t2, types $ Proxy @t3, types $ Proxy @t4, types $ Proxy @t5, types $ Proxy @t6, types $ Proxy @t7, types $ Proxy @t8, types $ Proxy @t9, types $ Proxy @t10, types $ Proxy @t11, types $ Proxy @t12, types $ Proxy @t13, types $ Proxy @t14]
+ src/Mischief/ECS/Components/Common.hs view
@@ -0,0 +1,14 @@+module Mischief.ECS.Components.Common where++import Mischief.ECS.Components++-- | Special component inserted automatically on most entities.+--+-- Can be inserted manually to give each entity a custom name.+newtype Name = Name String+  deriving anyclass (Component)+  deriving newtype (Eq)++instance Show Name where+  show :: Name -> String+  show (Name name) = show name
+ src/Mischief/ECS/Components/HooksDef.hs view
@@ -0,0 +1,9 @@+module Mischief.ECS.Components.HooksDef where++import Data.Data+import Mischief.ECS.EventDef++data ErasedHook c where+  ErasedHook :: forall e c m. (Event (e c), Typeable m) => (e c -> m ()) -> ErasedHook c++newtype Hooks c = Hooks [ErasedHook c] deriving newtype (Semigroup)
+ src/Mischief/ECS/Components/Required.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++module Mischief.ECS.Components.Required (require, requireAll, toBundleElement) where++import Data.Data+import Data.Default+import Data.Set (Set)+import Data.Set qualified as Set+import Mischief.ECS.Components++class RequiredBundle b where+  defaultBundleData :: Proxy b -> Set DefaultComponentType++instance RequiredBundle () where+  defaultBundleData :: Proxy () -> Set DefaultComponentType+  defaultBundleData _ = Set.empty++instance {-# OVERLAPPABLE #-} (Component c, Default c) => RequiredBundle c where+  defaultBundleData :: Proxy c -> Set DefaultComponentType+  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++require :: forall b. (RequiredBundle b) => Set DefaultComponentType+require = defaultBundleData (Proxy @b)++requireAll :: forall c. (Component c) => Set DefaultComponentType+requireAll = requireAll' $ required @c++requireAll' :: Set DefaultComponentType -> Set DefaultComponentType+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)+   in Set.difference newSet set++expandOne :: DefaultComponentType -> Set DefaultComponentType+expandOne (DefaultComponentType (_ :: (Proxy c))) = required @c++toBundleElement :: DefaultComponentType -> BundleElement ErasedComponent+toBundleElement (DefaultComponentType (_ :: (Proxy c))) = BundleElement (ComponentRep $ ComponentType $ Proxy @c) $ ErasedComponent $ def @c
+ src/Mischief/ECS/Components/Runnable.hs view
@@ -0,0 +1,25 @@+{-# 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)
+ src/Mischief/ECS/Components/Spawn.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++module Mischief.ECS.Components.Spawn where++import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Reader+import Data.Data+import Data.Default+import Data.Foldable+-- import Mischief.ECS.Components.Hooks+-- import Mischief.ECS.World.Defer+-- import Mischief.ECS.World.Insert++-- 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 #)++-- | 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)++  case w of+    Just (W# t) -> return $ ComponentId (# t, Nothing #)+    Nothing -> do+      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)++      -- l <- liftIO $ newIORef Set.empty+      -- liftIO $ modifyIORef' comp.archetypes $ Map.insert result l++      forkPrefs (supressEvents True) $+        worldSpawnByInsert+          result+          ( ( ComponentType $ Proxy @c,+              ( def @ComponentArchetypes,+                def @ComponentPairs+              )+            ),+            Name $+              "Meta entity for " ++ show (typeRep $ Proxy @c)+          )++      when (isExclusive @(RelExclusivity c)) $ do+        worldSet IsExclusiveRelationship result++      for_ (requireAll @c) $ \(DefaultComponentType (_ :: (Proxy other))) -> do+        (ComponentId (# otherId', _ #)) <- getOrAddComponentId (ComponentType $ Proxy @other)++        let otherId = Entity (# otherId', 0## #)+        worldSet (Rel RequiredBy result) otherId+        worldSet (Rel Requires otherId) result+        worldSet (DefaultValue $ ErasedComponent $ def @other) otherId++      registerHooks $ hooks @c++      return $ ComponentId (# id, Nothing #)++-- l <- liftIO $ newIORef Set.empty+-- liftIO $ modifyIORef' archetypes $ Map.insert id l++meta :: forall c. (Component c) => System Entity+meta = do+  (ComponentId (# id, _ #)) <- getOrAddComponentId (ComponentType $ Proxy @c)+  return $ 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++registerHooks :: Hooks c -> System ()+registerHooks (Hooks h) = for_ h registerHook++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
+ src/Mischief/ECS/Entities.hs view
@@ -0,0 +1,136 @@+-- {-# LANGUAGE DeriveLift #-}++module Mischief.ECS.Entities+  ( -- * Entity+    Entity (..),+    EntityPointer (..),+    getPointer,+    isAliveIO,++    -- * Storage+    Entities,+    EntityCounter,+    getNewEntity,+    removeEntity,+    insertPointer,+    getNewEntityComp,+    emptyEntities,+  )+where++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++-- | A pointer to the exact table and row that an entity is in.+--+-- The first @Int#@ is the id of its archetype. The second is the index of the row it's in.+data EntityPointer = EntityPointer (# Int#, Int# #)++-- { archetypeId :: ArchetypeId,+--   rowIndex :: Int+-- }+-- deriving (Show)++-- | A storage for entity ids and pointers.+data Entities = Entities+  { -- | Associates each @Entity@ to an @EntityPointer@.+    pointers :: IOVec (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.+    counter :: TVar EntityCounter+  }++-- | A counter and a list for recycling entities.+data EntityCounter = EntityCounter {counter :: Word#, free :: [Entity]}++-- | 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++-- | 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++  if i < l+    then do+      p <- Vec.unsafeRead entities.pointers i+      pure $ if p /= entities.nullPtr then Just p else Nothing+    else+      pure Nothing++-- | Create a new entity.+getNewEntity :: Entities -> IO Entity+getNewEntity entities = do+  (e, reused) <- 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+        writeTVar entities.counter EntityCounter {counter = counter, free = xs}+        pure (Entity (# id, plusWord# gen 1## #), True)++  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+  atomically $ do+    EntityCounter {counter, 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++  when (i < l) $ do+    Vec.unsafeWrite entities.pointers i entities.nullPtr++    atomically $ do+      EntityCounter {counter, free} <- readTVar entities.counter+      writeTVar entities.counter EntityCounter {counter, free = Entity (# i', g #) : free}++-- | 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# #)++  Vec.pushBack map nullPtr+  return $ 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++  if i < l+    then do+      p <- Vec.unsafeRead entities.pointers i+      pure $ p /= entities.nullPtr+    else pure False
+ src/Mischief/ECS/EntityDef.hs view
@@ -0,0 +1,44 @@+module Mischief.ECS.EntityDef where++import GHC.Base (Word (W#), Word#, compareWord#, eqWord#, isTrue#)++-- |+-- __UNLIFTED__+--+-- Points to an unique entity. The first @Word#@ is an id, the second is a generation.+--+-- It is guaranteed that there can't be two alive entities with the same id.+data Entity = Entity (# Word#, Word# #)++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)++instance Eq Entity where+  (==) :: Entity -> Entity -> Bool+  (==) (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 #)) =+    case compareWord# id1 id2 of+      EQ -> compareWord# gen1 gen2+      x -> x++newtype Entity# = Entity# (# Word#, Word# #)++liftEntity :: Entity# -> Entity+liftEntity (Entity# a) = Entity a++unliftEntity :: Entity -> Entity#+unliftEntity (Entity a) = Entity# a++eqEntity# :: Entity# -> Entity# -> Bool+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 #)) =+  case compareWord# id1 id2 of+    EQ -> compareWord# gen1 gen2+    x -> x
+ src/Mischief/ECS/EventDef.hs view
@@ -0,0 +1,11 @@+module Mischief.ECS.EventDef where++import Data.Data++-- | @Event@ typeclass.+class (Typeable e) => Event e where+  eraseEvent :: e -> ErasedEvent+  eraseEvent = ErasedEvent++data ErasedEvent where+  ErasedEvent :: (Typeable e) => e -> ErasedEvent
+ src/Mischief/ECS/Events.hs view
@@ -0,0 +1,58 @@+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])++flushEvents :: System ()+flushEvents = do+  world <- unsafeGetWorld+  events <- liftIO $ readIORef world.events+  for_ events runEvent+  liftIO $ writeIORef world.events []++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++newtype OnInsert c = OnInsert {entity :: Entity}+  deriving anyclass (Event)+  deriving stock (Show)++data OnInsertRel c = OnInsertRel {entity :: Entity, target :: Entity}+  deriving anyclass (Event)+  deriving stock (Show)++newtype OnRemove c = OnRemove {entity :: Entity}+  deriving anyclass (Event)+  deriving stock (Show)++data OnRemoveRel c = OnRemoveRel {entity :: Entity, target :: Entity}+  deriving anyclass (Event)+  deriving stock (Show)
+ src/Mischief/ECS/Graph.hs view
@@ -0,0 +1,92 @@+{- 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'
+ src/Mischief/ECS/Hidden.hs view
@@ -0,0 +1,15 @@+-- |+-- Internal module containing utilities for hiding data+-- behind constructors that can't be accessed externally.+--+-- Used for things such as hiding the 'Mischief.ECS.World.World' in a 'Mischief.ECS.World.ParSystem' so+-- it can't be mutated unsafely.+module Mischief.ECS.Hidden where++newtype Hidden a = Hidden a++hide :: a -> Hidden a+hide = Hidden++unhide :: Hidden a -> a+unhide (Hidden a) = a
+ src/Mischief/ECS/Hooks.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- {-# OPTIONS_GHC -Wno-redundant-constraints #-}++module Mischief.ECS.Hooks+  ( relComplementary,+    relCleanup,+    relCleanupRemove,+    relCleanupDespawn,+  )+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++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}
+ src/Mischief/ECS/Interval.hs view
@@ -0,0 +1,30 @@+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
+ src/Mischief/ECS/Log.hs view
@@ -0,0 +1,36 @@+module Mischief.ECS.Log where++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+  liftIO $ Colog.usingLoggerT world.logger $ Colog.logDebug msg++info :: (HasCallStack) => (MonadSystem w m) => Text -> m ()+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+  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
+ src/Mischief/ECS/Mappable.hs view
@@ -0,0 +1,106 @@+{-# 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)
+ src/Mischief/ECS/Messages.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++module Mischief.ECS.Messages+  ( Message,+    add,+    write,+    read,+  )+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.Markers+import Mischief.ECS.World.Query.Queryable+import Prelude hiding (read)++-- | Message typeclass.+class (Typeable m) => Message m++-- | Resource for writing and reading messages.+--+-- Internally, this keeps track of which messages each system has already read.+data Messages m = Messages {messages :: [(Frame, Tick, m)], readers :: Map SystemId Reader}++newMessages :: forall m. Messages m+newMessages = Messages {messages = [], readers = Map.empty}++newtype Reader = Reader (IORef Tick)++getReader :: (Message m) => Messages m -> System Reader+getReader !m = do+  world <- unsafeGetWorld+  case Map.lookup world.systemId m.readers of+    Just r -> return r+    Nothing -> do+      tick <- liftIO $ newIORef $ Tick (0, 0)+      insertRes $ (\Messages {messages, readers} -> Messages {messages, readers = Map.insert world.systemId (Reader tick) readers}) m+      return $ Reader tick++instance (Message m) => Component (Messages m)++-- | Write a message.+write :: forall m. (Message m) => m -> System ()+write !message = do+  messages <- resOrInsert $ newMessages @m+  world <- unsafeGetWorld+  frame <- liftIO $ readIORef world.frame++  loc <- self+  Just currentSystemTick <- get (C @SystemTick) loc++  let message' = (frame, currentSystemTick.inner, message)+  modify messages (\Messages {messages, readers} -> Messages {messages = message' : messages, readers})+  clearOldMessages messages++-- | Read all the messages that haven't been read by the current system.+read :: forall m. (Message m) => System [m]+read = do+  m <- res @(Messages m)+  case m of+    Nothing -> pure []+    Just m -> do+      Reader tick <- getReader m+      readerTick <- liftIO $ readIORef tick++      loc <- self+      Just currentSystemTick <- get (C @SystemTick) loc++      let newMessages = map (\(_, _, x) -> x) $ filter (\(_, tick, _) -> tick < currentSystemTick.inner && tick > readerTick) m.messages+      liftIO $ writeIORef tick currentSystemTick.inner++      return newMessages++-- | Register a new message type with the App. This will automatically create a corresponding resource.+add :: forall (m :: Type). (Message m) => System ()+add = insertRes $ newMessages @m++clearOldMessages :: (Message m) => Result (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})
+ src/Mischief/ECS/Observer.hs view
@@ -0,0 +1,20 @@+module Mischief.ECS.Observer where++import Data.Data+import Data.Default+import GHC.Generics+import Mischief.ECS.Components+import Mischief.ECS.Components.Required+import Mischief.ECS.World++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)++data EventProxy e = EventProxy deriving (Component, Generic, Default)
+ src/Mischief/ECS/Observers.hs view
@@ -0,0 +1,10 @@+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
+ src/Mischief/ECS/Prelude.hs view
@@ -0,0 +1,57 @@+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)
+ src/Mischief/ECS/Relationships.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++module Mischief.ECS.Relationships where++import Mischief.ECS.Components++data IsExclusiveRelationship = IsExclusiveRelationship deriving (Show, Component)
+ src/Mischief/ECS/Relationships/ChildOf.hs view
@@ -0,0 +1,23 @@+module Mischief.ECS.Relationships.ChildOf where++import Mischief.ECS.Components+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++-- 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++-- children :: forall m w. (MonadSystem w m) => Entity -> m [Entity]+-- children = outgoing @ChildOf
+ src/Mischief/ECS/Relationships/Graph.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++module Mischief.ECS.Relationships.Graph where++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++-- 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++-- ingoing :: forall c m w. (Component c, BundleTypes c, MonadSystem w m) => Entity -> m [Entity]+-- ingoing entity = query' E (With (R @c entity))
+ src/Mischief/ECS/Relationships/Order.hs view
@@ -0,0 +1,46 @@+module Mischief.ECS.Relationships.Order where++import Data.Foldable+import Data.Maybe+import Data.Set (Set)+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)+  for_ entities $ remove (C @Visited)+  -- err $ text res+  return res++orderEntitiesStep :: Set Entity -> System [Entity]+orderEntitiesStep entities =+  if null entities+    then+      return []+    else do+      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
+ src/Mischief/ECS/Relationships/Tree.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++module Mischief.ECS.Relationships.Tree where++import Mischief.ECS.Components+import Mischief.ECS.Components.BundleTypes+import Mischief.ECS.Entities+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'++-- 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)++-- 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++-- 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'
+ src/Mischief/ECS/Resources.hs view
@@ -0,0 +1,28 @@+module Mischief.ECS.Resources where++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.+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)+res = do+  meta <- meta @c+  get (Val (C @c)) meta++resOrInsert :: forall r. (Component r, Updateable (Result r), Bundle r) => r -> System (Result r)+resOrInsert r = do+  meta <- meta @r+  getOrInsert r meta
+ src/Mischief/ECS/Schedules.hs view
@@ -0,0 +1,12 @@+module Mischief.ECS.Schedules where++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++run :: (Schedule sc) => sc -> System ()+run = runSchedule
+ src/Mischief/ECS/Stdin.hs view
@@ -0,0 +1,29 @@+module Mischief.ECS.Stdin where++import Control.Monad.IO.Class+import GHC.IO.Handle+import Mischief.ECS.World+import System.IO+import Prelude hiding (read)++init :: System ()+init = liftIO $ do+  hSetBuffering stdin NoBuffering+  hSetEcho stdin False++read :: System String+read = do+  ready <- liftIO $ hReady stdin+  if ready+    then do+      c <- liftIO getChar+      ([c] ++) <$> read+    else do+      return []++readLast :: System (Maybe Char)+readLast = do+  r <- read+  return $ case r of+    [] -> Nothing+    x -> Just $ last x
+ src/Mischief/ECS/Stdout.hs view
@@ -0,0 +1,11 @@+module Mischief.ECS.Stdout where++import Control.Monad.IO.Class+import Mischief.ECS.World+import System.Console.ANSI++printClear :: String -> System ()+printClear !s = liftIO $ do+  liftIO clearScreen+  liftIO $ setCursorPosition 0 0+  liftIO $ putStr s
+ src/Mischief/ECS/Systems.hs view
@@ -0,0 +1,73 @@+-- |+-- 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.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++  for_ systems $ \system -> systemEntity schedule system++  for_ edges $ \(s1, s2) -> do+    id1 <- systemEntity schedule s1+    id2 <- systemEntity schedule 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++  despawn s++  query' E (With (R @Before s))+    >>= traverse_ (removeRel @Before s)++spawn :: System () -> System Entity+spawn = Spawn.spawn . SystemFunction++get :: (Schedule sc) => sc -> System () -> System Entity+get = systemEntity++schedule :: (Schedule sc) => sc -> System () -> System ()+schedule sch s = do+  s' <- Mischief.ECS.Systems.get sch s+  sch' <- scheduleEntity sch++  insert (Rel ScheduledIn sch') 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'
+ src/Mischief/ECS/Tables.hs view
@@ -0,0 +1,447 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++module Mischief.ECS.Tables where++import Control.Monad (forM, when)+import Data.Foldable (Foldable (toList), find, 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.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 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++newtype Tables = Tables {inner :: IOVec Table}++data Table = Table+  { columns :: IORef (Map ComponentId Column),+    components :: [ComponentId],+    entities :: IOVec (Entity, IORef EntityPointer)+  }++newtype Column = Column (IOVec ComponentData)++baseline_entities_cap :: Int+baseline_entities_cap = 64++emptyTables :: IO Tables+emptyTables = do+  v <- Vec.new 128+  Vec.pushBack v =<< newTable []+  pure $ Tables v++newTable :: [ComponentId] -> IO Table+newTable components = do+  cols <-+    for components $ \x -> do+      empty_vec <- Vec.new baseline_entities_cap+      pure (x, Column empty_vec)++  columns <- newIORef $ Map.fromList (toList cols)+  entities <- Vec.new baseline_entities_cap++  return $ Table {columns = columns, components, entities}++tableIsEmpty :: Table -> IO Bool+tableIsEmpty table = Vec.null table.entities++-- removeTable :: ArchetypeId -> Tables -> IO ()+-- removeTable archetype tables = do+--   let Tables tables' = tables+--   modifyIORef' tables' $ Map.filterWithKey (\archetype' _ -> archetype' /= archetype)++-- |+--  runs the specified monadic action with the value of the given map key as input, if the key exists.+--  if it doesn't, do nothing+tapMap ::+  (Monad m, Ord k) =>+  Map k a ->+  k ->+  (a -> m ()) ->+  m ()+tapMap map k act = do+  maybe (pure ()) act $ Map.lookup k map++insertComponentsIntoMap :: ProcessedBundleData -> Map ComponentId Column -> IO ()+insertComponentsIntoMap bundle map =+  for_ bundle.elements $ \el ->+    tapMap map el.id $ \(Column col) ->+      Vec.pushBack col el.component++insertComponentsIntoTable :: ProcessedBundleData -> Table -> IO ()+insertComponentsIntoTable bundle table = do+  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+  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})++--   foldl' modifyMap tableMap bundle.elements+--  where+--   modifyMap tableMap element = Map.adjust (modifyComponents element) element.id tableMap+--   modifyComponents element (Column x) =+--     let (x', _ : ys) = splitAt pointer.rowIndex x+--      in Column $ x' ++ [element.component] ++ ys++replaceComponentsIntoTable ::+  ProcessedBundleData ->+  -- | The current tick that will be as the components' change tick.+  Maybe Tick ->+  EntityPointer ->+  Table ->+  IO ()+replaceComponentsIntoTable bundle tick pointer table = do+  cols <- readIORef table.columns+  replaceComponentsIntoMap bundle tick pointer cols++takeFromColumn :: EntityPointer -> Column -> IO ComponentData+takeFromColumn (EntityPointer (# _, rowIndex #)) (Column col) = Vec.takeSwap col (I# rowIndex)++takeComponentsFromTable :: EntityPointer -> Table -> IO ProcessedBundleData+takeComponentsFromTable (EntityPointer (# archetypeId, rowIndex #)) table = do+  cols <- readIORef table.columns+  newColumns <- for cols $ takeFromColumn (EntityPointer (# archetypeId, rowIndex #))+  removeEntityFromTable (I# rowIndex) table+  let elements = map (uncurry ProcessedBundleElement) $ Map.toList newColumns+  pure ProcessedBundleData {elements}++collectComponentIdsFromTable :: Table -> IO [ComponentId]+collectComponentIdsFromTable table = do+  cols <- readIORef table.columns+  return $ map fst $ Map.toList cols++-- let elements = map getComponent newColumns+-- return ProcessedBundleData{elements}++removeComponentFromColumn :: EntityPointer -> Column -> IO ()+removeComponentFromColumn (EntityPointer (# _, rowIndex #)) (Column col) = Vec.removeSwap col (I# rowIndex)++removeComponentsFromMap :: EntityPointer -> Map ComponentId Column -> IO ()+removeComponentsFromMap pointer columnMap =+  for_ columnMap $ removeComponentFromColumn pointer++-- map (\(id, column) -> (id, removeComponentFromColumn pointer column)) (Map.toList columnMap)++removeComponentsFromTable :: EntityPointer -> Table -> IO ()+removeComponentsFromTable (EntityPointer (# archetypeId, rowIndex #)) table = do+  cols <- readIORef table.columns+  removeComponentsFromMap (EntityPointer (# archetypeId, rowIndex #)) cols+  removeEntityFromTable (I# rowIndex) table++removeRow :: Int -> IOVec (Entity, IORef EntityPointer) -> IO ()+removeRow row_idx vec = do+  len <- Vec.length vec+  Vec.removeSwap vec row_idx+  when (row_idx < len - 1) $ do+    Vec.tap vec row_idx $ \(_, ptr) ->+      modifyIORef' ptr $ \(EntityPointer (# archetypeId, _ #)) ->+        let !(I# id) = row_idx+         in EntityPointer (# archetypeId, id #)++removeEntityFromTable :: Int -> Table -> IO ()+removeEntityFromTable row table = removeRow row table.entities++-- insertResourceIntoTables :: ProcessedBundleData -> Tick -> Tables -> ArchetypeId -> (Entity, IORef EntityPointer) -> IO ()+-- insertResourceIntoTables bundle tick (Tables tables) archetype (entity, pointerRef) =+--   do+--     innerTables <- readIORef tables++--     table <- newTable bundle+--     let newTables = Map.insert archetype table innerTables+--     writeIORef tables newTables++--     rowIndex <- Vec.length table.entities+--     Vec.pushBack table.entities (entity, pointerRef)++--     let !(I# archetype') = archetype.id+--     let !(I# rowIndex') = rowIndex+--     writeIORef pointerRef $ EntityPointer (# archetype', rowIndex' #)++--     insertComponentsIntoTable bundle table++insertEntityIntoTables :: ProcessedBundleData -> Tables -> ArchetypeId -> (Entity, IORef EntityPointer) -> IO ()+insertEntityIntoTables bundle (Tables tables) archetype pointerRef =+  do+    table <- Vec.unsafeRead tables archetype.id++    rowIndex <- Vec.length table.entities+    Vec.pushBack table.entities pointerRef++    let !(I# archetype') = archetype.id+    let !(I# rowIndex') = rowIndex+    writeIORef (snd pointerRef) $ EntityPointer (# archetype', rowIndex' #)++    insertComponentsIntoTable bundle 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++tryGetRelCollectionFromTable :: forall c. (Component c) => Table -> Entity -> EntityPointer -> ComponentId -> IO (Maybe [Result (Rel c)])+tryGetRelCollectionFromTable table entity pointer (ComponentId (# id, target #)) =+  do+    columns <- readIORef table.columns+    -- TODO: improve lookup performance for partial tuples++    components' <- forM (Map.toList columns) $ \(ComponentId (# id', target' #), column) -> do+      if isTrue# $ eqWord# id id'+        then do+          case target' of+            Nothing -> return Nothing+            Just entity -> do+              component <- tryGetComponentFromColumn @c column pointer+              return $ fmap (,entity) component+        else return Nothing++    if null $ catMaybes components'+      then+        return Nothing+      else do+        return $ Just $ map (\(value, target) -> Result (Rel value target, entity)) $ catMaybes components'++tryGetComponentFromTable :: forall c. (Component c) => Table -> EntityPointer -> ComponentId -> IO (Maybe c)+tryGetComponentFromTable table pointer componentId =+  do+    columns <- readIORef table.columns+    let column = Map.lookup componentId columns+    case column of+      Nothing -> return Nothing+      Just column -> tryGetComponentFromColumn column pointer++tryGetRelCollectionFromTables :: forall c. (Component c) => Tables -> Entity -> EntityPointer -> ComponentId -> IO (Maybe ([Result (Rel c)]))+tryGetRelCollectionFromTables (Tables tables) entity (EntityPointer (# archetypeId, rowIndex #)) componentId =+  do+    table <- Vec.unsafeRead tables (I# archetypeId)+    tryGetRelCollectionFromTable table entity (EntityPointer (# archetypeId, rowIndex #)) componentId++tryGetComponentFromTables :: forall c. (Component c) => Tables -> EntityPointer -> ComponentId -> IO (Maybe c)+tryGetComponentFromTables (Tables tables) (EntityPointer (# archetypeId, rowIndex #)) componentId =+  do+    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)++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++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 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++tryGetTicksFromTables :: Tables -> [ArchetypeId] -> ComponentId -> IO [Maybe ComponentTicks]+tryGetTicksFromTables (Tables tables) archetypes componentId =+  do+    results <- mapM (\archetype -> tryGetTicksFromArchetype archetype tables componentId) archetypes+    return $ concat results++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+  pure $ maybe [] Vector.toList x++tryGetRelCollectionsFromTable :: forall c. (Component c) => Table -> ComponentId -> IO [(Entity, [Result (Rel c)])]+tryGetRelCollectionsFromTable table (ComponentId (# id, target #)) =+  do+    -- let Just entity = componentId.entity+    columns <- readIORef table.columns+    -- TODO: improve lookup performance for partial tuples++    components' :: [Maybe [(c, Entity)]] <- forM (Map.toList columns) $ \(ComponentId (# id', target' #), column) -> do+      if isTrue# $ eqWord# id id'+        then do+          case target' of+            Nothing -> return Nothing+            Just entity -> do+              components <- tryGetComponentsFromColumn @c column+              return $ Just $ map (,entity) components+        else return Nothing++    entities <- Vec.toList table.entities+    let components'' = zip (map fst entities) $ transpose $ catMaybes components'+    return $+      map+        (\(entity, components) -> (entity, map (\(value, target) -> Result (Rel value target, entity)) components))+        components''++tryGetComponentsFromTable :: forall c. (Component c) => Table -> ComponentId -> IO [(Entity, Result c)]+tryGetComponentsFromTable table componentId =+  do+    columns <- readIORef table.columns+    case Map.lookup componentId columns of+      Nothing -> undefined+      Just column -> do+        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++tryGetEntitiesFromTable :: Table -> IO [Entity]+tryGetEntitiesFromTable table =+  do+    entities <- Vec.toList table.entities+    return $ map fst entities++tryGetComponentsFromTableMaybe :: forall c. (Component c) => Table -> ComponentId -> IO [(Entity, Maybe (Result c))]+tryGetComponentsFromTableMaybe table componentId =+  do+    columns <- readIORef table.columns+    case Map.lookup componentId columns of+      Nothing -> do+        entities <- Vec.toList table.entities+        return $ map ((,Nothing) . fst) entities+      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)++tryGetRelCollectionsFromArchetype :: forall c. (Component c) => ArchetypeId -> IOVec Table -> ComponentId -> IO [(Entity, [Result (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 archetype tables componentId = do+  table <- Vec.unsafeRead tables archetype.id+  tryGetComponentsFromTable table componentId++tryGetEntitiesFromArchetype :: ArchetypeId -> IOVec Table -> IO [Entity]+tryGetEntitiesFromArchetype archetype tables = do+  table <- Vec.unsafeRead tables archetype.id+  tryGetEntitiesFromTable table++tryGetComponentsFromArchetypeMaybe :: forall c. (Component c) => ArchetypeId -> IOVec Table -> ComponentId -> IO [(Entity, Maybe (Result 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 (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 (Tables tables) archetypes componentId =+  do+    results <- mapM (\archetype -> tryGetComponentsFromArchetype archetype tables componentId) archetypes+    return $ concat results++tryGetEntitiesFromTables :: Tables -> [ArchetypeId] -> IO [Entity]+tryGetEntitiesFromTables (Tables tables) archetypes =+  do+    results <- mapM (`tryGetEntitiesFromArchetype` tables) archetypes+    return $ concat results++tryGetComponentsFromTablesMaybe :: forall c. (Component c) => Tables -> [ArchetypeId] -> ComponentId -> IO [(Entity, Maybe (Result c))]+tryGetComponentsFromTablesMaybe (Tables tables) archetypes componentId =+  do+    results <- mapM (\archetype -> tryGetComponentsFromArchetypeMaybe archetype tables componentId) archetypes+    return $ concat results++newtype Result c = Result (c, Entity)++data ErasedResult where+  ErasedResult :: Result c -> ErasedResult++value :: Result c -> c+value (Result (c, _)) = c++type family IsComp a where+  IsComp (Rel a) = False+  IsComp a = True++entityOf :: Result c -> Entity+entityOf (Result (_, e)) = e++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 (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)++class DeepValue' flag c i | flag c -> i where+  deepValue' :: c -> i++instance DeepValue' True (Result c) c where+  deepValue' = value++instance DeepValue' False (Result (Rel c)) c where+  deepValue' x = x.comp++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)
+ src/Mischief/ECS/Time.hs view
@@ -0,0 +1,47 @@+module Mischief.ECS.Time where++import Control.Monad.IO.Class+import GHC.Records (HasField (getField))+import Mischief.ECS.App+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.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 System.Clock++data Time = Time+  { delta :: TimeSpec,+    elapsed :: TimeSpec+  }+  deriving (Show, Component)++time :: System Time+time = unwrap <$> res @Time++deltaTime :: System Float+deltaTime = deltaSecs <$> time++deltaSecs :: Time -> Float+deltaSecs Time {delta} = fromIntegral delta.sec + fromIntegral delta.nsec / 1000000000++data TimePlugin = TimePlugin deriving (Eq)++instance Plugin TimePlugin where+  init _ = do+    currentTime <- liftIO $ getTime Monotonic+    insertRes $ Time {delta = TimeSpec {sec = 0, nsec = 0}, elapsed = currentTime}+    Systems.add First updateTime++updateTime :: System ()+updateTime = do+  Just time <- res @Time+  currentTime <- liftIO $ getTime Monotonic+  insertRes Time {delta = currentTime - time.elapsed, elapsed = currentTime}
+ src/Mischief/ECS/Timer.hs view
@@ -0,0 +1,14 @@+module Mischief.ECS.Timer where++data Timer = Timer {duration :: Float, elapsed :: Float, mode :: Mode}++data Mode = Once | Repeat++new :: Float -> Mode -> Timer+new duration mode = Timer {duration, mode, elapsed = 0}++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)+tick _ Timer {duration, elapsed = _, mode = Once} = (Timer {duration, elapsed = duration, mode = Once}, True)+tick x Timer {duration, elapsed, mode = Repeat} = (Timer {duration, elapsed = elapsed + x - duration, mode = Repeat}, True)
+ src/Mischief/ECS/Tutorial/App.hs view
@@ -0,0 +1,179 @@+{-# 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.
+ src/Mischief/ECS/Tutorial/Components.hs view
@@ -0,0 +1,573 @@+{-# 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)+-- ...+-- @
+ src/Mischief/ECS/Tutorial/Dungeon.hs view
@@ -0,0 +1,1229 @@+{-# 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).
+ src/Mischief/ECS/Tutorial/Events.hs view
@@ -0,0 +1,99 @@+{-# OPTIONS_GHC -Wno-unused-imports #-}++-- |+-- Module: Events and Messages Tutorial+-- Description: Tutorial on using @Events and Messages@+--+-- This module contains a more in-depth tutorial on using @Events and Messages@.+--+-- [Previous Chapter: Systems]("Mischief.ECS.Tutorial.Systems")+--+-- [Main Page]("Mischief.ECS")+module Mischief.ECS.Tutorial.Events+  ( -- * Learn You an ECS for Great Mischief! - 8. Events and Messages+    -- $intro++    -- * Events+    -- $events++    -- * Messages+    -- $msg+  )+where++import Mischief.ECS++-- $intro+-- This chapter presents two ways of communicating between systems. @Events@ and @Messages@!.++-- $events+-- You should already be pretty familiar with @Events@ if you've read the rest of this tutorial. But let's get into them again just in case.+--+-- An event is any type deriving the @Event@ typeclass.+--+-- @+-- data Foo = Foo 'Int' deriving ('Event')+-- @+--+-- Events can be triggered using @trigger@:+--+-- @+-- 'trigger' (Foo 5)+-- @+--+-- Events can be listened to by spawning an observer. Observers will be called immediately when an event is triggered.+--+-- @+-- listenToFoo :: Foo -> 'System' ()+-- listenToFoo foo = ...+-- @+--+-- @+-- _ <- [Observers]("Mischief.ECS.Observers").'Mischief.ECS.Observers.spawn' listenToFoo+-- @+--+-- There are also pre-defined systems called by Mischief:+--+-- * @'OnInsert' c@ - called after @c@ has been inserted on an entity.+-- * @'OnRemove' c@ - called before @c@ is removed from an entity.+-- * @'OnInsertRel' c@ / @'OnRemoveRel' c@ - same as the above but for relationships.+--+-- Events are really handy, but they can be become inefficient if called many times in a frame, since there will be an individual system ran per triggered event.+-- That's where messages come in!++-- $msg+-- @Messages@ are just convenient wrappers around resources that are used for inter-system communication.+--+-- A message is a type that derives the @Message@ typeclass:+--+-- @+-- data Foo = Foo 'Int' deriving ('Message')+-- @+--+-- Tools for working with messages are found provided by the @Messages@ module:+--+-- @+-- import "Mischief.ECS.Messages" qualified as [Messages]("Mischief.ECS.Messages")+-- @+--+-- There are two main functions used to deal with messages, @write@ and @read@.+--+-- You can use @write@ to write a new message into the buffer:+--+-- @+-- [Messages]("Mischief.ECS.Messages").'Mischief.ECS.Messages.write' (Foo 5)+-- @+--+-- And you can use @read@ to drain the buffer of a certain type of message:+--+-- @+-- messages <- [Messages]("Mischief.ECS.Messages").'Mischief.ECS.Messages.read' \@Foo+-- @+--+-- @+-- messages :: [Foo]+-- @+--+-- @read@ will get all messages that haven't yet been read by the current system, erasing them from the buffer.+--+-- Messages are better than events for higher throughput, since they function in batches so a system can process multiple messages at a time.
+ src/Mischief/ECS/Tutorial/Queries.hs view
@@ -0,0 +1,322 @@+{-# OPTIONS_GHC -Wno-unused-imports #-}++-- |+-- Module: Queries Tutorial+-- Description: Tutorial on using @Queries@+--+-- This module contains a more in-depth tutorial on @Mischief Queries@.+--+-- [Previous Chapter: Relationships]("Mischief.ECS.Tutorial.Relationships")+--+-- [Next Chapter: Systems]("Mischief.ECS.Tutorial.Systems")+--+-- [Main Page]("Mischief.ECS")+module Mischief.ECS.Tutorial.Queries+  ( -- * Learn You an ECS for Great Mischief! - 6. Queries+    -- $intro++    -- * Outputs+    -- $outputs++    -- * Val+    -- $val++    -- * Filters+    -- $filters++    -- * The Check Filter+    -- $check++    -- * Quasi-Queries+    -- $quasi++    -- * [Next Chapter: Systems]("Mischief.ECS.Tutorial.Systems")+  )+where++import Mischief.ECS++-- $intro+-- Queries are the main way we read component data. They are fully type-checked and based on archetypes, making them quite fast.+--+-- Each query associates an output type to the types you put into it.+--+-- For instance,+--+-- @+-- x <- 'query' ('C' \@A, 'M' \@B)+-- @+--+-- Will have an output type of:+--+-- @+-- ('Result' A, 'Maybe' ('Result' B))+-- @+--+-- With an actual return type of:+--+-- @+-- x :: ['Result' A, 'Maybe' ('Result' B)]+-- @+--+-- Because @query@ actually returns @[Output]@.+--+-- @single@ on the other hand, returns a @Maybe Output@, only outputting something if there is exactly one entity which matches the query.+--+-- @+-- x <- 'single' ('C' \@A, 'M' \@B)+-- @+--+-- @+-- x :: 'Maybe' ('Result' A, 'Maybe' ('Result' B))+-- @+--+-- @get@ queries the components of a specific entity:+--+-- @+-- x <- 'get' ('C' \@A) e+-- @+--+-- @+-- x :: 'Maybe' ('Result' A)+-- @+--+-- @get@ returns @'Nothing'@ if the entity doesn't exist or if it doesn't contain any of the components.++-- $val+-- Working with @Result c@ can be annoying, especially if you only want to read the value of a component and not mutate anything.+--+-- That's why all query types can be wrapped in a @Val@ in order to extract their values out of the @Result@:+--+-- @+-- 'query' ('C' \@Foo, 'Val' ('C' \@Bar, 'M' \@Baz))+-- @+--+-- Will return:+--+-- @+-- ['Result' Foo, (Bar, 'Maybe' Baz)]+-- @+--+-- @Val@ maps anything that looks like a @Result c@ to just @c@, while leaving most other things be as they are.++-- $outputs+-- Here's a list of the the various markers you can use in queries and each of their output types:+--+-- Entity:+--+-- * @'E'@ -> @'Entity'@+--+-- Components:+--+-- * @'C' c@ -> @'Result' c@+-- * @'M' c@ -> @'Maybe' ('Result' c)@+-- * @'Has' c@ -> @'Bool'@+--+-- Relationships:+--+-- * @'R' c e@ -> @'Result' ('Rel' c)@+-- * @'R' c 'Any'@ -> @['Result' ('Rel' c)]@+-- * @'MR' c e@ -> @'Maybe' ('Result' ('Rel' c))@+-- * @'MR' c 'Any'@ -> @'Maybe' ['Result' ('Rel' c)@+-- * @'HasR' c e@ -> @'Bool'@+-- * @'HasR' c 'Any'@ -> @'Bool'@+--+-- Transitive:+--+-- * @'R' c ('Q' q)@ -> @[Result of q]@+-- * @'MR' c ('Q' q)@ -> @'Maybe' [Result of q]@+-- * @'HasR' c ('Q' q)@ -> @'Bool'@+--+-- Note that the relational queries using @Any@ and the transitive ones will return a single element+-- instead of a list, in the case of that relation being exclusive.++-- $filters+-- Filters can be passed to @'@ variants of query functions, such as @'query''@ and @'single''@.+--+-- There is an implicit @and@ between filters. @(A, B)@ means @A and B@. If you wish to express @A or B@, you can write it as @A |. B@. @Not@ can be used to+-- negate filters.+--+-- @(A |. Not (B, C))@ means @A or (not (B and C))@.+--+-- Most filters expect a tuple of @'C'@ and @'R'@ types. These are all valid filters:+--+-- * @'With' ('C' \@Foo)@+-- * @'With' ('R' \@Foo e, 'C' \@Bar)@+-- * @'With' ('R' \@Foo 'Any', 'C' \@Bar, 'C' \@Baz)@+--+-- These filters are:+--+-- * @'With'@+-- * @'Without'@+-- * @'Changed'@+-- * @'Added'@++-- $check+-- @Check@ is a special filter which takes a @f :: c -> Bool@ function and only accepts entities for which @f@ applied over the @c@ component is True.+-- Naturally, all entities that don't contain the @c@ component will fail.+--+-- For instance, here's how we can select all entities named \"Bob\":+--+-- @+-- 'query'' 'E' ('Check' (== 'Name' "\Bob\"))+-- @+--+-- For relationships, you must use the dedicated @'CheckR'@ variant which also expects an entity or @Any@.+--+-- Selecting all entities which Like alice more than 5:+--+-- @+-- 'query'' 'E' ('CheckR' alice (> Likes 5))+-- @+--+-- Selecting all entities which like any other entity more than 10:+--+-- @+-- 'query'' 'E' ('CheckR' 'Any' (> Like 10))+-- @++-- $quasi+-- @Quasi-Queries@ are queries written via a special quasi-quoter. Make sure to have the @QuasiQuotes@ and @TemplateHaskell@ langauge extensions enabled in order to use them.+--+-- === Components+--+-- Here's how we can rewrite a simple componnet query in quasi form:+--+-- @+-- 'query' ('C' \@Foo, 'C' \@Bar)+-- @+--+-- @+-- ['q'|Foo, Bar|]+-- @+--+-- As you can see, a @'C' \@c@ becomes @c@.+--+-- === Relationships+--+-- What about relationships?+--+-- @+-- 'query' ('R' \@Foo e, 'R' \@Bar 'Any')+-- @+--+-- @+-- ['q'|Foo -> e, Bar -> *|]+-- @+--+-- @'R' \@c a@ is translated to @c -> a@, and @Any@ becomes @*@.+--+-- == Transitive+--+-- Transitive queries are written the same as relationship ones, but with @()@ around their target:+--+-- @+-- 'query' ('R' \@Foo ('Q' ('C' \@Bar)))+-- @+--+-- @+-- ['q'|Foo -> (Bar)]+-- @+--+-- === Modifiers+--+-- Quasi-Queries also accept @Maybe@ and @Has@ modifiers:+--+-- @+-- 'query' ('M' \@Foo, 'HasR' \@Bar 'Any')+-- @+--+-- @+-- ['q'|Maybe Foo, Has Bar -> *|]+-- @+--+-- Since Quasi-Queries are parsed internally by Mischief, alternative symbols are allowed:+--+-- * @Maybe@ | @maybe@ | @M@ | @m@+-- * @Has@ | @has@ | @H@ | @h@+--+-- So the above query can also be written as:+--+-- @+-- ['q'|M Foo, H Bar -> *|]+-- @+--+-- You don't need to worry about the distinction between @M@ and @MR@ and so on, the parer will infer which to use.+--+-- === Val+--+-- @Val@ is accepted in quasi notation too:+--+-- @+-- 'query' ('Val' ('C' \@Foo, 'C' \@Bar))+-- @+--+-- @+-- ['q'|Val (Foo, Bar)|]+-- @+--+-- @Val@ can be written as: @Val@, @val@,  @V@,  @v@, @*@.+--+-- So an equivalent way to write the above would be:+--+-- @+-- ['q'|*(Foo, Bar)|]+-- @+--+-- === Entity+--+-- @'E'@ can be written as: @Entity@, @entity@, @E@, @e@.+--+-- === Filters+--+-- In order to add a filter to a quasi-query, we must separate it with a @\/@ from the rest of the query:+--+-- @+-- 'query'' ('C' \@Name) ('With' ('C' @\Foo, R @\Bar 'Any'), 'Without'('C' @\Baz))+-- @+--+-- @+-- ['q'|Name \/ With (Foo, Bar -> *), Without Baz|]+-- @+--+-- @Added@ and @Changed@ also exists for quasi-queries. All filters can be written either starting with a lower or uppercase letter. For instance, both @with@ and @With@ are correct.+-- @Not@ can also be written as @!@ and @|.@ can be written as @|.@, @||@, @or@, @Or@.+--+-- === Check+--+-- In quasi notation, @Check@ is unified for both components and relationships. Simply put @-> a@ after it if it's a relationship!+--+-- Getting all entities named \"Bob\" which like alice more than 5:+--+-- @+-- ['q'|Entity / Check (== Name \"Bob\"), Check (> Likes 5) -> alice|]+-- @+--+-- The argument for @Check@ can be any arbitrary lambda function or a function defined outside the quasi-quote.+--+-- === Generics+--+-- In order to use a quasi-query for a type with generic parameters, such as:+--+-- @+-- data A a b = A deriving ('Component')+-- @+--+-- The entire type must be put in @()@. For instance:+--+-- @+-- ['q'|Maybe (A Int Float), Likes -> *|]+-- @+--+-- === Other Quasies+--+-- There is also the @g@ Quasi-Query for @get@, and @s@ for @single@:+--+-- @+-- ['g'|Name|] alice+-- @+--+-- @+-- ['s'|Name / with Player|]+-- @
+ src/Mischief/ECS/Tutorial/Relationships.hs view
@@ -0,0 +1,402 @@+{-# OPTIONS_GHC -Wno-unused-imports #-}++-- |+-- Module: Relationships Tutorial+-- Description: Tutorial on using @Relationships@+--+-- This module contains a more in-depth tutorial on @Mischief Relationships@.+--+-- [Previous Chapter: Components]("Mischief.ECS.Tutorial.Components")+--+-- [Next Chapter: Queries]("Mischief.ECS.Tutorial.Queries")+--+-- [Main Page]("Mischief.ECS")+module Mischief.ECS.Tutorial.Relationships+  ( -- * Learn You an ECS for Great Mischief! - 5. Relationships+    -- $intro++    -- * Insertion+    -- $insertion++    -- * Removal+    -- $removal++    -- * Querying+    -- $query++    -- * Transitive Querying+    -- $trans++    -- * Hooks+    -- $hooks++    -- * Examples+    -- $examples++    -- * [Next Chapter: Queries]("Mischief.ECS.Tutorial.Queries")+  )+where++import Mischief.ECS++-- $intro+-- Mischief implement @Relationships@ in a similar way to @Flecs@.+--+-- When a component is added to an entity, it is actually indexed by a @ComponentId@:+--+-- @+-- data 'ComponentId' = ComponentId {id :: 'Entity', entity :: 'Maybe' 'Entity'}+-- @+--+-- The first field, @id@, is the entity corresponding to the component, while the second field, @entity@, is an optional reference to another entity.+--+-- This means that each @ComponentId@ can either be a simple component, or a pair between a component and an entity (technically even between+-- two components or two entities but that's not directly allowed by the API).+--+-- So a relationship in Mischief is a pair between a component and an entity. It can be inserted on entities using @Rel@:+--+-- @+-- data 'Rel' c = Rel {comp :: c, target :: 'Entity'}+-- @+--+-- For instance, this is how we spawn an entity @b@ that's a child of @a@:+--+-- @+-- a <- 'spawn' ()+-- b <- 'spawn' ('Rel' 'ChildOf' a)+-- @++-- $insertion+-- Let's consider the following component, which will symbolize that an entity likes another, and by how much:+--+-- @+-- data Likes = Likes 'Int' deriving ('Component')+-- @+--+-- And three spawned entities: @alice@, @bob@, @charlie@.+--+-- As mentioned before, we can insert a relationship using the 'Rel' type.+--+-- @+-- 'insert' ('Rel' (Likes 3) alice, 'Rel' (Likes 5) charlie) bob+-- 'insert' ('Rel' (Likes 2) bob) alice+-- @+--+-- If we insert a second relationship with the same component and the same target, its value will overwrite the other. For instance, the following code+-- will make @alice@ like @bob@ by 3 instead of 2:+--+-- @+-- 'insert' ('Rel' (Likes 3) bob) alice+-- @++-- $removal+-- Removing relationships can be done through the @remove@ function, same as normal components. But instead of using the @'C'@ marker, we will use the @'R'@ marker.+--+-- Making @bob@ stop liking @alice@.+--+-- @+-- 'remove' ('R' \@Likes alice) bob+-- @+--+-- The @'R'@ marker takes a type hint of the relationship's type (@\@Likes@), and a target Entity (@alice@). But it can also be given the @Any@ wildcard instead:+--+-- @+-- 'remove' ('R' \@Likes 'Any') bob+-- @+--+-- This will remove all @Likes@ relationships from @bob@, making him not like anyone.++-- $query+-- Relationships can be queried using the @R@ marker.+--+-- @+-- x <- 'query' ('R' \@Likes alice)+-- @+--+-- @+-- x :: ['Result' ('Rel' Likes)]+-- @+--+-- In quasi-queries, this becomes:+--+-- @+-- x \<- ['q'|Likes -\> alice|]+-- @+--+-- @Result (Rel c)@ is the return type of @R \@c e@. It can be used in most Result-based operation discussed in the previous chapter, such as @'set'@ and @'delete'@.+--+-- Querying can also be done using the @Any@ wildcard:+--+-- @+-- x <- 'query' ('R' \@Likes Any)+-- @+--+-- @+-- x :: [['Result' ('Rel' Likes)]]+-- @+--+-- In quasi-queries, @Any@ is symbolized by @*@:+--+-- @+-- x \<- ['q'|Likes -\> *|]+-- @+--+-- As you can see, the return type of @'R' \@c Any@ is @[Result (Rel c)]@. It's returning a list of relationships, rather than a single relationship (unless the+-- relationship is exclusive, but more on that in a bit).+--+-- Remember that the fields of the inner type of a Result are inherited by the Result itself. So we can just use @.comp@ and @.target@ to get the component and target of a @Result (Rel c)@.+--+-- @+-- 'Just' x <- 'get' ('R' \@Likes alice) bob+-- @+--+-- @+-- x.target :: Entity+-- x.comp   :: Likes+-- @+--+-- In the case of querying for @R c Any@, the query will only match entities that have at least one such relationship. The resulting @[Result (Rel c)]@ should never be empty.+--+-- If you wish to also include entities that do not have those relationships, you can use @`MR`@ (short for @Maybe Relationships@), the relational equivalent of @'M'@.+--+-- @+-- x <- 'query' ('MR' \@Likes alice)+-- @+--+-- @+-- x :: ['Maybe' ('Result' ('Rel' c))]+-- @+--+-- Which is this in quasi form:+--+-- @+-- x <- ['q'|Maybe Likes -> alice|]+-- @++-- $exclusive+-- A relationship can be made exclusive by setting the following associated type on its component instance:+--+-- @+-- instance 'Component' FooRel where+--   type 'RelExclusivity' FooRel = 'Exclusive'+-- @+--+-- This will make it so only one instance of a relationship can exist on an entity at once.+--+-- @+-- insert (Rel (FooRel, a)) c+-- insert (Rel (FooRel, b)) c+-- @+--+-- Will result in just @Rel (FooRel, b)@ being on @c@.+--+-- It also changes the result of @R \@FooRel Any@ queries to be of the form:+--+-- @+-- 'Result ('Rel' FooRel)+-- @+--+-- Instead of:+--+-- @+-- ['Result ('Rel' FooRel)]+-- @++-- $trans+-- Transitive queries are a powerful primitive which allow us to easily query components based on relational connections.+--+-- For instance, this is how we can get the name of each entity, along with the names of all entities they like:+--+-- @+-- x <- 'query' ('C' \@Name, 'R' \@Likes ('Q' ('C' \@Name)))+-- @+--+-- @+-- x :: [(Result Name, [Result Name])]+-- @+--+-- They /tend/ to look much better when written as quasi-queries (don't forget the @()@!):+--+-- @+-- x \<- ['q'|Name, Likes -\> (Name)]+-- @+--+-- Note that transitive queries can be nested as much as you want:+--+-- @+-- x \<- ['q'|Name, Likes -\> (Name, Likes -\> (Name))|]+-- @+--+-- @+-- x :: [(Result Name, [(Result Name, [Result Name])])]+-- @++-- $hooks+-- There are a number of predefined hooks that are useful when working with relationships, which can be found in "Mischief.ECS.Hooks".+--+-- For instance, @relComplementary@ can be used to automate adding a complementary relationship on the target of a relationship.+--+-- As a quick example of why this is useful, let's create a @Before@/@After@ relationship between entities:+--+-- @+-- data Before = Before+-- data After = After+--+-- instance 'Component' Before where+--   'hooks' = 'relComplementary' ('const' After)+--+-- instance 'Component' After where+--   'hooks' = 'relComplementary' ('const' Before)+-- @+--+-- Now, when we do:+--+-- @+-- 'insert' ('Rel' Before a) b+-- @+--+-- A @Rel After b@ will be inserted automatically on @a@.+--+-- And when we do:+--+-- @+-- 'remove' ('R' \@Before) b+-- @+--+-- @Rel After b@ will be removed from @a@.+--+-- And vice versa.+--+-- There are also @'relCleanupRemove'@ and @'relCleanupDespawn'@ for automatically removing a relationship (or ,respectively, despawning its entity) when its target has been despawned. And a+-- more generic @'relCleanup'@ which allows adding custom cleanup behavior.++-- The 'WithR' query filter lets us easily query for components of entities that have a certain relationship with a certain entity.+--+-- Getting a list of all entities that like bob.+--+-- @+-- x <- 'query'' 'E' ('WithR' @Likes bob)+-- @+--+-- Getting a list of all entities that like anyone.+--+-- @+-- x <- 'query'' 'E' ('WithR' @Likes Any)+-- @+--+-- We can also modify @Likes@ to have an @Int@ as well, representing how much an entity likes another:+--+-- @+-- data Likes = Likes 'Int' deriving ('Component')+-- @+--+-- @+-- 'insert' ('Rel' (Likes 5, alice), 'Rel' (Likes 8, charlie)) bob+-- @+--+-- The 'R' marker type can be used in a query to get a @['Result' ('Rel' c)]@ for each entity.+--+-- Getting the name and all the Likes relationships of all entities.+--+-- @+-- x <- query (C \@Name, 'R' \@Likes Any)+-- @+--+-- @+-- x :: [('Result' Name, ['Result' ('Rel' Likes)])]+-- @+--+--+-- Getting the name and the Like relationship with bob for all entities.+--+-- @+-- x <- query (C \@Name, 'R' \@Likes bob)+-- @+--+-- @+-- x :: [('Result' Name, 'Result' ('Rel' Likes))]+-- @+--+-- Note that @'R' \@Likes@ will limit the query to only the archetypes that contain any relation with @Likes@.+-- You can also use @'MR'@ (Maybe relationship) to also include the entities that don't contain such relationships.+--+-- A component can be made @exclusive@ by setting the following 'Bool' in the 'Component' instance:+--+-- @+-- instance 'Component' Likes where+--   'isExclusiveRel' = 'True'+-- @+--+-- If a component is exclusive, there can only be one relationship containing it on an entity at once.+--+-- For instance, if we do:+--+-- @+-- 'insert' ('Rel' (Likes, alice) bob+-- 'insert' ('Rel' (Likes, charlie)) bob+-- @+--+-- @(Likes, charlie)@ will overwrite @(Likes, alice)@.+--+-- This is useful for relationships such as 'ChildOf', since an entity can only have one parent at a time.++-- $examples+--+-- === __Example 1__+--+--+-- An example showing different operations on relationships, and the @relCleanupRemove@ hook.+--+-- @+-- import "Mischief.ECS.Prelude"+-- import "Mischief.ECS.Hooks" qualified as [Hooks]("Mischief.ECS.Hooks")+-- import "Mischief.ECS.Systems" qualified as [Systems]("Mischief.ECS.Systems")+--+-- data Likes = Likes 'Int' deriving ('Show')+--+-- instance 'Component' Likes where+--   'hooks' = [Hooks]("Mischief.ECS.Hooks").'Mischief.ECS.Hooks.relCleanupRemove'+--+-- main :: 'IO' ()+-- main = do+--   app <- 'newApp' MainPlugin+--   'runApp' app+--+-- data MainPlugin = MainPlugin deriving ('Eq')+--+-- instance 'Plugin' MainPlugin where+--   init _ = [Systems]("Mischief.ECS.Systems").'Mischief.ECS.Systems.add' 'Startup' test+--+-- test :: 'System' ()+-- test = do+--   alice <- 'spawn' ('Name' \"Alice\")+--   bob <- 'spawn' ('Name' \"Bob\")+--   charlie <- 'spawn' ('Name' \"Charlie\")+--+--   'insert' ('Rel' (Likes 5) alice, 'Rel' (Likes 10) bob) charlie+--   'insert' ('Rel' (Likes 7) alice) bob+--   'insert' ('Rel' (Likes 9) bob, 'Rel' (Likes 5) charlie) alice+--+--   ('info' . 'text') =<< 'query' ('C' \@Name, 'R' \@Likes alice)+--   ('info' . 'text') =<< 'query' ('C' \@Name, 'R' \@Likes bob)+--   ('info' . 'text') =<< 'query' ('C' \@Name, 'R' \@Likes charlie)+--+--   'remove' ('R' \@Likes 'Any') alice+--   'despawn' bob+--+--   ('info' . 'text') =<< 'query' ('C' \@Name, 'R' \@Likes alice)+--   ('info' . 'text') =<< 'query' ('C' \@Name, 'R' \@Likes bob)+--   ('info' . 'text') =<< 'query' ('C' \@Name, 'R' \@Likes charlie)+-- @+--+-- @+-- > [INFO] [(\"Bob\",Rel {comp = Likes 7, target = 28v1}),(\"Charlie\",Rel {comp = Likes 5, target = 28v1})]+-- > [INFO] [(\"Alice\",Rel {comp = Likes 9, target = 29v1}),(\"Charlie\",Rel {comp = Likes 10, target = 29v1})]+-- > [INFO] [(\"Alice\",Rel {comp = Likes 5, target = 30v1})]+--+-- > [INFO] [(\"Charlie\",Rel {comp = Likes 5, target = 28v1})]+-- > [INFO] []+-- > [INFO] []+-- @+--+-- You can see in the second set of prints that nobody likes Bob anymore, since he "died", and the cleanup hook made it so any "Likes -> Bob" relationships were automatically removed.
+ src/Mischief/ECS/Tutorial/Startup.hs view
@@ -0,0 +1,431 @@+{-# OPTIONS_GHC -Wno-unused-imports #-}++-- |+-- Module: Components Tutorial+-- Description: Introductory Tutorial+--+-- This module walks the user through setting up Mischief and creating a simple app.+--+-- [Next Chapter: Coding a Dungeon Game]("Mischief.ECS.Tutorial.Dungeon")+--+-- [Main Page]("Mischief.ECS")+module Mischief.ECS.Tutorial.Startup+  ( -- * Learn You an ECS for Great Mischief! - 1. Startup Guide++    -- * What do I need to know?+    -- $know++    -- * Setup+    -- $setup++    -- * The App+    -- $app++    -- * The ECS+    -- $ecs++    -- * Your First System+    -- $firstSystem++    -- * Your First Component+    -- $firstComp++    -- * Your First Query+    -- $firstQuery++    -- * Your First Mutation+    -- $firstMut++    -- * Your First Resource+    -- $res++    -- * Your First Relationship+    -- $rel++    -- * Your First Transitive Query+    -- $trans++    -- * What's Next?+    -- $next++    -- * [Next Chapter: Coding a Dungeon Game]("Mischief.ECS.Tutorial.Dungeon")+  )+where++import Control.Monad (when)+import Data.Foldable (for_)+import Data.Traversable (for)+import Mischief.ECS++-- $know+-- This book doesn't assume any knowledge of other game engines or programming paradigms, but it does expect some Haskell knowledge.+--+-- While it is possible to read this book and get a pretty good idea of what Mischief is and how it works, you'll have a much better time+-- if you have at least a very basic understanding of Haskell syntax.++-- $setup+-- In order to use Mischief, you'll first need to install @GHC@ and @cabal@. You can follow [this](https://www.haskell.org/cabal/) quick-start guide in order to do that.+--+-- After you have a new project set up, you need to install @mischief-ecs@:+--+-- @+-- cabal add mischief-ecs+-- @+--+-- We recommend using @GHC2024@ as the language standard (set in your @.cabal@ file).+--+-- == Language Extensions+-- We generally recommend using the following language extensions in a Mischief project:+--+-- @+-- DeriveAnyClass+-- DuplicateRecordFields+-- NoFieldSelectors+-- DerivingStrategies+-- OverloadedRecordDot+-- OverloadedStrings+-- QuasiQuotes+-- RequiredTypeArguments+-- TypeFamilyDependencies+-- @+--+-- @QuasiQuotes@ and @OverloadedStrings@ are especially important because some Mischief features are not available without them (namely quasi-queries and logging).+-- The rest of the extensions are highly optional.+--+-- You can paste these extensions in the @default-extensions@ field of your @.cabal@ file.++-- $app+-- A Mischief program usually starts with an app and a plugin.+--+-- @+-- import "Mischief.ECS.Prelude"+--+-- main :: 'IO' ()+-- main = do+--   app <- 'newApp' MyPlugin+--   'runApp' app+--+-- data MyPlugin = MyPlugin deriving ('Eq', 'Plugin')+-- @+--+-- If you copy this code into your project and run it using @cabal run@, your app will start! Although we haven't told it to do anything yet.+--+-- The @App@ is a wrapper around our @World@, which is the structure containing all data stored by the ECS. It allows us to add+-- initializition instructions and to plug additional logic into our game through @Plugins@.++-- $ecs+-- Mischief's ECS logic is designed to be very approachable and simple to write.+--+-- @Components@ are just types deriving the @Component@ typeclass.+--+-- @+-- data Position = Position {x :: 'Float', y :: 'Float'} deriving ('Component')+-- @+--+-- @Systems@ are functions in the @System@ monad.+--+-- @+-- printPositions :: 'System' ()+-- printPositions = do+--   'info' . 'text' =<< 'query' ('C' \@Position)+-- @+--+-- @Entities@ are ids used to represent and manipulate data.+--+-- @+-- data Entity = Entity 'Int'+-- @++-- $firstSystem+-- Paste the following function into your module:+--+-- @+-- helloWorld :: 'System' ()+-- helloWorld = 'info' "Hello World!"+-- @+--+-- This will be our first system. The only remaining step is to schedule it to run!+--+-- @+-- import "Mischief.ECS.Systems" qualified as [Systems]("Mischief.ECS.Systems")+-- @+--+-- @+-- instance 'Plugin' MyPlugin where+--+--   'Mischief.ECS.App.Plugins.init' :: MyPlugin -> 'System' ()+--   'Mischief.ECS.App.Plugins.init' _ = do+--     [Systems]("Mischief.ECS.Systems").'Mischief.ECS.Systems.add' 'Update' helloWorld+-- @+--+-- The @Systems.add@ function adds the system to your App's update schedule, making it run once per frame. If you run your app again,+-- you will see \"Hello World!\" printed to your terminal many, many times.+--+-- As you may have noticed, the @init@ we give to the Plugin is, in itself, a system! There's nothing differentiating+-- the logic you write here from the logic ran at any point in your app's runtime. @init@ is just a convenient way of+-- adding some initialization that happens before anything else, but we'll get into that later.++-- $firstComp+-- Let's do a little more than greeting the whole world, let's greet some individual people!+--+-- In ECS, you would generally model people as entities with a set of components that define them. Let's start with a simple @Person@ component:+--+-- @+-- data Person = Person deriving ('Component')+-- @+--+-- So how can we give people names? In a more traditional design you could just add a @name :: String@ field to @Person@. But the ECS makes you think of it differently!+-- A @Name@ is just a piece of data that can be attached to anything. A dog could also have a name. So why not just make a @Name@ component?+--+-- @+-- data Name = Name 'String' deriving ('Component')+-- @+--+-- No need to define it though, since this exact @Name@ is already defined internally by Mischief, you can just use it directly.+--+-- Now that we can represent people with names, let's make a system that spawns some:+--+-- @+-- addPeople :: 'System' ()+-- addPeople = do+--   kim <- 'spawn' (Person, Name \"Kimberly\")+--   nick <- 'spawn' (Person, Name \"Nicholas\")+--   flo <- 'spawn' (Person, Name \"Florian\")+--   'pure' ()+-- @+--+-- You can register it to run on the app's startup like this:+--+-- @+-- 'Mischief.ECS.App.Plugins.init' _ = do+--   [Systems]("Mischief.ECS.Systems").'Mischief.ECS.Systems.add' 'Startup' addPeople+--   [Systems]("Mischief.ECS.Systems").'Mischief.ECS.Systems.add' 'Update' helloWorld+-- @++-- $firstQuery+-- If you run your app, the people will be spawned but we aren't doing anything with them yet! Let's make a system that greets them:+--+-- @+-- greetPeople :: 'System' ()+-- greetPeople = do+--   people <- 'query' ('C' \@Name, 'C' \@Person)+--   'for_' people $ \(name, _) ->+--     'info' $ \"Hello \" <> 'text' name+-- @+--+-- The above query will grab the @Name@ and @Person@ of every entity. Then it iterates over them  in order to greet them.+--+-- The @Person@ component however, is only queried to ensure we are querying the right entities. We don't care about its value at all! So we can instead write it+-- as a filter to limit the types of entities selected by the query and save us the trouble of carrying an extra variable around.+--+-- @+-- greetPeople :: 'System' ()+-- greetPeople = do+--   people <- 'query'' ('C' \@Name) ('With' ('C' \@Person))+--   'for_' people $ \name ->+--     'info' $ \"Hello \" <> 'text' name+-- @+--+-- Do note the use of @query'@ here instad of @query@. The former is a variant of the same function but which also expects a filter.+--+-- Mischief has two equivalent ways of writing queries. The normal way that you've seen above, and the quasi way:+--+-- @+-- people <- ['q'|Name / With Person|]+-- @+--+-- Query-queries are macros meant to simplify writing queries. They'll become especially helpful once we start dealing+-- with relationships and transitive queries.+--+-- Now we can schedule this system to also run:+--+-- @+-- 'Mischief.ECS.App.Plugins.init' _ = do+--   [Systems]("Mischief.ECS.Systems").'Mischief.ECS.Systems.add' 'Startup' addPeople+--   [Systems]("Mischief.ECS.Systems").'Mischief.ECS.Systems.add' 'Update' (helloWorld, greetPeople)+-- @+--+-- Running our app will result in the following output:+--+-- @+-- [INFO] Hello World!+-- [INFO] Hello Kimberly+-- [INFO] Hello Nicholas+-- [INFO] Hello Florian+-- @+--+-- Note that \"Hello World\" might show above or beneath the other people, since systems in the same schedule can run in any order unless they are explicitly ordered.++-- $firstMut+-- If we want to change the name of some people, we can apply a mutation to a value obtained from the query:+--+-- @+-- updateFlo :: 'System'+-- updateFlo = do+--   people <- ['q'|Name / With Person|]+--   'for_' people $ \name -> do+--     'when' (name == Name \"Florian\") $+--       'set' name (Name \"Florianne\")+-- @+--+-- Although.. that feels awfully imperative doesn't it? We can also write the same system as:+--+-- @+-- updateFlo = do+--   florians <- ['q'|Name / With Person, Check (== Name \"Florian\")|]+--   'for_' florians $ '`set`' Name \"Florianne\"+-- @+--+-- The above query can also be written like this, in non-quasi notation:+--+-- @+-- florians <- 'query'' ('C' \@Name) ('With' ('C' \@Person), 'Check' (== Name \"Florian\"))+-- @+--+-- Let's add the new system to a schedule:+--+-- @+-- 'Mischief.ECS.App.Plugins.init' _ = do+--   [Systems]("Mischief.ECS.Systems").'Mischief.ECS.Systems.add' 'Startup' addPeople+--   [Systems]("Mischief.ECS.Systems").'Mischief.ECS.Systems.add' 'Update' (helloWorld, greetPeople)+--   [Systems]("Mischief.ECS.Systems").'Mischief.ECS.Systems.add' 'Update' $ updateFlo '`before`' greetPeople+-- @+--+-- Note that we have explicitly ordered @updateFlo@ to happen before @greetPeople@. We want to only greet Flo after their name has changed!++-- $res+-- Resources are a great way to store global information that can be easily written to and read in any system.+--+-- Let's say we want to have a custom greeting that we can change at runtime. We could store that in a resource:+--+-- @+-- data Greeting = Greeting 'String' deriving ('Component')+-- @+--+-- Yes, resources are just normal components! Any component can be stored and retrieved as a resource by using @insertRes@ and @res@.+--+-- Let's insert a greeting from our init system:+--+-- @+-- 'Mischief.ECS.App.Plugins.init' _ = do+--   [Systems]("Mischief.ECS.Systems").'Mischief.ECS.Systems.add' 'Startup' addPeople+--   [Systems]("Mischief.ECS.Systems").'Mischief.ECS.Systems.add' 'Update' (helloWorld, greetPeople)+--   [Systems]("Mischief.ECS.Systems").'Mischief.ECS.Systems.add' 'Update' $ updateFlo '`before`' greetPeople+--+--   'insertRes' (Greeting \"Hey\")+-- @+--+-- And let's modify @greetPeople@ so that it uses the current greeting from the resource:+--+-- @+-- greetPeople :: 'System' ()+-- greetPeople = do+--   'Just' (Greeting greeting) <- 'res' \@Greeting+--+--   people <- ['q'|Name / With Person]+--   'for_' people $ \name ->+--     'info' $ 'text' greeting <> \" \" <> 'text' name+-- @+--+-- You should now see this when running the app:+--+-- @+-- [INFO] Hello World!+-- [INFO] Hey Kimberly+-- [INFO] Hey Nicholas+-- [INFO] Hey Florianne+-- @++-- $rel+-- Relationships in Mischief are pairs made up of a Component and an Entity. Let's implement a simple relationship between our entities that says which like which.+--+-- We'll start by defining a component:+--+-- @+-- data Likes = Likes deriving ('Component')+-- @+--+-- Let's now modify our spawning system to also insert relationships between our three entities. We can insert a relationship using the @Rel@ keyword.+--+-- @+-- 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+-- @+--+-- We've now made @flo@ like @kim@, and we've made @kim@ like both @nick@ and @flo@!.++-- $trans+-- We now have relationships but we aren't doing much with them. What about having a system that displays the name of each entity, along with the name of all entities they like?+--+-- There are a few different ways to get the names of entities that a given entity likes, for instance we could do:+--+-- @+-- people <- 'query' ('C' \@Name, 'R' \@Likes Any)+--+-- 'for_' people $ \(name, likes) -> do+--   names \<- 'for' likes $ \\l -\> 'get' ('C' \@Name) l.target+--   'info' $ 'text' name <> " likes " <>  'text' names+-- @+--+-- We get the name of each entity, along with all their @Likes@ relationships (using the @R@ marker). Then, for each entity, we iterate over all their relationships and get the names of the targets.+-- (@get@ is just like @query@ but it queries the components of a specific entity).+--+-- But we'll have a way easier time getting there by just using @transitive queries@!+-- Rather than querying for the relationships themselves, Mischief allows us to query for the components of the relationship targets from within the same query:+--+-- @+-- people <- 'query' ('C' \@Name, 'R' \@Likes ('Q' ('C' \@Name)))+--+-- 'for_' people $ \(name, names) -> do+--   'info' $ 'text' name <> " likes " <> 'text' names+-- @+--+-- There's no need for a second query to grab the names. The equivalent quasi-query looks like this:+--+-- @+-- people \<- ['q'|Name, Likes -\> (Name)|]+-- @+--+-- Pretty nice, huh?+--+-- Let's now put this logic in a proper system and schedule it to run:+--+-- @+-- showLikes :: 'System' ()+-- showLikes = do+--   people \<- ['q'|Name, Likes -\> (Name)|]+--+--   'for_' people $ \(name, names) -> do+--     'info' $ 'text' name <> " likes " <> 'text' names+-- @+--+-- @+-- 'Mischief.ECS.App.Plugins.init' _ = do+--   [Systems]("Mischief.ECS.Systems").'Mischief.ECS.Systems.add' 'Startup' addPeople+--   [Systems]("Mischief.ECS.Systems").'Mischief.ECS.Systems.add' 'Update' (helloWorld, greetPeople, showLikes)+--   [Systems]("Mischief.ECS.Systems").'Mischief.ECS.Systems.add' 'Update' $ updateFlo '`before`' greetPeople+--+--   'insertRes' (Greeting \"Hey\")+-- @+--+-- We should now see these additional likes printed to the terminal:+--+-- @+-- [INFO] \"Florianne\" likes [\"Kimberly\"]+-- [INFO] \"Kimberly\"  likes [\"Nicholas\", \"Florianne\"]+-- @++-- $next+-- What you learn next is up to you.+--+-- The next chapter will have you working on a little dungeon game in the terminal and introduce you to more notions. If you prefer to learn by example it's recommended to+-- go check that out.+--+-- After that, the next chapters go into detail on various topics (Components, Queries, Systems, etc.), so you may choose to just read those directly, and maybe come+-- back to the game later.
+ src/Mischief/ECS/Tutorial/Systems.hs view
@@ -0,0 +1,397 @@+{-# OPTIONS_GHC -Wno-unused-imports #-}++-- |+-- Module: Systems Tutorial+-- Description: Tutorial on using @Systems@+--+-- This module contains a more in-depth tutorial on using @Mischief Systems@.+--+-- [Previous Chapter: Queries]("Mischief.ECS.Tutorial.Queries")+--+-- [Next Chapter: Events and Messages]("Mischief.ECS.Tutorial.Events")+--+-- [Main Page]("Mischief.ECS")+module Mischief.ECS.Tutorial.Systems+  ( -- * Learn You an ECS for Great Mischief! - 7. Systems+    -- $intro++    -- * Scheduling+    -- $scheduling++    -- * Schedules+    -- $schedules++    -- * Deferring+    -- $deferring++    -- * Parallelism+    -- $par++    -- * Asynchronicity+    -- $async++    -- * [Next Chapter: Events and Messages]("Mischief.ECS.Tutorial.Events")+  )+where++import Control.Concurrent (threadDelay)+import Control.Monad.Reader+import Data.Foldable (for_)+import Mischief.ECS++-- $intro+-- A @System@ in Mischief is a Monad that executes operations on a World.+--+-- Unlike other ECS's, systems here are fully composable, In fact, most of the functions discussed in this tutorial so far were systems.+-- For instance, the type of @spawn@ is:+--+-- @+-- 'spawn' :: ('Bundle' b) => b -> 'System' ()@+-- @+--+-- Systems can either be ran directly, or they can be added scheduled.++-- $scheduling+-- Any @System ()@ can be added to a @Schedule@. This will make the system run when that schedule is ran.+--+-- There are two ways of scheduling systems, an automatic and a manual way. Tools for using both are found in "Mischief.ECS.Systems".+--+-- == Automatic+--+-- In order to schedule a system we just use the @add@ function:+--+--+-- @+-- data SomeSchedule = SomeSchedule deriving ('Schedule')+-- systemA :: 'System' ()+-- @+--+-- @+-- [Systems]("Mischief.ECS.Systems").'Mischief.ECS.Systems.add' SomeSchedule systemA+-- @+--+-- This will register @systemA@ and schedule it to run in @SomeSchedule@.+--+-- Systems scheduled this way are considered a unique combination of the actual system and the schedule.+-- If we were to add @systemA@ to /another/ schedule, it would be considered a different system.+--+-- You can also add a tuple of systems directly:+--+-- @+-- [Systems]("Mischief.ECS.Systems").'Mischief.ECS.Systems.add' SomeSchedule (systemA, systemB)+-- @+--+-- This function also allows custom ordering between systems. For instance, if we want to schedule a new @systemC@ that happens /before/ @systemA@ and /after/ @SystemB@:+--+-- @+-- [Systems]("Mischief.ECS.Systems").'Mischief.ECS.Systems.add' SomeSchedule $ systemC '`before`' systemA '`after`' systemB+-- @+--+-- One very important thing to keep in mind is that a scheduled system is only unique as long as the type you're registering is @System ()@.+--+-- For instance, scheduling this system:+--+-- @+-- systemA :: 'Int' -> 'System' ()+-- @+--+-- @+-- [Systems]("Mischief.ECS.Systems").'Mischief.ECS.Systems.add' SomeSchedule (systemA 5)+-- @+--+-- And then another system which we want to run after:+--+-- @+-- [Systems]("Mischief.ECS.Systems").'Mischief.ECS.Systems.add' SomeSchedule $ systemB '`after`' (systemA 4)+-- @+--+-- Will compile fine, but since @systemA 5@ and @systemA 4@ are different systems, we've basically told @systemB@ to happen after a system that's not even running.+--+-- Both @systemB@ and @systemA 5@ will run, but there won't be any explicit ordering between them.+--+-- A system that's been added with @Systems.add@ can be removed using @Systems.remove@:+--+-- @+-- [Systems]("Mischief.ECS.Systems").'Mischief.ECS.Systems.remove' SomeSchedule systemA+-- @+--+-- Note however, that this will also erase all orderings @systemA@ had with other systems at that point.+--+-- If you wish to just temporarily disable a system while keeping its configuration, you can use+-- @[Systems]("Mischief.ECS.Systems").'Mischief.ECS.Systems.unschedule'@ instead. And then use @[Systems]("Mischief.ECS.Systems").'Mischief.ECS.Systems.schedule'@ to+-- re-enable it.+--+-- == Manual+--+-- In order to schedule a system manually you just spawn an entity for it:+--+-- @+-- foo :: 'System' ()+-- @+--+-- @+-- fooEntity <- [Systems]("Mischief.ECS.Systems").'Mischief.ECS.Systems.spawn' foo+-- @+--+-- And then link that entity to a schedule via the @ScheduledIn@ relationship.+--+-- @+-- someSchedule <- [Schedules]("Mischief.ECS.Schedules").'Mischief.ECS.Schedules.get' SomeSchedule+-- 'insert' ('Rel' 'ScheduledIn' someSchedule) fooEntity+-- @+--+-- This will make make your system run along with @SomeSchedule@. Compared to using @Systems.add@, this method will not do any sort of bookkeeping for you.+-- Is is your job to keep track of the spawned system's entity.+--+-- Two systems can be ordered by using the @Before@ relationship:+--+-- @+-- fooEntity <- [Systems]("Mischief.ECS.Systems").'Mischief.ECS.Systems.spawn' foo+-- barEntity <- [Systems]("Mischief.ECS.Systems").'Mischief.ECS.Systems.spawn' bar+--+-- 'insert' ('Rel' 'Before' fooEntity) barEntity+-- @+--+-- The above will order @bar@ to happen before @foo@.++-- $schedules+-- Same as systems, @Schedules@ are entities. Each schedule has an associated type, usually empty:+--+-- @+-- data Update = Update deriving ('Schedule')+-- @+--+-- You can both register and get the the entity of a schedule using @Schedules.get@:+--+-- @+-- update <- [Schedules]("Mischief.ECS.Schedules").'Mischief.ECS.Schedules.get' Update+-- @+--+-- You can run a schedule using @Schedules.run@:+--+-- @+-- [Schedules]("Mischief.ECS.Schedules").'Mischief.ECS.Schedules.run' Update+-- @+--+-- This will run all systems currently linked to that Schedule, respecting their ordering.+--+-- Mischief has two components: @'StartupSchedule'@ and @'UpdateSchedule'@ which you can add to a schedule to make it automatically run on app startup, respectively each frame.+--+-- These schedules can also be ordered via @'Before'@ (same relationship used for ordering systems).+--+-- The systems Mischief has by default in Startup:+--+-- * 'PreStartup'+-- * 'Startup'+-- * 'PostStartup'+--+-- And in Update:+--+-- * 'First'+-- * 'PreUpdate'+-- * 'Update'+-- * 'PostUpdate'+--+-- @First@ is usually reserved for internal systems (such as updating time).++-- @The startup schedules@ run once at the start of the app, before any Update, in this order:++-- * 'PreStartup'++-- * 'Startup'++-- * 'PostStartup++--+-- @The update shchedules@ run once every frame, in this order:+--++-- * 'First'++-- * 'PreUpdate'++-- * 'Update'++-- * 'PostUpdate'++-- 'Last'+--+-- Note that @First@ and @Last@ are reserved mostly for ECS internal logic and should generally be avoided.+--+-- In order to add a system @s :: 'System' ()@ to a schedule @sc@, you can use this 'Plugin':+--+-- @+-- 'addSystems' :: ('Schedule' sc, 'SystemConfig' s) => sc -> s -> 'Plugin' ()+-- @+--+-- @'SystemConfig'@ is a typeclass that allows you to provide stuff like a @'System' ()@, a tuple of systems, or a system ordered to happen after / before another system.+--+-- @+-- 'addSystems' 'Update' a+-- @+--+-- @+-- 'addSystems' 'Update' (a, b)+-- @+--+-- @+-- 'addSystems' 'Update' $ a '`after`' b+-- @+--+-- @+-- 'addSystems' 'Update' $ (a, b) '`after`' c '`before`' d+-- @+--+-- Keep in mind that when you add @a '`after`' b@, this will just add @a@ to the schedule; @b@ needs to be added separately, and doesn't need+-- to be in the same plugin. It's even possible to create and order a system to run before a system defined internally by Mischief, as long as+-- that system is exported and visible to you.+--+-- Additionally, these are equivalent:+--+-- @+-- 'addSystems' b+-- 'addSystems' 'Update' $ a `'after'` b+-- @+--+-- @+-- 'addSystems' 'Update' $ a `'after'` b+-- 'addSystems' b+-- @+--+-- Note that when you order systems, they will be ordered only in the context of the current schedule.+-- So @'addSystems' 'Update' $ a '`after`' b@ will order @a@ after the system @b@ that's in Update, if there is one at the point of running the app.+--+-- Also, a system can be added to any number of schedules. Adding a system twice to the same schedule will have no effect.++-- $deferring+-- Time to learn a very powerful and important primitive:+--+-- @+-- 'defer' :: 'System' a -> 'System' ()+-- @+--+-- All the systems presented so far in this tutorial had their effect applied immediately. When you write @set Name $ Name \"Player\"@,+-- you are /immediately/ mutating the respective component. When you do @e <- 'spawn' ()@, you are /immediately/ spawning that entity into the World.+--+-- @'defer'@ takes a system and adds it to an internal list instead of applying it.+--+-- @+-- 'defer' $ 'spawn' ()+-- @+--+-- @+-- 'defer' $ do+--   e <- 'spawn' ()+--   'insert' ('Name' \"Name\") e+-- @+--+-- You can then use @'flush'@ to empty the list of deferred systems, applying all of them.+-- Mischief automatically runs @'flush'@ at each @sync point@, usually at the end of each scheduled system.+--+-- @forkDeref@ is a useful function that temporarily restricts @flush@ to just the current context:+--+-- @+-- 'defer' $ a+--+-- 'forkDefer' $ do+--   'defer' $ do+--     b+--     c+--   'flush'+-- @+--+-- The above @flush@ will just run @b@ and @c@. @forkDeref@ will drain all non-flushed systems into the outer context.+--+-- There is also a special @'deferSpawn'@ primitive that immediately returns an @Entity@ you can use but defers the actual spawn.++-- $par+-- @Parallelism@ in Mischief happens through the @'ParSystem'@ monad.+--+-- @ParSystem@ is a special variant of @System@ that forbids any mutations to the World.+--+-- This will throw a compilation error:+--+-- @+-- s :: 'ParSystem' ()+-- s = 'void' $ 'spawn' ()+-- @+--+-- There are generally 2 types of operations allowed in a @ParSystem@:+--+-- * Queries+-- * Deferred Systems+--+-- So for instance, if we want to read and change the name of the player in a @ParSystem@:+--+-- @+-- changeName :: 'ParSystem' ()+-- changeName = do+--   'Just' name <- 'single'' ('C' \@Name) ('With' ('C' \@Player))+--   'defer' $ 'set' name (Name "New Name")+-- @+--+-- so how can we actually run systems in parallel? There are two main primitives used for it: @par@ and @parIter@:+--+-- @par@ is given a list of @'ParSystem' ()@ and will run each of them in parallel:+--+-- @+-- 'par' [foo, bar, baz]+-- @+--+-- @parIter@ (and @parIter_@ which ignores the result) applies a @ParSystem@ over the elements of a list. Given a list of Entities, this is how we can get their names in parallel:+--+-- @+-- entities :: ['Entity']+-- @+--+-- @+-- names <- 'parIter' entities $ 'get' ('C' \@Name)+-- @+--+-- These primtiives should only be used in performance which are at the risk of bottlenecking performance.++-- $async+-- Mischief has a couple of primitived that allow running systems asynchronously.+--+-- === runAfter+--+-- Asynchonicity in Mischief can be achieved using the @runAfter@ primtitive.+-- You provide it an 'IO' action that returns an @a@, and a system which consumes that @a@.+--+-- The 'IO' will be ran fully asychrnously and then will add the system to a special async-friendly deferred list that+-- will be applied at the first available sync point.+--+-- We can look at @delay@ as an example of how this may be useful:+--+-- @+-- 'delay' d system = 'runAfter' ('threadDelay' d) ('const' system)+-- @+--+-- Whcih allows delaying any system by an amount of time:+--+-- @+-- 'delay' 500 $ 'insert' (Health 100) player+-- @+--+-- === Intervals+--+-- Intervals are another way of running async systems.+--+-- @+-- import "Mischief.ECS.Interval" qualified as [Interval]("Mischief.ECS.Interval")+-- @+--+-- This allows you to set a system to repeatedly run on a fixed interval:+--+--+-- This will print \"Hello!\" once per second:+--+-- @+-- hello <- [Interval]("Mischief.ECS.Interval").'Mischief.ECS.Interval.start' 1000 ('info' \"Hello!\")+-- @+--+-- The interval can be stopped at any time by calling @Interval.stop@ on the returned object:+--+-- @+-- [Interval]("Mischief.ECS.Interval").'Mischief.ECS.Interval.stop' hello+-- @
+ src/Mischief/ECS/Utils.hs view
@@ -0,0 +1,28 @@+module Mischief.ECS.Utils where++import Data.Data+import Data.Foldable+import Data.Kind+import Data.Maybe+import GHC.Stack++class GetRep t where+  getRep :: t -> TypeRep++findM :: forall (m :: Type -> Type) a t. (Monad m, Foldable t) => (a -> m Bool) -> t a -> m (Maybe a)+findM f l = f' f (toList l)+  where+    f' _ [] = pure Nothing+    f' f (x : xs) = do+      b <- f x+      if b+        then+          pure $ Just x+        else+          findM f xs++unwrap :: (HasCallStack) => Maybe a -> a+unwrap = withFrozenCallStack $ fromMaybe undefined++(>>+) :: forall (m :: Type -> Type) a b. (Monad m) => m a -> (a -> m b) -> m a+(>>+) a f = a >>= f >>= const a
+ src/Mischief/ECS/Vec.hs view
@@ -0,0 +1,399 @@+-- Adapted from `grow-vector` as the package seems unmaintained+-- Module defines mutable vector that can grow in size automatically when an user+-- adds new elements at the end of vector.+--+-- We reallocate vector with 1.5x length to get amortized append.+module Mischief.ECS.Vec+  ( Vec (..),+    IOVec,++    -- * Quering info about vector+    length,+    null,+    capacity,++    -- * Creation+    new,+    newSized,++    -- * Quering subvectors+    slice,++    -- * Converting to immutable+    thaw,+    freeze,+    toList,++    -- * Capacity maninuplation+    ensure,+    ensureAppend,++    -- * Accessing individual elements+    read,+    write,+    unsafeRead,+    unsafeWrite,++    -- * Appending to vector+    pushBack,+    unsafePushBack,++    -- * modify an element+    modify,+    modify_,+    modifyM,+    modifyM_,++    -- * general utilities+    swap,+    tap,+    shrink,++    -- * O(1) amortized swap backed operations+    takeSwap,+    removeSwap,++    -- * cloning, very naive approach+    clone,+  )+where++import Control.Monad+import Control.Monad.Primitive+import Data.Foldable (for_)+import Data.Primitive.MutVar+import Data.Vector (Vector)+import Data.Vector qualified as Vector+import Data.Vector.Mutable (MVector)+import Data.Vector.Mutable qualified as MVector+import Debug.Trace (traceShow)+import GHC.Generics+import GHC.Stack (HasCallStack)+import Prelude hiding (length, null, read)++-- | Normal rust-like vector with buffer (the MVector) + len (the len field) + cap (the `buffer` length)+data Vec s a = Vec+  { buffer :: !(MutVar s (MVector s a)),+    len :: !(MutVar s Int)+  }+  deriving (Generic)++type IOVec a = Vec RealWorld a++-- | Return current capacity of the vector (amount of elements that it can fit without realloc)+capacity :: (PrimMonad m) => Vec (PrimState m) a -> m Int+capacity v =+  MVector.length <$> readMutVar v.buffer+{-# INLINE capacity #-}++-- | Return current amount of elements in the vector+length :: (PrimMonad m) => Vec (PrimState m) a -> m Int+length v = readMutVar v.len+{-# INLINE length #-}++-- | Return 'True' if there is no elements inside the vector+null :: (PrimMonad m) => Vec (PrimState m) a -> m Bool+null v = (== 0) <$> length v++-- | Allocation of new growable vector with given capacity.+new :: (PrimMonad m) => Int -> m (Vec (PrimState m) a)+new = newSized 0+{-# INLINE new #-}++-- | Allocation of new growable vector with given filled size and capacity.+-- Elements is not initialized. Capacity must be greater than filled size.+newSized :: (PrimMonad m) => Int -> Int -> m (Vec (PrimState m) a)+newSized n cap = do+  buffer <- MVector.new cap+  buffer <- newMutVar buffer+  len <- newMutVar n+  pure Vec {buffer, len}+{-# INLINEABLE newSized #-}++-- | Yield a part of mutable vector without copying it. The vector must contain at least i+n elements.+slice ::+  (PrimMonad m) =>+  -- | i starting index+  Int ->+  -- | n number of elements+  Int ->+  Vec (PrimState m) a ->+  m (Vec (PrimState m) a)+slice i n v = do+  len <- newMutVar n+  mv <- readMutVar v.buffer+  buffer <- newMutVar $! MVector.slice i n mv+  pure $! Vec {len, buffer}+{-# INLINEABLE slice #-}++-- | Convert immutable vector to grow mutable version. Doesn't allocate additonal memory for appending,+-- use 'ensure' to add capacity to the vector.+thaw ::+  (PrimMonad m) =>+  Vector a ->+  m (Vec (PrimState m) a)+thaw u = do+  buffer <- newMutVar =<< Vector.thaw u+  len <- newMutVar $! Vector.length u+  pure Vec {buffer, len}+{-# INLINEABLE thaw #-}++-- | Freezing growable vector. It will contain only actual elements of the vector not including capacity+-- space, but you should call 'U.force' on resulting vector to not hold the allocated capacity of original+-- vector in memory.+freeze ::+  (PrimMonad m) =>+  Vec (PrimState m) a ->+  m (Vector a)+freeze v = do+  n <- length v+  mv <- readMutVar v.buffer+  Vector.freeze $ MVector.take n mv+{-# INLINEABLE freeze #-}++toList ::+  (PrimMonad m) =>+  Vec (PrimState m) a ->+  m [a]+toList vec = Vector.toList <$> freeze vec++ensure_not_oob ::+  (HasCallStack, PrimMonad m) =>+  String ->+  -- | the name of the function+  Int ->+  -- | The element we want to check+  Vec (PrimState m) a ->+  -- | The length of the vec+  m ()+ensure_not_oob fname i vec = do+  len <- length vec+  when (i < 0 || i >= len) $ do+    error $ mconcat [fname, ": index ", show i, " is out bounds ", show len]++-- | Ensure that grow vector has at least given capacity possibly with reallocation.+ensure ::+  (PrimMonad m) =>+  Vec (PrimState m) a ->+  Int ->+  m ()+ensure v cap = do+  current_cap <- capacity v+  unless (current_cap >= cap) $ do+    buffer <- readMutVar v.buffer+    grown <- MVector.grow buffer (cap - current_cap)+    writeMutVar v.buffer grown+{-# INLINEABLE ensure #-}++-- | Ensure that grow vector has enough space for additonal n elements.+-- We grow vector by 1.5 factor or by required elements count * 1.5.+ensureAppend ::+  (PrimMonad m) =>+  Vec (PrimState m) a ->+  -- | Additional n elements+  Int ->+  m ()+ensureAppend vec i = do+  len <- length vec+  buf <- readMutVar vec.buffer+  let cap = MVector.length buf+  unless (cap >= len + i) $ do+    -- ugly as shit code would like to fix+    let newCap = ceiling $ max (growFactor * fromIntegral cap) (fromIntegral cap + growFactor * fromIntegral (len + i - cap))+    new_buf <- MVector.grow buf (newCap - cap)+    writeMutVar vec.buffer new_buf+  where+    growFactor :: Double+    growFactor = 1.5+{-# INLINEABLE ensureAppend #-}++-- | Read element from vector at given index.+read ::+  (HasCallStack, PrimMonad m) =>+  Vec (PrimState m) a ->+  -- | Index of element. Must be in [0 .. length) range+  Int ->+  m a+read vec i = do+  ensure_not_oob "Vec.read" i vec+  buf <- readMutVar vec.buffer+  MVector.unsafeRead buf i+{-# INLINEABLE read #-}++-- | Read element from vector at given index, without checking whether the index is inbounds+unsafeRead ::+  (PrimMonad m) =>+  Vec (PrimState m) a ->+  -- | Index of element. Must be in [0 .. length) range+  Int ->+  m a+unsafeRead vec i = do+  buf <- readMutVar vec.buffer+  MVector.unsafeRead buf i+{-# INLINEABLE unsafeRead #-}++-- | Write down element in the vector at given index.+write ::+  (PrimMonad m) =>+  Vec (PrimState m) a ->+  -- | Index of element. Must be in [0 .. length) range+  Int ->+  a ->+  m ()+write vec i value = do+  ensure_not_oob "Vec.write" i vec+  buf <- readMutVar vec.buffer+  MVector.unsafeWrite buf i value+{-# INLINEABLE write #-}++-- | Write down element in the vector at given index.+unsafeWrite ::+  (PrimMonad m) =>+  Vec (PrimState m) a ->+  -- | Index of element. Must be in [0 .. length) range+  Int ->+  a ->+  m ()+unsafeWrite vec i value = do+  buf <- readMutVar vec.buffer+  MVector.unsafeWrite buf i value+{-# INLINEABLE unsafeWrite #-}++modify ::+  (PrimMonad m) =>+  Vec (PrimState m) a ->+  Int ->+  (a -> a) ->+  m a+modify vec i f = do+  ensure_not_oob "Vec.modify" i vec+  old_val <- read vec i+  write vec i (f old_val)+  pure old_val+{-# INLINEABLE modify #-}++modify_ ::+  (PrimMonad m) =>+  Vec (PrimState m) a ->+  Int ->+  (a -> a) ->+  m ()+modify_ vec i f = do+  ensure_not_oob "Vec.modify_" i vec+  old_val <- read vec i+  write vec i (f old_val)+{-# INLINEABLE modify_ #-}++modifyM ::+  (PrimMonad m) =>+  Vec (PrimState m) a ->+  Int ->+  (a -> m a) ->+  m a+modifyM vec i f = do+  ensure_not_oob "Vec.modifyM" i vec+  old_val <- read vec i+  write vec i =<< f old_val+  pure old_val+{-# INLINEABLE modifyM #-}++modifyM_ ::+  (PrimMonad m) =>+  Vec (PrimState m) a ->+  Int ->+  (a -> m a) ->+  m ()+modifyM_ vec i f = do+  ensure_not_oob "Vec.modifyM_" i vec+  old_val <- read vec i+  write vec i =<< f old_val+{-# INLINEABLE modifyM_ #-}++tap ::+  (PrimMonad m) =>+  Vec (PrimState m) a ->+  Int ->+  (a -> m ()) ->+  m ()+tap vec i act = do+  ensure_not_oob "Vec.tap" i vec+  act =<< read vec i+{-# INLINE tap #-}++-- | O(1) amortized appending to vector+pushBack ::+  (PrimMonad m) =>+  Vec (PrimState m) a ->+  a ->+  m ()+pushBack vec value = do+  ensureAppend vec 1+  unsafePushBack vec value+{-# INLINEABLE pushBack #-}++-- | O(1) amortized appending to vector. Doesn't reallocate vector, so+-- there must by capacity - length >= 1.+unsafePushBack ::+  (PrimMonad m) =>+  Vec (PrimState m) a ->+  a ->+  m ()+unsafePushBack vec a = do+  len <- length vec+  buf <- readMutVar vec.buffer+  MVector.write buf len a+  writeMutVar vec.len (len + 1)+{-# INLINEABLE unsafePushBack #-}++swap ::+  (PrimMonad m) =>+  Vec (PrimState m) a ->+  Int ->+  -- | index of element #1 to swap+  Int ->+  -- | index of element #2 to swap+  m ()+swap vec i j = do+  when (i /= j) $ do+    ensure_not_oob "Vec.swap" i vec+    ensure_not_oob "Vec.swap" j vec+    buffer <- readMutVar vec.buffer+    MVector.swap buffer i j++shrink ::+  (PrimMonad m) =>+  Vec (PrimState m) a ->+  Int ->+  m ()+shrink vec amount = do+  old_len <- length vec+  writeMutVar vec.len (old_len - amount)++takeSwap ::+  (PrimMonad m) =>+  Vec (PrimState m) a ->+  Int ->+  m a+takeSwap vec i = do+  value <- read vec i+  removeSwap vec i+  pure value++removeSwap ::+  (PrimMonad m) =>+  Vec (PrimState m) a ->+  -- | index of element to remove+  Int ->+  m ()+removeSwap vec i = do+  len <- length vec+  swap vec i (len - 1)+  shrink vec 1++clone :: (PrimMonad m) => Vec (PrimState m) a -> m (Vec (PrimState m) a)+clone vec = do+  list <- toList vec+  len <- length vec+  newVec <- new len+  for_ list $ pushBack newVec+  return newVec
+ src/Mischief/ECS/World.hs view
@@ -0,0 +1,232 @@+module Mischief.ECS.World+  ( -- * World+    World (..),+    newWorld,+    setSystemId,+    setDeferred,+    setPrefs,+    forkPrefs,+    Frame (..),+    SystemTools (..),+    worldGet,+    worldGetRAny,+    worldSet,+    worldSpawnByInsert,++    -- * Systems+    System (..),+    SystemId (..),+    runSystem,+    MonadSystem,+    unsafeGetWorld,++    -- * Parallel+    ParSystem (..),+    ParWorld (..),+  )+where++import Colog qualified+import Control.Concurrent.STM (TVar, newTVarIO)+import Control.Monad.IO.Class (MonadIO (liftIO))+import Control.Monad.Primitive (PrimMonad (..), RealWorld)+import Control.Monad.Reader.Class (MonadReader (..), asks)+import Control.Monad.Trans (MonadTrans (..))+import Control.Monad.Trans.Reader (ReaderT (runReaderT))+import Data.Data+import Data.IORef (IORef, modifyIORef', newIORef, readIORef)+import Mischief.ECS.Archetypes (Archetypes, emptyArchetypes)+import Mischief.ECS.Collectable+import Mischief.ECS.Components+  ( Component (RelExclusivity),+    Components,+    Exclusivity (..),+    Rel,+    Tick (Tick),+    emptyComponents,+  )+import Mischief.ECS.Components.Bundle+import Mischief.ECS.Entities+  ( Entities,+    Entity (Entity),+    emptyEntities,+  )+import Mischief.ECS.EventDef+import Mischief.ECS.Hidden+import Mischief.ECS.Mappable+import Mischief.ECS.Tables (Tables, emptyTables)+import Mischief.ECS.World.Prefs (WorldPrefs, newPrefs)+import Mischief.ECS.World.Query.QueryType++-- | @The World@ is the main data structure storing the entities, components, archetypes, and everything else that lives in our app.+data World = World+  { -- | Archetype storage.+    archetypes :: Archetypes,+    -- | Components storage.+    components :: Components,+    -- | Entities storage.+    entities :: Entities,+    -- | Archetype tables. Storage for the actual data of components.+    tables :: Tables,+    -- | List of events to be ran at the next sync point.+    events :: IORef [ErasedEvent],+    -- | List of deferred system to be ran at the next sync point. They can also be flushed manually using 'flush'.+    deferred :: IORef [System ()],+    -- | Secondary list of deferred systems stored in a TVar, meant to be used when running systems asynchronously.+    -- They are ran at the first available sync point, and can also be flushed manually with 'flushAsync'.+    deferredAsync :: TVar [System ()],+    -- | The current tick, incremented each time a system is ran, used for change detection.+    tick :: IORef Tick,+    -- | Id of the current system.+    systemId :: SystemId,+    -- | The current frame.+    frame :: IORef Frame,+    -- | Certain toggleable settings.+    prefs :: WorldPrefs,+    logger :: Colog.LogAction IO Colog.Message,+    tools :: SystemTools+  }++newtype Frame = Frame Int deriving (Show, Eq, Ord)++-- | Unique id assigned to each system that's added to a schedule. Just a wrapper around Entity.+newtype SystemId = SystemId {id :: Entity} deriving (Show, Eq, Ord)++-- | Create a new World in IO.+newWorld :: SystemTools -> IO World+newWorld tools = do+  archetypes <- emptyArchetypes+  components <- emptyComponents+  entities <- emptyEntities+  tables <- emptyTables+  deferred <- newIORef []+  deferredAsync <- newTVarIO []+  events <- newIORef []+  tick <- newIORef (Tick (0, 0))+  frame <- newIORef (Frame 0)+  let prefs = newPrefs++  let logger = Colog.cmap Colog.fmtMessage Colog.logTextStdout++  return+    World+      { archetypes,+        components,+        entities,+        tables,+        events,+        deferred,+        deferredAsync,+        tick,+        systemId = SystemId (Entity (# 0##, 0## #)),+        frame,+        prefs,+        logger,+        tools+      }++-- | Change the current SystemId of the World.+setSystemId :: SystemId -> World -> World+setSystemId systemId world = world {systemId}++-- | Set the list of deferred systems of the World.+setDeferred :: IORef [System ()] -> World -> World+setDeferred deferred world = world {deferred}++-- | Set new WorldPrefs for the World.+setPrefs :: WorldPrefs -> World -> World+setPrefs prefs world = world {prefs}++-- | A System is a set of instructions applied over a World.+-- It can be added to the App to be ran on a certain Schedule.+--+-- A system is actually a wrapper around @'ReaderT' 'World' 'IO'@, meaning you can 'ask' for the World,+-- or do IO operations by using 'liftIO'.+newtype System a = System (ReaderT (Hidden World) IO a)+  deriving newtype (Functor, Applicative, Monad, MonadIO, MonadReader (Hidden World), MonadFail)++-- | Run a 'System' with the given 'World' inside 'IO'+runSystem :: System a -> World -> IO a+runSystem (System !r) w = runReaderT r (hide w)++instance PrimMonad System where+  type PrimState System = PrimState IO+  primitive = System . lift . primitive++-- | Run a 'System' with changed 'WorldPrefs'.+forkPrefs :: (WorldPrefs -> WorldPrefs) -> System a -> System a+forkPrefs f s = do+  world <- unsafeGetWorld+  let world' = setPrefs (f world.prefs) world+  liftIO $ runSystem s world'++-- | Special wrapper around World given to 'ParSystem's.+data ParWorld = ParWorld+  { -- | @Hidden@ ensures users cannot access and mutate the World.+    world :: Hidden World,+    -- | Deferred systems will be collected in this dedicated list and then+    -- merged back into the main deferred list once the parallel systems are joined.+    parDeferred :: IORef [System ()]+  }++-- | A variant of 'System' that contains a 'ParWorld' instead of 'World'.+--+-- @Parallel systems@ will only be able to run systems that are either specifically intended for them or+-- are made to work with any @'MonadSystem'@ (such as queries).+--+-- To run a normal @System ()@, you need to 'Mischief.ECS.World.Defer.defer'!+newtype ParSystem a = ParSystem (ReaderT ParWorld IO a)+  deriving newtype (Functor, Applicative, Monad, MonadIO, MonadReader ParWorld, MonadFail, PrimMonad)++class GetWorld a where+  getWorld :: a -> Hidden World++instance (GetWorld (Hidden World)) where+  getWorld = id++instance (GetWorld ParWorld) where+  getWorld x = x.world++-- | Typeclass that can be used to generalize systems to both @'System'@ and @'ParSystem'@.+--+-- Used mainly by queries and other operations which don't mutate the World.+class (GetWorld w, MonadReader w a, Applicative a, MonadFail a, Functor a, Monad a, MonadIO a, PrimMonad a, PrimState a ~ RealWorld) => MonadSystem w a++instance MonadSystem (Hidden World) System++instance MonadSystem ParWorld ParSystem++unsafeGetWorld :: (MonadSystem w m) => m World+unsafeGetWorld = do+  asks (unhide . getWorld)++instance EraseIntoStorage (System ()) [System ()] where+  erase :: System () -> [System ()]+  erase x = [x]++data SystemTools = SystemTools+  { get :: forall c m w. (MonadSystem w m, QueryType c) => Proxy c -> Entity -> m (Maybe c),+    getRAny :: forall c m w. (Component c, MonadSystem w m, RelExclusivity c ~ Inclusive) => Proxy c -> Entity -> m (Maybe [Rel c]),+    set :: forall c. (Bundle c) => c -> Entity -> System (),+    spawnByInsert :: forall b. (Bundle b) => Entity -> b -> System ()+  }++worldGet :: forall c m w. (MonadSystem w m, QueryType c) => Proxy c -> Entity -> m (Maybe c)+worldGet p e = do+  World {tools = SystemTools {get}} <- unsafeGetWorld+  get p e++worldSet :: forall c. (Bundle c) => c -> Entity -> System ()+worldSet c e = do+  World {tools = SystemTools {set}} <- unsafeGetWorld+  set c e++worldGetRAny :: forall c m w. (Component c, MonadSystem w m, RelExclusivity c ~ Inclusive) => Proxy c -> Entity -> m (Maybe [Rel c])+worldGetRAny p e = do+  World {tools = SystemTools {getRAny}} <- unsafeGetWorld+  getRAny p e++worldSpawnByInsert :: forall b. (Bundle b) => Entity -> b -> System ()+worldSpawnByInsert e b = do+  World {tools = SystemTools {spawnByInsert}} <- unsafeGetWorld+  spawnByInsert e b
+ src/Mischief/ECS/World/Change.hs view
@@ -0,0 +1,94 @@+module Mischief.ECS.World.Change where++import Control.Monad.Reader (MonadIO (liftIO), ask)+import Data.Foldable+import Data.IORef+import Data.Map qualified as Map+import Data.Maybe+import Data.Set qualified as Set+import GHC.Base (Int (..))+import GHC.Stack (HasCallStack)+import Mischief.ECS.App.SystemDef+import Mischief.ECS.Archetypes+import Mischief.ECS.Components+import Mischief.ECS.Components.Bundle+import Mischief.ECS.Entities+import Mischief.ECS.EntityDef+import Mischief.ECS.Events+import Mischief.ECS.Log+import Mischief.ECS.Tables+import Mischief.ECS.Vec qualified as Vec+import Mischief.ECS.World+import Mischief.ECS.World.Query+import Mischief.ECS.World.Query.Markers+import Mischief.ECS.World.Query.Queryable+import Mischief.ECS.World.Utils++data ChangeResult = ChangeResult+  { requiredComponentsAdded :: [ProcessedBundleElement],+    newComponents :: [ProcessedBundleElement]+  }++changeArchetype :: (HasCallStack) => Entity -> ArchetypeData -> Maybe ProcessedBundleData -> System ChangeResult+changeArchetype entity newArchetype insertedBundle = do+  world <- unsafeGetWorld+  currentTick <- liftIO $ readIORef world.tick++  reqAdded <- liftIO $ newIORef []++  Just pointer <- liftIO $ getPointer entity world.entities+  (EntityPointer (# archetypeId', rowIndex' #)) <- liftIO $ readIORef pointer++  table <- Vec.read world.tables.inner (I# archetypeId')++  collected <- liftIO $ takeComponentsFromTable (EntityPointer (# archetypeId', rowIndex' #)) table++  newElements'' <-+    mapM+      ( \component -> do+          case insertedBundle of+            Nothing -> maybe undefined return (find (\x -> x.id == component) collected.elements)+            Just bundle ->+              case find (\x -> x.id == component) bundle.elements of+                Just x -> return x+                Nothing ->+                  case find (\x -> x.id == component) collected.elements of+                    Just x -> return x+                    Nothing -> do+                      r <- getDefault component+                      liftIO $ modifyIORef' reqAdded (++ [r])+                      return r+      )+      $ Set.toList newArchetype.components++  let newElements = case insertedBundle of+        Nothing -> ProcessedBundleData newElements''+        Just bundle ->+          let newElements' = setChangedTickOfComponents (ProcessedBundleData newElements'') (\id -> isInProcessedBundle bundle id && isInProcessedBundle collected id) currentTick+           in setAddedTickOfComponents newElements' (\id -> isInProcessedBundle bundle id && not (isInProcessedBundle collected id)) currentTick++  liftIO $ insertEntityIntoTables newElements world.tables newArchetype.id (entity, pointer)++  requiredComponentsAdded <- liftIO $ readIORef reqAdded+  return ChangeResult {requiredComponentsAdded}++getDefault :: ComponentId -> System ProcessedBundleElement+getDefault (ComponentId (# id, e #)) = do+  world <- unsafeGetWorld++  Just x <- get (C @DefaultValue) (Entity (# id, 0## #))+  let dv = value x+  let (DefaultValue value) = dv++  let (SystemId sys) = world.systemId+  currentSystemTick <- fromMaybe (SystemTick $ Tick (0, 0)) <$> get (Val $ C @SystemTick) sys++  return+    ProcessedBundleElement+      { id = ComponentId (# id, e #),+        component =+          ComponentData+            { value,+              ticks = ComponentTicks {changed = currentSystemTick.inner, added = currentSystemTick.inner}+            }+      }
+ src/Mischief/ECS/World/Defer.hs view
@@ -0,0 +1,110 @@+module Mischief.ECS.World.Defer where++import Control.Concurrent+import Control.Concurrent.Async+import Control.Concurrent.STM+import Control.Exception+import Control.Monad.IO.Class+import Control.Monad.Reader+import Data.Foldable+import Data.Functor+import Data.IORef+import Mischief.ECS.Hidden+import Mischief.ECS.World++-- class Defer s where+--   -- | Defer a command to be ran after the current 'System' is finished,+--   -- or when 'flush' is called.+--   defer :: System a -> s++-- instance Defer (System ()) where+--   defer :: System a -> System ()+--   defer !system = do+--     world <- ask+--     liftIO $ modifyIORef' world.deferred (++ [system $> ()])++-- instance Defer (ParSystem ()) where+--   defer :: System a -> ParSystem ()+--   defer !system = do+--     ParWorld {deferred} <- ask+--     liftIO $ modifyIORef' deferred (++ [system $> ()])++class Defer m where+  defer :: System a -> m ()++instance Defer System where+  defer :: System a -> System ()+  defer !s = do+    world <- unsafeGetWorld+    liftIO $ modifyIORef' world.deferred (++ [s $> ()])++instance Defer ParSystem where+  defer :: System a -> ParSystem ()+  defer !s = do+    ParWorld {parDeferred} <- ask+    liftIO $ modifyIORef' parDeferred (++ [s $> ()])++-- | Flush the current list of deferred commands.+flush :: System ()+flush = do+  world <- unsafeGetWorld+  systems <- liftIO $ readIORef world.deferred++  for_ systems $ \s -> do+    forkDefer $ do+      s+      flush++  liftIO $ writeIORef world.deferred []++flushAsync :: System ()+flushAsync = do+  world <- unsafeGetWorld++  systems <- liftIO $ atomically $ do+    systems <- readTVar world.deferredAsync+    writeTVar world.deferredAsync []+    return systems++  for_ systems $ \s -> do+    forkDefer $ do+      s+      flush++forkDefer :: System a -> System a+forkDefer s = do+  world <- unsafeGetWorld+  deferred <- liftIO $ newIORef []++  let world' = setDeferred deferred world+  a <- liftIO $ runSystem s world'++  deferred <- liftIO $ readIORef deferred+  liftIO $ modifyIORef' world.deferred (++ deferred)+  return a++-- let world' =++-- forkSystem :: ParSystem () -> System ()+-- forkSystem (ParSystem !x) = do+--   world <- ask+--   _ <- liftIO $ forkIO $ do+--     deferred <- newIORef []+--     runReaderT x ParWorld {world, deferred}+--     deferred' <- readIORef deferred++--     atomically $ modifyTVar' world.deferredAsync (++ deferred')++--   return ()++runAfter :: (MonadSystem w m) => IO a -> (a -> System ()) -> m ()+runAfter !function !system = do+  world <- unsafeGetWorld+  _ <- liftIO $ forkIO $ do+    a <- function+    atomically $ modifyTVar' world.deferredAsync (++ [system a])++  return ()++delay :: (MonadSystem w m) => Int -> System () -> m ()+delay !d system = runAfter (threadDelay d) (const system)
+ src/Mischief/ECS/World/Insert.hs view
@@ -0,0 +1,229 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++module Mischief.ECS.World.Insert where++import Control.Exception+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Reader (MonadReader (..))+import Data.Data+import Data.Foldable (for_)+import Data.IORef+import Data.List hiding (insert)+import Data.Map qualified as Map+import Data.Maybe (fromMaybe)+import Data.Set qualified as Set+import Data.Text qualified as Text+import GHC.Base (Int (..))+import GHC.Stack+import Mischief.ECS.Archetypes+import Mischief.ECS.Archetypes.Graph+  ( getArchetypeOnInsert,+  )+import Mischief.ECS.Components+import Mischief.ECS.Components.Bundle+import Mischief.ECS.Entities+import Mischief.ECS.EntityDef+import Mischief.ECS.EventDef+import Mischief.ECS.Events+import Mischief.ECS.Log+import Mischief.ECS.Tables+import Mischief.ECS.Vec qualified as Vec+import Mischief.ECS.World+import Mischief.ECS.World.Change+import Mischief.ECS.World.Prefs+import Mischief.ECS.World.Query+import Mischief.ECS.World.Query.Markers+import Mischief.ECS.World.Query.Queryable+import Mischief.ECS.World.Utils++data Exception' = Exception' deriving (Show)++instance Exception Exception'++-- | Insert a bundle of components on an Entity.+--+-- If the entity already contains these components, their values will be+-- updated in-place instead of causing an archetype change.+insert :: (HasCallStack) => forall b. (Bundle b) => b -> Entity -> System ()+insert bundle entity =+  do+    world <- unsafeGetWorld+    pointer <- liftIO $ getPointer entity world.entities++    case pointer of+      Nothing -> warn $ "Insertion failed: Entity " <> text entity <> " is not alive."+      Just currentPointer -> do+        let BundleData {elements} = bundleData bundle++        currentTick <- liftIO $ readIORef world.tick++        bundleData <- liftIO $ processBundleElements world ComponentTicks {changed = currentTick, added = currentTick} elements+        let newComponents = sort $ map (\x -> x.id) bundleData.elements++        (EntityPointer (# archetypeId, rowIndex #)) <- liftIO $ readIORef currentPointer++        currentTable <- Vec.read world.tables.inner (I# archetypeId)++        -- Simple case, no archetype change.+        if newComponents `isSubsequenceOf` currentTable.components+          then+            liftIO $ replaceComponentsIntoTable bundleData (Just currentTick) (EntityPointer (# archetypeId, rowIndex #)) currentTable+          -- Complex case, archetype change.+          else do+            newArchetype <- getArchetypeOnInsert (ArchetypeId $ I# archetypeId) newComponents+            ChangeResult {requiredComponentsAdded} <- changeArchetype entity newArchetype (Just bundleData)++            unless world.prefs.supressEvents $+              triggerInsertEvent (ProcessedBundleData requiredComponentsAdded) entity++        unless world.prefs.supressEvents $+          triggerInsertEvent bundleData entity++getOrInsert :: forall qd. (Updateable (Result qd), Bundle qd) => qd -> Entity -> System (Result qd)+getOrInsert val entity = do+  g <- update (Result (val, entity))+  case g of+    Just g -> return g+    Nothing -> do+      insert val entity+      return $ Result (val, entity)++-- | Insert a bundle of components on an Entity.+--+-- Only the components that the entity doesn't already have will be inserted, and the rest ignored.+insertNew :: forall b. (Bundle b) => b -> Entity -> System ()+insertNew bundle entity =+  do+    world <- unsafeGetWorld+    pointer <- liftIO $ getPointer entity world.entities++    case pointer of+      Nothing -> warn $ "Insertion failed: Entity " <> text entity <> " is not alive."+      Just currentPointer -> do+        let BundleData {elements} = bundleData bundle++        currentTick <- liftIO $ readIORef world.tick++        bundleData <- liftIO $ processBundleElements world ComponentTicks {changed = currentTick, added = currentTick} elements++        (EntityPointer (# archetypeId, _ #)) <- liftIO $ readIORef currentPointer++        currentTable <- Vec.read world.tables.inner (I# archetypeId)++        let newComponents = ProcessedBundleData $ filter (\c -> c.id `notElem` currentTable.components) bundleData.elements++        unless (null newComponents.elements) $ do+          newArchetype <- getArchetypeOnInsert (ArchetypeId $ I# archetypeId) $ map (\x -> x.id) newComponents.elements+          ChangeResult {requiredComponentsAdded} <- changeArchetype entity newArchetype (Just bundleData)++          unless world.prefs.supressEvents $+            triggerInsertEvent (ProcessedBundleData requiredComponentsAdded) entity++          unless world.prefs.supressEvents $+            triggerInsertEvent newComponents entity++insertIfNeq :: (BundleEq b) => b -> Entity -> System ()+insertIfNeq b entity = do+  let BundleData {elements} = bundleDataEq b++  comps <- flip filterM (Set.toList elements) $ \BundleElement {rep, component = ErasedComponentEq (val :: c)} -> do+    val' <- case rep of+      PairRep (_, target) -> fmap (\x -> x.comp) <$> get (R @c target) entity+      _ -> fmap value <$> get (C @c) entity++    case val' of+      Nothing -> return True+      Just val' -> return (val /= val')++  insert (bundleEqToSimple $ BundleData (Set.fromList comps)) entity++class Settable c i | c -> i where+  setInner :: c -> i -> System ()++  setIfNeqInner :: (Eq i) => c -> i -> System ()++class Settable' isRel c i | isRel c -> i where+  setInner' :: c -> i -> System ()+  setIfNeqInner' :: (Eq i) => c -> i -> System ()++instance (Component c) => Settable' False (Result (Rel c)) c where+  setInner' :: Result (Rel c) -> c -> System ()+  setInner' !result !newValue = Mischief.ECS.World.Insert.insert (Rel newValue result.target) (entityOf result)++  setIfNeqInner' :: (Component c, Eq c) => Result (Rel c) -> c -> System ()+  setIfNeqInner' !result !newValue = do+    curr <- get (R @c result.target) (entityOf result)+    case curr of+      Nothing -> warn $ "SetIfNeq failed: Entity " <> text (entityOf result) <> " is not alive."+      Just curr ->+        when (curr.comp /= newValue) $+          setInner' @False result newValue++instance (Component c, IsComponentC c ~ HTrue) => Settable' True (Result c) c where+  setInner' :: Result c -> c -> System ()+  setInner' !result !newValue = Mischief.ECS.World.Insert.insert newValue (entityOf result)++  setIfNeqInner' :: (Component c, Eq c) => Result c -> c -> System ()+  setIfNeqInner' !result !newValue = do+    curr <- get (C @c) (entityOf result)+    case curr of+      Nothing -> warn $ "SetIfNeq failed: Entity " <> text (entityOf result) <> " is not alive."+      Just curr ->+        when (value curr /= newValue) $+          setInner' @True result newValue++instance (Settable' (IsComp c) (Result c) i) => Settable (Result c) i where+  setInner = setInner' @(IsComp c)+  setIfNeqInner = setIfNeqInner' @(IsComp c)++-- | Set the value of a component obtained as query result.+--+-- Note that the local 'Result' won't be mutated.+-- You'll need to query the component again or use 'update' to update the current result.+set :: (Settable c i) => c -> i -> System ()+set = setInner++setIfNeq :: (Eq i, Settable c i) => c -> i -> System ()+setIfNeq = setIfNeqInner++class Updateable' flag r where+  updateInner' :: r -> System (Maybe r)++instance (Component c, IsComponentC c ~ HTrue) => Updateable' True (Result c) where+  updateInner' r = get (C @c) (entityOf r)++instance (Component c) => Updateable' False (Result (Rel c)) where+  updateInner' r = get (R @c r.target) (entityOf r)++class Updateable r where+  updateInner :: r -> System (Maybe r)++instance (Updateable' (IsComp c) (Result c)) => Updateable (Result c) where+  updateInner = updateInner' @(IsComp c)++-- | Update the value of a 'Result'.+--+-- Useful if you've done changed to the component and want to grab the live value+-- without re-querying.+update :: forall c. (Updateable (Result c)) => Result c -> System (Maybe (Result c))+update = updateInner++triggerInsertEvent :: ProcessedBundleData -> Entity -> System ()+triggerInsertEvent bundle entity =+  for_ bundle.elements $ \x -> do+    let !(ComponentId (# id, target #)) = x.id+    case target of+      Nothing ->+        triggerInsertEventC x.component.value entity+      Just target ->+        triggerInsertEventR x.component.value target entity++triggerInsertEventC :: ErasedComponent -> Entity -> System ()+triggerInsertEventC (ErasedComponent (_ :: c)) entity =+  runEvent $ eraseEvent $ OnInsert @c entity++triggerInsertEventR :: ErasedComponent -> Entity -> Entity -> System ()+triggerInsertEventR (ErasedComponent (_ :: c)) target entity = do+  runEvent $ eraseEvent $ OnInsertRel @c entity target
+ src/Mischief/ECS/World/Modify.hs view
@@ -0,0 +1,70 @@+module Mischief.ECS.World.Modify where++import Data.Maybe+import Mischief.ECS.Components+import Mischief.ECS.Components.Bundle+import Mischief.ECS.Components.Common+import Mischief.ECS.Entities+import Mischief.ECS.Log+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.Queryable+import Mischief.ECS.World.Remove++-- | Modifies the value of the component with the given function.+--+-- The function will be applied over the @live value@ of the component, adding some overhead.+--+-- If you are confident the value in the 'Result' is the live one, or otherwise do not care of updating the live value,+-- you are encouraged to use 'modify'' instead.+--+-- Note that this will trigger change detection even if the provided function is 'id'.+modify :: forall c i. (Updateable (Result c), Settable (Result c) i, DeepValue (Result c) i) => Result c -> (i -> i) -> System ()+modify !result !f = do+  res <- update result+  case res of+    Nothing -> warn $ "Modify failed: Entity " <> text (entityOf result) <> " is not alive."+    Just res -> do+      let v = deepValue res+      set result (f v)++-- | Modifies the value of the component with the given function.+--+-- The function will be applied over the value contained within the 'Result', which is not guaranteed+-- to be the live value of the component.+--+-- If you wish to apply the function over the live value, use 'modify' instead.+--+-- Note that this will trigger change detection even if the provided function is 'id'.+modify' :: forall c i. (Settable (Result c) i, DeepValue (Result c) i) => Result c -> (i -> i) -> System ()+modify' !result !f = do+  let v = deepValue result+  set result (f v)++-- | The most generic function for modifying a component on a given entity.+--+-- This can do removals, insertions, and modify the value.+--+-- Example:+--+-- @+-- data Counter = Counter 'Int' deriving ('Component', 'Queryable')+--+-- incrementCounter :: 'Entity' -> 'System' ()+-- incrementCounter = 'alter' (\case 'Nothing' -> 'Just' $ Counter 0; 'Just' (Counter x) -> 'Just' $ Counter (x + 1))+-- @+alter :: forall c. (Queryable (C c) (Result c), Bundle c, Component c) => (Maybe c -> Maybe c) -> Entity -> System ()+alter !f !entity = do+  val <- get (C @c) entity+  let r = f (fmap value val)++  if isNothing r && isJust val+    then+      remove (C @c) entity+    else case r of+      Just r ->+        insert r entity+      Nothing -> return ()
+ src/Mischief/ECS/World/Par.hs view
@@ -0,0 +1,59 @@+module Mischief.ECS.World.Par where++import Control.Concurrent (forkIO)+import Control.Concurrent.Async (async, wait)+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Reader+import Data.Foldable+import Data.IORef (modifyIORef', newIORef, readIORef)+import Data.Traversable+import GHC.Conc (numCapabilities)+import Mischief.ECS.Hidden+import Mischief.ECS.World++par :: (MonadSystem w m) => [ParSystem ()] -> m ()+par !parSystems = do+  world <- unsafeGetWorld++  x <- forM parSystems $ \(ParSystem p) -> do+    systems <- liftIO $ newIORef []+    id <- liftIO $ async $ runReaderT p ParWorld {world = Hidden world, parDeferred = systems}+    return (id, systems)++  for_ x $ \(id, systems) -> do+    liftIO $ wait id+    systems <- liftIO $ readIORef systems+    liftIO $ modifyIORef' world.deferred (++ systems)++parIterList :: (MonadSystem w m, Foldable t) => t a -> ([a] -> ParSystem b) -> m [b]+parIterList !list !s = do+  world <- unsafeGetWorld++  let n = numCapabilities+  let len = length list++  let chunks = group (len `div` n) (toList list)++  x <- forM chunks $ \chunk -> do+    systems <- liftIO $ newIORef []+    let ParSystem p = s chunk+    id <- liftIO $ async $ runReaderT p ParWorld {world = Hidden world, parDeferred = systems}+    return (id, systems)++  for x $ \(id, systems) -> do+    a <- liftIO $ wait id+    systems <- liftIO $ readIORef systems+    liftIO $ modifyIORef' world.deferred (++ systems)+    return a++group :: Int -> [a] -> [[a]]+group _ [] = []+group 0 l = [l]+group !n !l = take n l : group n (drop n l)++parIter :: (MonadSystem w m, Foldable t) => t a -> (a -> ParSystem b) -> m [b]+parIter x s = concat <$> parIterList x (`for` s)++parIter_ :: (MonadSystem w m, Foldable t) => t a -> (a -> ParSystem b) -> m ()+parIter_ x s = void (parIterList x (`for_` s))
+ src/Mischief/ECS/World/Prefs.hs view
@@ -0,0 +1,14 @@+module Mischief.ECS.World.Prefs where++newtype WorldPrefs = WorldPrefs+  { supressEvents :: Bool+  }++newPrefs :: WorldPrefs+newPrefs =+  WorldPrefs+    { supressEvents = False+    }++supressEvents :: Bool -> WorldPrefs -> WorldPrefs+supressEvents b WorldPrefs {} = WorldPrefs {supressEvents = b}
+ src/Mischief/ECS/World/Query.hs view
@@ -0,0 +1,157 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++module Mischief.ECS.World.Query where++import Control.Monad+import Control.Monad.IO.Class+import Data.Data+import Data.Foldable+import Data.Foldable hiding (and)+import Data.IORef+import Data.Map qualified as Map+import Data.Maybe+import Data.Set qualified as Set+import GHC.Base (Int (..), eqWord#, isTrue#)+import Mischief.ECS.App.SystemDef+import Mischief.ECS.Archetypes.Graph+import Mischief.ECS.Collectable+import Mischief.ECS.Components+import Mischief.ECS.Components.BundleTypes+import Mischief.ECS.Components.Common+import Mischief.ECS.Entities+import Mischief.ECS.EntityDef+import Mischief.ECS.Log+import Mischief.ECS.Tables+import Mischief.ECS.Vec qualified as Vec+import Mischief.ECS.World+import Mischief.ECS.World.Query.Markers+import Mischief.ECS.World.Query.QueryFilter+import Mischief.ECS.World.Query.Queryable+import Mischief.ECS.World.Utils+import Prelude hiding (and)++runQuery :: forall qd m w output. (Queryable qd output, MonadSystem w m) => qd -> QueryFilter -> World -> m [output]+runQuery query filter world =+  do+    components <-+      liftIO $+        mapM+          ( \(c, t) -> do+              c <- getComponentId c world.components+              return $+                fmap+                  ( \c ->+                      case t of+                        CompQ -> (c, ComponentQuery)+                        RelQ -> (c, RelationshipQueryAny)+                        RelQ' entity -> (setCompIdTarget (Just entity) c, RelationshipQuery)+                  )+                  c+          )+          (Set.toList (queryTypes query))+    archetypes <- findMatchingArchetypes (catMaybes components) world.archetypes+    let (otherFilter, archetypeFilter) = extractArchetypeFilters $ preprocessFilter filter++    archetypes' <- filterM (\(components, _) -> liftIO $ (filterArchetype . preprocessFilter) archetypeFilter components world) archetypes++    outputs <- liftIO $ runQueryInternal query (map snd archetypes') world+    outputs' <- filterM (\(e, b, _) -> (&& b) <$> filterQuery (preprocessFilter otherFilter) e) outputs+    return $ map (\(_, _, o) -> o) outputs'++query :: forall qd output m w. (Queryable qd output, MonadSystem w m) => qd -> m [output]+query qd = do+  world <- unsafeGetWorld+  runQuery qd NoFilter world++entityQuery :: forall qd output m w. (Queryable qd output, MonadSystem w m) => qd -> Entity -> m (Maybe output)+entityQuery qd entity = do+  world <- unsafeGetWorld+  liftIO $ runQueryEntity qd world entity++get :: forall qd m w out. (Queryable qd out, MonadSystem w m) => qd -> Entity -> m (Maybe out)+get = entityQuery++get' :: forall qd m w out qf. (Queryable qd out, MonadSystem w m, Collectable qf QueryFilter) => qd -> qf -> Entity -> m (Maybe out)+get' qd qf entity = do+  b <- filterQuery (preprocessFilter $ collect qf) entity+  if b+    then+      entityQuery qd entity+    else+      pure Nothing++query' :: forall qd m w out qf. (Queryable qd out, MonadSystem w m, Collectable qf QueryFilter) => qd -> qf -> m [out]+query' qd filter = do+  world <- unsafeGetWorld+  runQuery qd (collect filter) world++single :: forall qd m w out. (Queryable qd out, MonadSystem w m) => qd -> m (Maybe out)+single qd = do+  res <- query qd+  case res of+    [x] -> return $ Just x+    _ -> return Nothing++single' :: forall qd m w out qf. (Queryable qd out, MonadSystem w m, Collectable qf QueryFilter) => qd -> qf -> m (Maybe out)+single' qd filter = do+  res <- query' qd filter+  case res of+    [x] -> return $ Just x+    _ -> return Nothing++-- iter :: forall qd m w. (Queryable qd, MonadSystem w m) => (QueryOutput qd -> m ()) -> m ()+-- iter system = do+--   res <- query @qd+--   for_ res system++-- iter' :: forall qd m w. (Queryable qd, MonadSystem w m) => QueryFilter -> (QueryOutput qd -> m ()) -> m ()+-- iter' filter system = do+--   res <- query' @qd filter+--   for_ res system++-- parIter :: forall qd m w. (Queryable qd, MonadSystem w m) => (QueryOutput qd -> ParSystem ()) -> m ()+-- parIter system = do+--   res <- query @qd+--   parIterList res $ \chunk -> for_ chunk system++class GetResultComponentId c where+  getResultComponentId :: (MonadSystem w m) => c -> m (Maybe ComponentId)++class GetResultComponentId' flag c where+  getResultComponentId' :: (MonadSystem w m) => c -> m (Maybe ComponentId)++instance (Component c) => GetResultComponentId' True (Result c) where+  getResultComponentId' _ = fmap (\(Entity (# id, _ #)) -> ComponentId (# id, Nothing #)) <$> tryMetaLocal @c++instance (Component c) => GetResultComponentId' False (Result (Rel c)) where+  getResultComponentId' r = fmap (\(Entity (# id, _ #)) -> ComponentId (# id, Just r.target #)) <$> tryMetaLocal @c++tryMetaLocal :: forall c m w. (Component c, MonadSystem w m) => m (Maybe Entity)+tryMetaLocal = do+  world <- unsafeGetWorld+  component <- liftIO $ getComponentId (typeRep $ Proxy @c) world.components+  return $ fmap (\(ComponentId (# id, _ #)) -> Entity (# id, 0## #)) component++instance (GetResultComponentId' (IsComp c) (Result c)) => GetResultComponentId (Result c) where+  getResultComponentId = getResultComponentId' @(IsComp c)++addedChanged :: forall c m w. (MonadSystem w m, GetResultComponentId (Result c)) => (ComponentTicks -> Tick -> Tick -> Bool) -> Result c -> m Bool+addedChanged f r = do+  id <- getResultComponentId r+  case id of+    Nothing -> return False+    Just id -> do+      world <- unsafeGetWorld+      ticks <- liftIO $ tryGetEntityTicks (entityOf r) id world+      case ticks of+        Nothing -> return False+        Just ticks -> do+          (lastSystemTick, currentSystemTick) <- liftIO $ getSystemTicksInternal world+          return $ f ticks lastSystemTick currentSystemTick++added :: forall c m w. (MonadSystem w m, GetResultComponentId (Result c)) => Result c -> m Bool+added = addedChanged qfAddedF++changed :: forall c m w. (MonadSystem w m, GetResultComponentId (Result c)) => Result c -> m Bool+changed = addedChanged qfChangedF
+ src/Mischief/ECS/World/Query/Markers.hs view
@@ -0,0 +1,273 @@+{-# OPTIONS_GHC -Wno-unused-imports #-}++module Mischief.ECS.World.Query.Markers where++import Mischief.ECS.Components+import Mischief.ECS.Tables++-- | Used to query for the [Entity]('Mischief.ECS.Entities.Entity').+--+-- __Example__+--+-- @+-- x <- query E+-- @+--+-- __Quasi Notation__+--+-- * @Entity@+-- * @entity@+-- * @E@+-- * @e@+--+-- For instance:+--+-- @+-- x <- [q|Entity|]+-- @+data E = E++-- | Used to query for a component or to remove a component. Forces queries to only include entities which have the component.+--+-- __Example__+--+-- Querying:+--+-- @+-- x <- query (C \@Name)+-- @+--+-- Removing:+--+-- @+-- remove (C \@Name)+-- @+--+-- __Quasi Notation__+--+-- None, you just write the component name directly. For instance:+--+-- @+-- x <- [q|Name|]+-- @+data C a = C++-- | Used to query for a component that an entity may or may not have.+--+-- __Example__+--+-- @+-- x <- query (M \@Name)+-- @+--+-- __Quasi Notation__+--+-- * @Maybe@+-- * @maybe@+-- * @M@+-- * @m@+--+-- For instance:+--+-- @+-- x <- [q|Maybe Name|]+-- @+data M a = M++-- | Used in queries to return a Bool which indicates whether a component exists on the entity or not.+--+-- __Example__+--+-- @+-- x <- query (Has \@Name)+-- @+--+-- __Quasi Notation__+--+-- * @Has@+-- * @has@+-- * @H@+-- * @h@+--+-- For instance:+--+-- @+-- x <- [q|Has Name|]+-- @+data Has a = Has++-- | Wildcard used when querying for relationships to indicate that you're querying for relationships with any target.+--+-- In the case of exclusive relationships, @Any@ returns a single relationship rather than a list of relationships.+data Any = Any++-- | Used to query for a relationships. Can be used in three different ways:+--+-- __1. @R c e@__+--+-- Queries for a relationship with a specific target. Forces queries to only include entities which have such a relationship.+--+-- __Example__+--+-- @+-- x <- query (R \@Likes alice)+-- @+--+-- @+-- x :: [Result (Rel Likes)]+-- @+--+-- __Quasi Notation__+--+-- It is written with an arrow like so:+--+-- @+-- x \<- [q|Likes -\> alice|]+-- @+--+-- __2. @R c Any@__+--+-- Queries for all relationships with any target. Forces queries to only include entities which have at least one such relationship.+--+-- __Example__+--+-- @+-- x <- query (R \@Likes Any)+-- @+--+-- @+-- x :: [[Result (Rel Likes)]]+-- @+--+-- __Quasi Notation__+--+-- @+-- x \<- [q|Likes -\> *|]+-- @+--+-- __3. @R c q@__+--+-- Runs a transitive query on the targets of all such relationships.+-- q can either be @Q d@ or @Q' d f@, depending if you want to also run a filter or not.+--+-- Similar to the previous case, it will limit the query to only entities which have such a relationship with at least one entity which matches the transitive query.+--+-- __Example__+--+-- @+-- x <- query (R @Likes (Q (C \@Name))+-- @+--+-- @+-- x <- query (R @Likes (Q' (C \@Name) (With (C \@Enemy))))+-- @+--+-- @+-- x :: [[Result Name]]+-- @+--+-- __Quasi Notation__+--+-- You just write the given query in the @()@ following the arrow. @\/@ can be used to give it a filter.+--+-- For instance:+--+-- @+-- x \<- [q|Likes -\> (Name)|]+-- @+--+-- @+-- x \<- [q|Likes -\> (Name / With Enemy)|]+-- @+newtype R a b = R b++-- | Exactly like 'R', except that it wraps the result in a Maybe, also including entities that don't have such a relationship.+--+-- __Example__+--+-- @+-- x <- query (MR @Likes Any)+-- @+--+-- __Quasi Notation__+--+-- * @Maybe@+-- * @maybe@+-- * @M@+-- * @m@+--+-- For instance:+--+-- @+-- x \<- [q|Maybe Likes -\> *|]+-- @+newtype MR a b = MR b++-- | Exactly like 'R', except that it returns a Bool depending on whether the entity has such a relationship or not.+--+-- __Example__+--+-- @+-- x <- query (HasR @Likes Any)+-- @+--+-- __Quasi Notation__+--+-- * @Has@+-- * @has@+-- * @H@+-- * @h@+--+-- For instance:+--+-- @+-- x \<- [q|Has Likes -\> *|]+-- @+newtype HasR a b = HasR b++-- | Used when writing transitive queries. See 'R'.+newtype Q a = Q a++-- | Used when writing transitive queries with filters. See 'R'.+data Q' a b = Q' a b++-- | Can be wrapped around any queryable marker to unwrap the inner value from the Results.+--+-- __Example__+--+-- @+-- x <- query (C \@Name, Val (C \@Name))+-- @+--+-- @+-- x :: [(Result Name, Name)]+-- @+--+-- @+-- y <- query (Val (C \@Name, R \@Likes Any))+-- @+--+-- @+-- y :: [(Name, [Rel Likes])]+-- @+--+-- __Quasi Notation__+--+-- * @Val@+-- * @val@+-- * @V@+-- * @v@+-- * @*@+--+-- For instance:+--+-- @+-- x <- [q|Name, *Name|]+-- @+--+-- @+-- x \<- [q|*(Name, Likes -\> *)|]+-- @+newtype Val a = Val a++newtype R' a b = R' b
+ src/Mischief/ECS/World/Query/QueryFilter.hs view
@@ -0,0 +1,244 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++module Mischief.ECS.World.Query.QueryFilter where++import Data.Data+import Data.Maybe+import Data.Set qualified as Set+import GHC.Base (eqWord#, isTrue#, (/=#))+import Mischief.ECS.Collectable+import Mischief.ECS.Components+import Mischief.ECS.Components.BundleTypes+import Mischief.ECS.Entities+import Mischief.ECS.EntityDef+import Mischief.ECS.World+import Mischief.ECS.World.Query.Markers++-- import Mischief.ECS.World.Query.Queryable++-- newtype QueryFilters = QueryFilters [QueryFilter] deriving newtype (Semigroup)++qfChangedF :: ComponentTicks -> Tick -> Tick -> Bool+qfChangedF ticks lastSystemTick currentSystemTick = ticks.changed >= lastSystemTick && ticks.changed < currentSystemTick++qfAddedF :: ComponentTicks -> Tick -> Tick -> Bool+qfAddedF ticks lastSystemTick currentSystemTick = ticks.added >= lastSystemTick && ticks.added < currentSystemTick++data QueryFilter+  = NoFilter+  | QFWith (TypeRep, Maybe Entity)+  | QFWithRelAny TypeRep+  | QFChanged (TypeRep, Maybe Entity) (ComponentTicks -> Tick -> Tick -> Bool)+  | QFChangedRelAny TypeRep (ComponentTicks -> Tick -> Tick -> Bool)+  | QFCheckRaw (TypeRep, Maybe Entity, ErasedCheck)+  | QFCheckRawRelAny (TypeRep, ErasedCheck)+  | QFNot QueryFilter+  | QFAnd QueryFilter QueryFilter+  | QFOr QueryFilter QueryFilter++instance Semigroup QueryFilter where+  (<>) :: QueryFilter -> QueryFilter -> QueryFilter+  (<>) = QFAnd++instance {-# OVERLAPPING #-} EraseIntoStorage QueryFilter QueryFilter where+  erase = id++instance (IntoQueryFilter q) => EraseIntoStorage q QueryFilter where+  erase = intoQueryFilter++data ErasedCheck where+  ErasedCheck :: (Component c) => (c -> Bool) -> ErasedCheck++instance Show ErasedCheck where+  show _ = "erased check"++and' :: [QueryFilter] -> QueryFilter+and' [x] = x+and' x = foldr QFAnd NoFilter x++filterArchetype :: QueryFilter -> [ComponentId] -> World -> IO Bool+filterArchetype NoFilter _ _ = return True+filterArchetype (QFWith (x, entity)) components world = do+  component <- fmap (setCompIdTarget entity) <$> getComponentId x world.components+  return $ case component of+    Nothing -> False+    Just component -> component `elem` components+filterArchetype (QFWithRelAny x) components world = do+  component <- getComponentId x world.components+  case component of+    Nothing -> pure False+    Just (ComponentId (# id, _ #)) -> do+      return $ any (\(ComponentId (# id', a #)) -> isJust a && isTrue# (eqWord# id' id)) components+filterArchetype (a `QFAnd` b) c w = do+  x <- filterArchetype a c w+  y <- filterArchetype b c w+  return $ x && y+filterArchetype (a `QFOr` b) c w = do+  x <- filterArchetype a c w+  y <- filterArchetype b c w+  return $ x || y+filterArchetype (QFNot a) c w = not <$> filterArchetype a c w+filterArchetype _ _ _ = pure True++-- | Extracts archetype-level filters from the bigger filter where possible, to be applied at the start of querying for better performance.+extractArchetypeFilters :: QueryFilter -> (QueryFilter, QueryFilter)+extractArchetypeFilters NoFilter = (NoFilter, NoFilter)+extractArchetypeFilters (QFWith x) = (NoFilter, QFWith x)+extractArchetypeFilters (QFWithRelAny x) = (NoFilter, QFWithRelAny x)+extractArchetypeFilters (QFChanged x f) = (QFChanged x f, NoFilter)+extractArchetypeFilters (QFChangedRelAny x f) = (QFChangedRelAny x f, NoFilter)+extractArchetypeFilters (QFCheckRaw x) = (QFCheckRaw x, NoFilter)+extractArchetypeFilters (QFCheckRawRelAny x) = (QFCheckRawRelAny x, NoFilter)+extractArchetypeFilters (a `QFAnd` b) = (filter1 `QFAnd` filter2, res1 `QFAnd` res2)+  where+    (filter1, res1) = extractArchetypeFilters a+    (filter2, res2) = extractArchetypeFilters b+extractArchetypeFilters (a `QFOr` b) =+  if isArchetypeFilter a && isArchetypeFilter b+    then+      (filter1 `QFOr` filter2, res1 `QFOr` res2)+    else+      (a `QFOr` b, NoFilter)+  where+    (filter1, res1) = extractArchetypeFilters a+    (filter2, res2) = extractArchetypeFilters b+extractArchetypeFilters (QFNot a) = (QFNot x, QFNot y)+  where+    (x, y) = extractArchetypeFilters a++isArchetypeFilter :: QueryFilter -> Bool+isArchetypeFilter NoFilter = True+isArchetypeFilter (QFChanged _ _) = False+isArchetypeFilter (QFChangedRelAny _ _) = False+isArchetypeFilter (QFWith _) = True+isArchetypeFilter (QFWithRelAny _) = True+isArchetypeFilter (a `QFAnd` b) = isArchetypeFilter a || isArchetypeFilter b+isArchetypeFilter (a `QFOr` b) = isArchetypeFilter a && isArchetypeFilter b+isArchetypeFilter (QFCheckRaw _) = False+isArchetypeFilter (QFCheckRawRelAny _) = False+isArchetypeFilter (QFNot a) = isArchetypeFilter a++preprocessFilter :: QueryFilter -> QueryFilter+preprocessFilter = propagateQFNot++propagateQFNot :: QueryFilter -> QueryFilter+propagateQFNot (QFNot NoFilter) = NoFilter+propagateQFNot (QFNot (QFNot a)) = propagateQFNot a+propagateQFNot (QFNot (a `QFAnd` b)) = propagateQFNot (QFNot a) `QFOr` propagateQFNot (QFNot b)+propagateQFNot (QFNot (a `QFOr` b)) = propagateQFNot (QFNot a) `QFAnd` propagateQFNot (QFNot b)+propagateQFNot (a `QFAnd` b) = propagateQFNot a `QFAnd` propagateQFNot b+propagateQFNot (a `QFOr` b) = propagateQFNot a `QFOr` propagateQFNot b+propagateQFNot x = x++class IntoQueryFilter qf where+  intoQueryFilter :: qf -> QueryFilter++newtype With c = With c++instance (Collectable c FilterType) => IntoQueryFilter (With c) where+  intoQueryFilter (With c) =+    let l :: FilterType = collect c+     in and' $ map withF l.inner++newtype Without c = Without c++instance (Collectable c FilterType) => IntoQueryFilter (Without c) where+  intoQueryFilter (Without c) =+    let l :: FilterType = collect c+     in and' $ map (QFNot . withF) l.inner++newtype Not c = Not c++instance (IntoQueryFilter q) => IntoQueryFilter (Not q) where+  intoQueryFilter (Not a) = QFNot $ intoQueryFilter a++data Or a b = Or a b++(|.) :: a -> b -> Or a b+(|.) = Or++data And a b = And a b++(&.) :: a -> b -> And a b+(&.) = And++infix 8 &.++infix 9 |.++instance (IntoQueryFilter a, IntoQueryFilter b) => IntoQueryFilter (a `Or` b) where+  intoQueryFilter (Or a b) = QFOr (intoQueryFilter a) (intoQueryFilter b)++instance (IntoQueryFilter a, IntoQueryFilter b) => IntoQueryFilter (a `And` b) where+  intoQueryFilter (And a b) = QFAnd (intoQueryFilter a) (intoQueryFilter b)++newtype Changed c = Changed c++instance (Collectable c FilterType) => IntoQueryFilter (Changed c) where+  intoQueryFilter (Changed c) =+    let l :: FilterType = collect c+     in and' $ map changedF l.inner++newtype Added c = Added c++instance (Collectable c FilterType) => IntoQueryFilter (Added c) where+  intoQueryFilter (Added c) =+    let l :: FilterType = collect c+     in and' $ map addedF l.inner++newtype Check c = Check (c -> Bool)++instance (Component c) => IntoQueryFilter (Check c) where+  intoQueryFilter (Check f) = checkF (typeRep $ Proxy @c, Nothing, Nothing, ErasedCheck f)++data CheckR e c = CheckR e (c -> Bool)++instance (Component c) => IntoQueryFilter (CheckR Entity c) where+  intoQueryFilter (CheckR e f) = checkF (typeRep $ Proxy @c, Just e, Nothing, ErasedCheck f)++instance (Component c) => IntoQueryFilter (CheckR Any c) where+  intoQueryFilter (CheckR _ f) = checkF (typeRep $ Proxy @c, Nothing, Just Any, ErasedCheck f)++withF :: (TypeRep, Maybe Entity, Maybe Any) -> QueryFilter+withF (c, e, Nothing) = QFWith (c, e)+withF (c, _, _) = QFWithRelAny c++addedF :: (TypeRep, Maybe Entity, Maybe Any) -> QueryFilter+addedF (c, e, Nothing) = QFWith (c, e) `QFAnd` QFChanged (c, e) qfAddedF+addedF (c, _, _) = QFWithRelAny c `QFAnd` QFChangedRelAny c qfAddedF++changedF :: (TypeRep, Maybe Entity, Maybe Any) -> QueryFilter+changedF (c, e, Nothing) = QFWith (c, e) `QFAnd` QFChanged (c, e) qfChangedF+changedF (c, _, _) = QFWithRelAny c `QFAnd` QFChangedRelAny c qfChangedF++checkF :: (TypeRep, Maybe Entity, Maybe Any, ErasedCheck) -> QueryFilter+checkF (c, e, Nothing, f) = QFWith (c, e) `QFAnd` QFCheckRaw (c, e, f)+checkF (c, _, _, f) = QFWithRelAny c `QFAnd` QFCheckRawRelAny (c, f)++newtype FilterType = FilterType {inner :: [(TypeRep, Maybe Entity, Maybe Any)]} deriving newtype (Semigroup)++instance (Component c) => EraseIntoStorage (C c) FilterType where+  erase _ = FilterType [(typeRep $ Proxy @c, Nothing, Nothing)]++instance (Component c) => EraseIntoStorage (R c Entity) FilterType where+  erase (R e) = FilterType [(typeRep $ Proxy @c, Just e, Nothing)]++instance (Component c) => EraseIntoStorage (R c Any) FilterType where+  erase _ = FilterType [(typeRep $ Proxy @c, Nothing, Just Any)]++newtype CheckFilterType = CheckFilterType {inner :: [(TypeRep, Maybe Entity, Maybe Any, ErasedCheck)]} deriving newtype (Semigroup)++instance (Component c) => EraseIntoStorage (C c, c -> Bool) CheckFilterType where+  erase (_, f) = CheckFilterType [(typeRep $ Proxy @c, Nothing, Nothing, ErasedCheck f)]++instance (Component c) => EraseIntoStorage (R c Entity, c -> Bool) CheckFilterType where+  erase :: (Component c) => (R c Entity, c -> Bool) -> CheckFilterType+  erase (R e, f) = CheckFilterType [(typeRep $ Proxy @c, Just e, Nothing, ErasedCheck f)]++instance (Component c) => EraseIntoStorage (R c Any, c -> Bool) CheckFilterType where+  erase :: (Component c) => (R c Any, c -> Bool) -> CheckFilterType+  erase (_, f) = CheckFilterType [(typeRep $ Proxy @c, Nothing, Just Any, ErasedCheck f)]++type family InnerC a where+  InnerC (C (Rel a)) = a+  InnerC (C a) = a
+ src/Mischief/ECS/World/Query/QueryType.hs view
@@ -0,0 +1,6 @@+module Mischief.ECS.World.Query.QueryType where++import Mischief.ECS.Components+import Mischief.ECS.Mappable++type QueryType a = (Mappable MapQueryVal a a, Mappable MapQueryValidity a a, Component a)
+ src/Mischief/ECS/World/Query/Queryable.hs view
@@ -0,0 +1,1073 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++module Mischief.ECS.World.Query.Queryable where++import Control.Applicative+import Control.Monad.IO.Class+import Data.Bifunctor qualified+import Data.Data+import Data.IORef+import Data.Maybe+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Traversable+import GHC.Base (Int (I#), eqWord#, isTrue#)+import Mischief.ECS.App.SystemDef+import Mischief.ECS.Collectable+import Mischief.ECS.Components+import Mischief.ECS.Entities+import Mischief.ECS.Mappable+import Mischief.ECS.Tables+import Mischief.ECS.Vec qualified as Vec+import Mischief.ECS.World+import Mischief.ECS.World.Query.Markers+import Mischief.ECS.World.Query.QueryFilter+import Mischief.ECS.World.Utils++data TypeQuery = CompQ | RelQ | RelQ' Entity deriving (Eq, Ord, Show)++data RelTarget = AnyTarget | RelTargets [Entities]++filterQueryIO :: QueryFilter -> World -> Entity -> IO Bool+filterQueryIO a w e = runSystem (filterQuery a e) w++class Queryable qd output | qd -> output where+  runQueryEntity :: qd -> World -> Entity -> IO (Maybe output)+  runQueryInternal :: qd -> [ArchetypeId] -> World -> IO [(Entity, Bool, output)]+  queryTypes :: qd -> Set (TypeRep, TypeQuery)++data HTrue++data HFalse++type family IsComponentC c where+  IsComponentC Entity = HFalse+  IsComponentC a = HTrue++instance {-# OVERLAPPABLE #-} (Component c) => Queryable (C c) (Result c) where+  runQueryEntity _ world entity = do+    result <- tryGetEntityComponent @c world entity+    return $ case result of+      Just (Just res) -> Just $ Result (res, entity)+      _ -> Nothing++  runQueryInternal _ archetypes world = map (\(a, b) -> (a, True, b)) <$> tryGetComponents @c world archetypes++  queryTypes _ = Set.singleton (typeRep (Proxy @c), CompQ)++instance Queryable E Entity where+  runQueryEntity _ _ entity = return $ Just entity++  runQueryInternal _ archetypes world = map (\x -> (x, True, x)) <$> tryGetEntities world archetypes++  queryTypes _ = Set.empty++class RelQuery (exclusive :: Exclusivity) qd output | qd exclusive -> output where+  relRunQueryEntity :: qd -> World -> Entity -> IO (Maybe output)+  relRunQueryInternal :: qd -> [ArchetypeId] -> World -> IO [(Entity, Bool, output)]+  relQueryTypes :: qd -> Set (TypeRep, TypeQuery)++instance (Component c) => RelQuery Inclusive (R c Any) [Result (Rel c)] where+  relRunQueryEntity _ world entity = do+    res <- tryGetEntityRelCollection @c world entity+    return $ case res of+      Just (Just x) -> Just x+      _ -> Nothing++  relRunQueryInternal _ archetypes world = map (\(a, b) -> (a, True, b)) <$> tryGetRelCollections @c world archetypes++  relQueryTypes _ = Set.singleton (typeRep $ Proxy @c, RelQ)++instance (Component c) => RelQuery Exclusive (R c Any) (Result (Rel c)) where+  relRunQueryEntity _ world entity = do+    res <- tryGetEntityRelCollection @c world entity+    return $ case res of+      Just (Just [x]) -> Just x+      _ -> Nothing++  relRunQueryInternal _ archetypes world = do+    rels <- tryGetRelCollections @c world archetypes+    return $ map (\(e, x : _) -> (e, True, x)) rels++  relQueryTypes _ = Set.singleton (typeRep $ Proxy @c, RelQ)++instance (Component c, Queryable q out) => RelQuery Inclusive (R c (Q q)) [out] where+  relRunQueryEntity (R (Q q)) world entity = do+    res <- relRunQueryEntity @Inclusive (R @c Any) world entity++    case fmap (traverse $ \r -> runQueryEntity q world r.target) res of+      Nothing -> pure Nothing+      Just x -> do+        x <- x+        pure $ case catMaybes x of+          [] -> Nothing+          x -> Just x++  relRunQueryInternal (R (Q q)) archetypes world = do+    res <- relRunQueryInternal @Inclusive (R @c Any) archetypes world+    for res $ \(e, b, rels) -> do+      a <- catMaybes <$> (traverse $ \r -> runQueryEntity q world r.target) rels++      pure $ case a of+        [] -> (e, False, undefined)+        x -> (e, b, x)++  relQueryTypes _ = Set.singleton (typeRep $ Proxy @c, RelQ)++instance (Component c, Queryable q out, Collectable f QueryFilter) => RelQuery Inclusive (R c (Q' q f)) [out] where+  relRunQueryEntity (R (Q' q f')) world entity = do+    let f :: QueryFilter = collect f'+    res <- relRunQueryEntity @Inclusive (R @c Any) world entity++    case fmap+      ( traverse $ \r -> do+          t <- filterQueryIO f world r.target+          if t+            then+              runQueryEntity q world r.target+            else pure Nothing+      )+      res of+      Nothing -> pure Nothing+      Just x -> do+        x <- x+        pure $ case catMaybes x of+          [] -> Nothing+          x -> Just x++  relRunQueryInternal (R (Q' q f')) archetypes world = do+    let f :: QueryFilter = collect f'+    res <- relRunQueryInternal @Inclusive (R @c Any) archetypes world+    for res $ \(e, b, rels) -> do+      a <-+        catMaybes+          <$> ( traverse $ \r -> do+                  t <- filterQueryIO f world r.target+                  if t+                    then+                      runQueryEntity q world r.target+                    else pure Nothing+              )+            rels++      pure $ case a of+        [] -> (e, False, undefined)+        x -> (e, b, x)++  relQueryTypes _ = Set.singleton (typeRep $ Proxy @c, RelQ)++instance (Component c, Queryable q out) => RelQuery Exclusive (R c (Q q)) out where+  relRunQueryEntity (R (Q q)) world entity = do+    res <- relRunQueryEntity @Exclusive (R @c Any) world entity++    case fmap (\r -> runQueryEntity q world r.target) res of+      Nothing -> pure Nothing+      Just x -> x+  relRunQueryInternal (R (Q q)) archetypes world = do+    res <- relRunQueryInternal @Exclusive (R @c Any) archetypes world+    for res $ \(e, b, rels) -> do+      r <- (\r -> runQueryEntity q world r.target) rels+      pure $ case r of+        Nothing -> (e, False, undefined)+        Just x -> (e, b, x)++  relQueryTypes _ = Set.singleton (typeRep $ Proxy @c, RelQ)++instance (Component c, Queryable q out, Collectable f QueryFilter) => RelQuery Exclusive (R c (Q' q f)) out where+  relRunQueryEntity (R (Q' q f')) world entity = do+    let f :: QueryFilter = collect f'+    res <- relRunQueryEntity @Exclusive (R @c Any) world entity++    case fmap+      ( \r -> do+          t <- filterQueryIO f world r.target+          if t+            then+              runQueryEntity q world r.target+            else pure Nothing+      )+      res of+      Nothing -> pure Nothing+      Just x -> x+  relRunQueryInternal (R (Q' q f')) archetypes world = do+    let f :: QueryFilter = collect f'+    res <- relRunQueryInternal @Exclusive (R @c Any) archetypes world+    for res $ \(e, b, rels) -> do+      r <-+        ( \r -> do+            t <- filterQueryIO f world r.target+            if t+              then+                runQueryEntity q world r.target+              else pure Nothing+        )+          rels+      pure $ case r of+        Nothing -> (e, False, undefined)+        Just x -> (e, b, x)++  relQueryTypes _ = Set.singleton (typeRep $ Proxy @c, RelQ)++instance (Component c) => Queryable (R c Entity) (Result (Rel c)) where+  runQueryEntity (R target) world entity = do+    res <- tryGetEntityRel @c target world entity+    return $ case res of+      Just (Just x) -> Just $ Result (Rel x target, entity)+      _ -> Nothing++  runQueryInternal (R target) archetypes world = map (\(a, b) -> (a, True, b)) <$> tryGetRels @c target world archetypes++  queryTypes (R target) = Set.singleton (typeRep $ Proxy @c, RelQ' target)++instance (RelQuery (RelExclusivity c) (R c Any) out) => Queryable (R c Any) out where+  runQueryEntity = relRunQueryEntity @(RelExclusivity c)++  runQueryInternal = relRunQueryInternal @(RelExclusivity c)++  queryTypes = relQueryTypes @(RelExclusivity c)++instance (RelQuery (RelExclusivity c) (R c (Q q)) out) => Queryable (R c (Q q)) out where+  runQueryEntity = relRunQueryEntity @(RelExclusivity c)++  runQueryInternal = relRunQueryInternal @(RelExclusivity c)++  queryTypes = relQueryTypes @(RelExclusivity c)++instance (RelQuery (RelExclusivity c) (R c (Q' q f)) out) => Queryable (R c (Q' q f)) out where+  runQueryEntity = relRunQueryEntity @(RelExclusivity c)++  runQueryInternal = relRunQueryInternal @(RelExclusivity c)++  queryTypes = relQueryTypes @(RelExclusivity c)++instance (RelQuery Inclusive (R c e) out) => Queryable (R' c e) out where+  runQueryEntity (R' e) = relRunQueryEntity @Inclusive (R @c e)+  runQueryInternal (R' e) = relRunQueryInternal @Inclusive (R @c e)+  queryTypes (R' e) = relQueryTypes @Inclusive (R @c e)++instance (Component c) => Queryable (M c) (Maybe (Result c)) where+  runQueryEntity _ world entity = do+    res <- tryGetEntityComponent @c world entity+    case res of+      Nothing -> return Nothing+      Just Nothing -> return $ Just Nothing+      Just (Just x) -> return $ Just $ Just $ Result (x, entity)++  runQueryInternal _ archetypes world = map (\(a, b) -> (a, True, b)) <$> tryGetComponentsMaybe @c world archetypes++  queryTypes _ = Set.empty++instance (Component c) => Queryable (MR c Entity) (Maybe (Result (Rel c))) where+  runQueryEntity (MR target) world entity = do+    res <- tryGetEntityRel @c target world entity+    return $ case res of+      Nothing -> Nothing+      Just Nothing -> Just Nothing+      Just (Just x) -> Just $ Just (Result (Rel x target, entity))++  runQueryInternal (MR target) archetypes world = map (\(a, b) -> (a, True, b)) <$> tryGetRelsMaybe @c target world archetypes+  queryTypes _ = Set.empty++instance (Component c) => RelQuery Inclusive (MR c Any) (Maybe [Result (Rel c)]) where+  relRunQueryEntity _ = tryGetEntityRelCollection @c++  relRunQueryInternal _ archetypes world = do+    x <- tryGetRelCollections @c world archetypes+    return $ flip map x $ \(e, x) ->+      case x of+        [] -> (e, True, Nothing)+        x -> (e, True, Just x)+  relQueryTypes _ = Set.empty++instance (Component c) => RelQuery Exclusive (MR c Any) (Maybe (Result (Rel c))) where+  relRunQueryEntity _ world entity = do+    res <- tryGetEntityRelCollection @c world entity+    pure $ case res of+      Just (Just [x]) -> Just (Just x)+      Just (Just _) -> undefined+      Just Nothing -> Just Nothing+      Nothing -> Nothing++  relRunQueryInternal _ archetypes world = do+    x <- tryGetRelCollections @c world archetypes+    return $ flip map x $ \(e, x) ->+      case x of+        [] -> (e, True, Nothing)+        [x] -> (e, True, Just x)+        _ -> undefined+  relQueryTypes _ = Set.empty++instance (Component c, Queryable q out) => RelQuery Inclusive (MR c (Q q)) (Maybe [out]) where+  relRunQueryEntity (MR (Q q)) world entity = do+    res <- relRunQueryEntity @Inclusive (MR @c Any) world entity+    case res of+      Nothing -> pure Nothing+      Just Nothing -> pure $ Just Nothing+      Just (Just r) ->+        Just <$> do+          let targets = map (\x -> x.target) r+          results <- catMaybes <$> for targets (runQueryEntity q world)+          case results of+            [] -> pure Nothing+            x -> pure $ Just x++  relRunQueryInternal (MR (Q q)) archetypes world = do+    res <- relRunQueryInternal @Inclusive (MR @c Any) archetypes world+    for res $ \(e, b, r) -> do+      case r of+        Nothing -> pure (e, b, Nothing)+        Just r -> do+          rs <- for r (\x -> runQueryEntity q world x.target)+          case catMaybes rs of+            [] -> pure (e, b, Nothing)+            x -> pure (e, b, Just x)++  relQueryTypes _ = Set.empty++instance (Component c, Queryable q out, Collectable f QueryFilter) => RelQuery Inclusive (MR c (Q' q f)) (Maybe [out]) where+  relRunQueryEntity (MR (Q' q f')) world entity = do+    let f :: QueryFilter = collect f'+    res <- relRunQueryEntity @Inclusive (MR @c Any) world entity+    case res of+      Nothing -> pure Nothing+      Just Nothing -> pure $ Just Nothing+      Just (Just r) ->+        Just <$> do+          let targets = map (\x -> x.target) r+          results <-+            catMaybes+              <$> for+                targets+                ( \t -> do+                    b <- filterQueryIO f world t+                    if b+                      then+                        runQueryEntity q world t+                      else+                        pure Nothing+                )+          case results of+            [] -> pure Nothing+            x -> pure $ Just x++  relRunQueryInternal (MR (Q' q f')) archetypes world = do+    let f :: QueryFilter = collect f'+    res <- relRunQueryInternal @Inclusive (MR @c Any) archetypes world+    for res $ \(e, b, r) -> do+      case r of+        Nothing -> pure (e, b, Nothing)+        Just r -> do+          rs <-+            for+              r+              ( \x -> do+                  t <- filterQueryIO f world x.target+                  if t+                    then+                      runQueryEntity q world x.target+                    else pure Nothing+              )+          case catMaybes rs of+            [] -> pure (e, b, Nothing)+            x -> pure (e, b, Just x)++  relQueryTypes _ = Set.empty++instance (Component c, Queryable q out) => RelQuery Exclusive (MR c (Q q)) (Maybe out) where+  relRunQueryEntity (MR (Q q)) world entity = do+    res <- relRunQueryEntity @Exclusive (MR @c Any) world entity+    case res of+      Nothing -> pure Nothing+      Just Nothing -> pure $ Just Nothing+      Just (Just x) -> Just <$> runQueryEntity q world x.target++  relRunQueryInternal (MR (Q q)) archetypes world = do+    res <- relRunQueryInternal @Exclusive (MR @c Any) archetypes world+    for res $ \(e, b, r) -> do+      case r of+        Nothing -> pure (e, b, Nothing)+        Just r -> do+          res <- runQueryEntity q world r.target+          pure (e, b, res)++  relQueryTypes _ = Set.empty++instance (Component c, Queryable q out, Collectable f QueryFilter) => RelQuery Exclusive (MR c (Q' q f)) (Maybe out) where+  relRunQueryEntity (MR (Q' q f')) world entity = do+    let f :: QueryFilter = collect f'+    res <- relRunQueryEntity @Exclusive (MR @c Any) world entity+    case res of+      Nothing -> pure Nothing+      Just Nothing -> pure $ Just Nothing+      Just (Just x) -> do+        t <- filterQueryIO f world x.target+        if t+          then+            Just <$> runQueryEntity q world x.target+          else pure (Just Nothing)++  relRunQueryInternal (MR (Q' q f')) archetypes world = do+    let f :: QueryFilter = collect f'+    res <- relRunQueryInternal @Exclusive (MR @c Any) archetypes world+    for res $ \(e, b, r) -> do+      case r of+        Nothing -> pure (e, b, Nothing)+        Just r -> do+          res <- do+            t <- filterQueryIO f world r.target+            if t+              then+                runQueryEntity q world r.target+              else pure Nothing+          pure (e, b, res)++  relQueryTypes _ = Set.empty++instance (RelQuery (RelExclusivity c) (MR c Any) out) => Queryable (MR c Any) out where+  runQueryEntity = relRunQueryEntity @(RelExclusivity c)++  runQueryInternal = relRunQueryInternal @(RelExclusivity c)+  queryTypes _ = Set.empty++instance (RelQuery (RelExclusivity c) (MR c (Q q)) out) => Queryable (MR c (Q q)) out where+  runQueryEntity = relRunQueryEntity @(RelExclusivity c)++  runQueryInternal = relRunQueryInternal @(RelExclusivity c)+  queryTypes _ = Set.empty++instance (RelQuery (RelExclusivity c) (MR c (Q' q f)) out) => Queryable (MR c (Q' q f)) out where+  runQueryEntity = relRunQueryEntity @(RelExclusivity c)++  runQueryInternal = relRunQueryInternal @(RelExclusivity c)+  queryTypes _ = Set.empty++instance (Component c) => Queryable (Has c) Bool where+  runQueryEntity _ world entity = do+    list <- runQueryEntity (M @c) world entity+    case list of+      Nothing -> return Nothing+      Just x -> return $ Just (isJust x)++  runQueryInternal _ archetypes world = do+    list <- runQueryInternal (M @c) archetypes world+    return $ map (Data.Bifunctor.second isJust) list++  queryTypes _ = Set.empty++instance (Component c) => Queryable (HasR c Any) Bool where+  runQueryEntity _ world entity = do+    res <- tryGetEntityRelCollection @c world entity+    return $ case res of+      Nothing -> Nothing+      Just Nothing -> Just False+      Just (Just _) -> Just True++  runQueryInternal _ archetypes world = do+    res <- tryGetRelCollections @c world archetypes+    return $ map ((\(a, b) -> (a, True, b)) . Data.Bifunctor.second null) res++  queryTypes _ = Set.empty++instance (Component c) => Queryable (HasR c Entity) Bool where+  runQueryEntity (HasR target) world entity = do+    res <- tryGetEntityRel @c target world entity+    return $ case res of+      Nothing -> Nothing+      Just Nothing -> Just False+      Just (Just _) -> Just True++  runQueryInternal (HasR target) archetypes world = do+    res <- runQueryInternal (MR @c target) archetypes world+    return $ map (Data.Bifunctor.second isNothing) res++  queryTypes _ = Set.empty++instance (Component c, Queryable q out) => Queryable (HasR c (Q q)) Bool where+  runQueryEntity (HasR (Q q)) world entity = do+    res <- tryGetEntityRelCollection @c world entity+    case res of+      Nothing -> pure Nothing+      Just Nothing -> pure $ Just False+      Just (Just r) -> do+        res <- catMaybes <$> for r (\r -> runQueryEntity q world r.target)+        case res of+          [] -> pure $ Just False+          _ -> pure $ Just True++  runQueryInternal (HasR (Q q)) archetypes world = do+    res <- relRunQueryInternal @Inclusive (MR @c Any) archetypes world+    for res $ \(e, b, r) -> do+      case r of+        Nothing -> pure (e, b, False)+        Just r -> do+          res <- catMaybes <$> for r (\r -> runQueryEntity q world r.target)+          case res of+            [] -> pure (e, b, False)+            _ -> pure (e, b, True)++  queryTypes _ = Set.empty++instance (Component c, Queryable q out, Collectable f QueryFilter) => Queryable (HasR c (Q' q f)) Bool where+  runQueryEntity (HasR (Q' q f')) world entity = do+    let f :: QueryFilter = collect f'+    res <- tryGetEntityRelCollection @c world entity+    case res of+      Nothing -> pure Nothing+      Just Nothing -> pure $ Just False+      Just (Just r) -> do+        res <-+          catMaybes+            <$> for+              r+              ( \r -> do+                  t <- filterQueryIO f world r.target+                  if t+                    then+                      runQueryEntity q world r.target+                    else pure Nothing+              )+        case res of+          [] -> pure $ Just False+          _ -> pure $ Just True++  runQueryInternal (HasR (Q' q f')) archetypes world = do+    let f :: QueryFilter = collect f'+    res <- relRunQueryInternal @Inclusive (MR @c Any) archetypes world+    for res $ \(e, b, r) -> do+      case r of+        Nothing -> pure (e, b, False)+        Just r -> do+          res <-+            catMaybes+              <$> for+                r+                ( \r -> do+                    t <- filterQueryIO f world r.target+                    if t+                      then+                        runQueryEntity q world r.target+                      else pure Nothing+                )+          case res of+            [] -> pure (e, b, False)+            _ -> pure (e, b, True)++  queryTypes _ = Set.empty++instance (Queryable qd out, Mappable MapQueryVal out out') => Queryable (Val qd) out' where+  runQueryEntity (Val qd) b c = do+    x <- runQueryEntity qd b c+    return $ fmap (mapTuple @MapQueryVal) x+  runQueryInternal (Val qd) b c = do+    x <- runQueryInternal qd b c+    return $ map (\(a, b, c) -> (a, b, mapTuple @MapQueryVal c)) x++  queryTypes (Val qd) = queryTypes qd++filterQuery :: (MonadSystem w m) => QueryFilter -> Entity -> m Bool+filterQuery NoFilter _ = pure True+filterQuery (QFWith (x, Nothing)) entity = do+  world <- unsafeGetWorld+  comp <- liftIO $ getComponentId x world.components+  case comp of+    Nothing -> return False+    Just (ComponentId (# id, _ #)) -> do+      Just (ComponentType (_ :: Proxy a)) <- liftIO $ runQueryEntity (Val (C @ComponentType)) world (Entity (# id, 0## #))+      a <- liftIO $ runQueryEntity (Has @a) world entity+      pure $ fromMaybe False a+filterQuery (QFWith (x, Just e)) entity = do+  world <- unsafeGetWorld+  comp <- liftIO $ getComponentId x world.components+  case comp of+    Nothing -> return False+    Just (ComponentId (# id, _ #)) -> do+      Just (ComponentType (_ :: Proxy a)) <- liftIO $ runQueryEntity (Val (C @ComponentType)) world (Entity (# id, 0## #))+      a <- liftIO $ runQueryEntity (HasR @a e) world entity+      pure $ fromMaybe False a+filterQuery (QFWithRelAny x) entity = do+  world <- unsafeGetWorld+  comp <- liftIO $ getComponentId x world.components+  case comp of+    Nothing -> return False+    Just (ComponentId (# id, _ #)) -> do+      Just (ComponentType (_ :: Proxy a)) <- liftIO $ runQueryEntity (Val (C @ComponentType)) world (Entity (# id, 0## #))+      a <- liftIO $ runQueryEntity (HasR @a Any) world entity+      pure $ fromMaybe False a+filterQuery (QFChanged (x, Nothing) f) entity = do+  world <- unsafeGetWorld+  comp <- liftIO $ getComponentId x world.components+  case comp of+    Nothing -> return False+    Just comp -> do+      addedChanged' f comp entity+filterQuery (QFChanged (x, Just e) f) entity = do+  world <- unsafeGetWorld+  comp <- liftIO $ getComponentId x world.components+  case comp of+    Nothing -> return False+    Just comp -> do+      addedChanged' f (setCompIdTarget (Just e) comp) entity+filterQuery (QFChangedRelAny x f) entity = do+  world <- unsafeGetWorld+  comp <- liftIO $ getComponentId x world.components+  case comp of+    Nothing -> return False+    Just (ComponentId (# id, _ #)) -> do+      components <- liftIO $ findComponentsOfEntity world entity+      case components of+        Nothing -> return True+        Just components' -> do+          let components = filter (\(ComponentId (# id', a #)) -> isJust a && isTrue# (eqWord# id id')) components'+          and <$> mapM (\c -> addedChanged' f c entity) components+filterQuery (QFCheckRaw (_, Nothing, ErasedCheck (f :: (c -> Bool)))) entity = do+  w <- unsafeGetWorld+  a <- liftIO $ runQueryEntity (C @c) w entity+  pure $ case a of+    Nothing -> False+    Just a -> f $ value a+filterQuery (QFCheckRaw (_, Just e, ErasedCheck (f :: (c -> Bool)))) entity = do+  world <- unsafeGetWorld+  a <- liftIO $ runQueryEntity (R @c e) world entity+  pure $ case a of+    Nothing -> False+    Just a -> f a.comp+filterQuery (QFCheckRawRelAny (_, ErasedCheck (f :: (c -> Bool)))) entity = do+  world <- unsafeGetWorld+  a <- liftIO $ runQueryEntity (R' @c Any) world entity+  pure $ case a of+    Nothing -> False+    Just a -> any (\x -> f x.comp) a+filterQuery (a `QFAnd` b) entity = do+  a <- filterQuery a entity+  b <- filterQuery b entity+  pure $ a && b+filterQuery (a `QFOr` b) entity = do+  a <- filterQuery a entity+  b <- filterQuery b entity+  pure $ a || b+filterQuery (QFNot a) entity = do+  a <- filterQuery a entity+  pure $ not a++findComponentsOfEntity :: World -> Entity -> IO (Maybe [ComponentId])+findComponentsOfEntity world entity = do+  pointer <- getPointer entity world.entities++  case pointer of+    Nothing -> return Nothing+    Just x -> do+      (EntityPointer (# archetypeId, _ #)) <- readIORef x++      x <- Vec.read world.tables.inner (I# archetypeId)++      pure $ Just x.components++addedChanged' :: forall m w. (MonadSystem w m) => (ComponentTicks -> Tick -> Tick -> Bool) -> ComponentId -> Entity -> m Bool+addedChanged' f id entity = do+  world <- unsafeGetWorld+  ticks <- liftIO $ tryGetEntityTicks entity id world+  case ticks of+    Nothing -> return False+    Just ticks -> do+      (lastSystemTick, currentSystemTick) <- liftIO $ getSystemTicksInternal world+      return $ f ticks lastSystemTick currentSystemTick++getSystemTicksInternal :: World -> IO (Tick, Tick)+getSystemTicksInternal world = do+  let (SystemId sys) = world.systemId+  Just a <- runQueryEntity (C @LastSystemTick) world sys+  Just b <- runQueryEntity (C @SystemTick) world sys+  return (a.inner, b.inner)++instance {-# OVERLAPPING #-} (Queryable q0 o0, Queryable q1 o1) => Queryable (q0, q1) (o0, o1) where+  runQueryEntity (q0, q1) world entity = do+    r0 <- runQueryEntity q0 world entity+    r1 <- runQueryEntity q1 world entity++    return $ (,) <$> r0 <*> r1++  runQueryInternal (q0, q1) archetypes world = do+    r0 <- runQueryInternal q0 archetypes world+    r1 <- runQueryInternal q1 archetypes world++    return $ map (\((e0, b0, r0), (_, b1, r1)) -> (e0, b0 || b1, (r0, r1))) $ getZipList $ (,) <$> ZipList r0 <*> ZipList r1++  queryTypes (q0, q1) = Set.unions [queryTypes q0, queryTypes q1]++instance {-# OVERLAPPING #-} (Queryable q0 o0, Queryable q1 o1, Queryable q2 o2) => Queryable (q0, q1, q2) (o0, o1, o2) where+  runQueryEntity (q0, q1, q2) world entity = do+    r0 <- runQueryEntity q0 world entity+    r1 <- runQueryEntity q1 world entity+    r2 <- runQueryEntity q2 world entity++    return $ (,,) <$> r0 <*> r1 <*> r2++  runQueryInternal (q0, q1, q2) archetypes world = do+    r0 <- runQueryInternal q0 archetypes world+    r1 <- runQueryInternal q1 archetypes world+    r2 <- runQueryInternal q2 archetypes world++    return $ map (\((e0, b0, r0), (_, b1, r1), (_, b2, r2)) -> (e0, b0 || b1 || b2, (r0, r1, r2))) $ getZipList $ (,,) <$> ZipList r0 <*> ZipList r1 <*> ZipList r2++  queryTypes (q0, q1, q2) = Set.unions [queryTypes q0, queryTypes q1, queryTypes q2]++instance {-# OVERLAPPING #-} (Queryable q0 o0, Queryable q1 o1, Queryable q2 o2, Queryable q3 o3) => Queryable (q0, q1, q2, q3) (o0, o1, o2, o3) where+  runQueryEntity (q0, q1, q2, q3) world entity = do+    r0 <- runQueryEntity q0 world entity+    r1 <- runQueryEntity q1 world entity+    r2 <- runQueryEntity q2 world entity+    r3 <- runQueryEntity q3 world entity++    return $ (,,,) <$> r0 <*> r1 <*> r2 <*> r3++  runQueryInternal (q0, q1, q2, q3) archetypes world = do+    r0 <- runQueryInternal q0 archetypes world+    r1 <- runQueryInternal q1 archetypes world+    r2 <- runQueryInternal q2 archetypes world+    r3 <- runQueryInternal q3 archetypes world++    return $ map (\((e0, b0, r0), (_, b1, r1), (_, b2, r2), (_, b3, r3)) -> (e0, b0 || b1 || b2 || b3, (r0, r1, r2, r3))) $ getZipList $ (,,,) <$> ZipList r0 <*> ZipList r1 <*> ZipList r2 <*> ZipList r3++  queryTypes (q0, q1, q2, q3) = Set.unions [queryTypes q0, queryTypes q1, queryTypes q2, queryTypes q3]++instance {-# OVERLAPPING #-} (Queryable q0 o0, Queryable q1 o1, Queryable q2 o2, Queryable q3 o3, Queryable q4 o4) => Queryable (q0, q1, q2, q3, q4) (o0, o1, o2, o3, o4) where+  runQueryEntity (q0, q1, q2, q3, q4) world entity = do+    r0 <- runQueryEntity q0 world entity+    r1 <- runQueryEntity q1 world entity+    r2 <- runQueryEntity q2 world entity+    r3 <- runQueryEntity q3 world entity+    r4 <- runQueryEntity q4 world entity++    return $ (,,,,) <$> r0 <*> r1 <*> r2 <*> r3 <*> r4++  runQueryInternal (q0, q1, q2, q3, q4) archetypes world = do+    r0 <- runQueryInternal q0 archetypes world+    r1 <- runQueryInternal q1 archetypes world+    r2 <- runQueryInternal q2 archetypes world+    r3 <- runQueryInternal q3 archetypes world+    r4 <- runQueryInternal q4 archetypes world++    return $ map (\((e0, b0, r0), (_, b1, r1), (_, b2, r2), (_, b3, r3), (_, b4, r4)) -> (e0, b0 || b1 || b2 || b3 || b4, (r0, r1, r2, r3, r4))) $ getZipList $ (,,,,) <$> ZipList r0 <*> ZipList r1 <*> ZipList r2 <*> ZipList r3 <*> ZipList r4++  queryTypes (q0, q1, q2, q3, q4) = Set.unions [queryTypes q0, queryTypes q1, queryTypes q2, queryTypes q3, queryTypes q4]++instance {-# OVERLAPPING #-} (Queryable q0 o0, Queryable q1 o1, Queryable q2 o2, Queryable q3 o3, Queryable q4 o4, Queryable q5 o5) => Queryable (q0, q1, q2, q3, q4, q5) (o0, o1, o2, o3, o4, o5) where+  runQueryEntity (q0, q1, q2, q3, q4, q5) world entity = do+    r0 <- runQueryEntity q0 world entity+    r1 <- runQueryEntity q1 world entity+    r2 <- runQueryEntity q2 world entity+    r3 <- runQueryEntity q3 world entity+    r4 <- runQueryEntity q4 world entity+    r5 <- runQueryEntity q5 world entity++    return $ (,,,,,) <$> r0 <*> r1 <*> r2 <*> r3 <*> r4 <*> r5++  runQueryInternal (q0, q1, q2, q3, q4, q5) archetypes world = do+    r0 <- runQueryInternal q0 archetypes world+    r1 <- runQueryInternal q1 archetypes world+    r2 <- runQueryInternal q2 archetypes world+    r3 <- runQueryInternal q3 archetypes world+    r4 <- runQueryInternal q4 archetypes world+    r5 <- runQueryInternal q5 archetypes world++    return $ map (\((e0, b0, r0), (_, b1, r1), (_, b2, r2), (_, b3, r3), (_, b4, r4), (_, b5, r5)) -> (e0, b0 || b1 || b2 || b3 || b4 || b5, (r0, r1, r2, r3, r4, r5))) $ getZipList $ (,,,,,) <$> ZipList r0 <*> ZipList r1 <*> ZipList r2 <*> ZipList r3 <*> ZipList r4 <*> ZipList r5++  queryTypes (q0, q1, q2, q3, q4, q5) = Set.unions [queryTypes q0, queryTypes q1, queryTypes q2, queryTypes q3, queryTypes q4, queryTypes q5]++instance {-# OVERLAPPING #-} (Queryable q0 o0, Queryable q1 o1, Queryable q2 o2, Queryable q3 o3, Queryable q4 o4, Queryable q5 o5, Queryable q6 o6) => Queryable (q0, q1, q2, q3, q4, q5, q6) (o0, o1, o2, o3, o4, o5, o6) where+  runQueryEntity (q0, q1, q2, q3, q4, q5, q6) world entity = do+    r0 <- runQueryEntity q0 world entity+    r1 <- runQueryEntity q1 world entity+    r2 <- runQueryEntity q2 world entity+    r3 <- runQueryEntity q3 world entity+    r4 <- runQueryEntity q4 world entity+    r5 <- runQueryEntity q5 world entity+    r6 <- runQueryEntity q6 world entity++    return $ (,,,,,,) <$> r0 <*> r1 <*> r2 <*> r3 <*> r4 <*> r5 <*> r6++  runQueryInternal (q0, q1, q2, q3, q4, q5, q6) archetypes world = do+    r0 <- runQueryInternal q0 archetypes world+    r1 <- runQueryInternal q1 archetypes world+    r2 <- runQueryInternal q2 archetypes world+    r3 <- runQueryInternal q3 archetypes world+    r4 <- runQueryInternal q4 archetypes world+    r5 <- runQueryInternal q5 archetypes world+    r6 <- runQueryInternal q6 archetypes world++    return $ map (\((e0, b0, r0), (_, b1, r1), (_, b2, r2), (_, b3, r3), (_, b4, r4), (_, b5, r5), (_, b6, r6)) -> (e0, b0 || b1 || b2 || b3 || b4 || b5 || b6, (r0, r1, r2, r3, r4, r5, r6))) $ getZipList $ (,,,,,,) <$> ZipList r0 <*> ZipList r1 <*> ZipList r2 <*> ZipList r3 <*> ZipList r4 <*> ZipList r5 <*> ZipList r6++  queryTypes (q0, q1, q2, q3, q4, q5, q6) = Set.unions [queryTypes q0, queryTypes q1, queryTypes q2, queryTypes q3, queryTypes q4, queryTypes q5, queryTypes q6]++instance {-# OVERLAPPING #-} (Queryable q0 o0, Queryable q1 o1, Queryable q2 o2, Queryable q3 o3, Queryable q4 o4, Queryable q5 o5, Queryable q6 o6, Queryable q7 o7) => Queryable (q0, q1, q2, q3, q4, q5, q6, q7) (o0, o1, o2, o3, o4, o5, o6, o7) where+  runQueryEntity (q0, q1, q2, q3, q4, q5, q6, q7) world entity = do+    r0 <- runQueryEntity q0 world entity+    r1 <- runQueryEntity q1 world entity+    r2 <- runQueryEntity q2 world entity+    r3 <- runQueryEntity q3 world entity+    r4 <- runQueryEntity q4 world entity+    r5 <- runQueryEntity q5 world entity+    r6 <- runQueryEntity q6 world entity+    r7 <- runQueryEntity q7 world entity++    return $ (,,,,,,,) <$> r0 <*> r1 <*> r2 <*> r3 <*> r4 <*> r5 <*> r6 <*> r7++  runQueryInternal (q0, q1, q2, q3, q4, q5, q6, q7) archetypes world = do+    r0 <- runQueryInternal q0 archetypes world+    r1 <- runQueryInternal q1 archetypes world+    r2 <- runQueryInternal q2 archetypes world+    r3 <- runQueryInternal q3 archetypes world+    r4 <- runQueryInternal q4 archetypes world+    r5 <- runQueryInternal q5 archetypes world+    r6 <- runQueryInternal q6 archetypes world+    r7 <- runQueryInternal q7 archetypes world++    return $ map (\((e0, b0, r0), (_, b1, r1), (_, b2, r2), (_, b3, r3), (_, b4, r4), (_, b5, r5), (_, b6, r6), (_, b7, r7)) -> (e0, b0 || b1 || b2 || b3 || b4 || b5 || b6 || b7, (r0, r1, r2, r3, r4, r5, r6, r7))) $ getZipList $ (,,,,,,,) <$> ZipList r0 <*> ZipList r1 <*> ZipList r2 <*> ZipList r3 <*> ZipList r4 <*> ZipList r5 <*> ZipList r6 <*> ZipList r7++  queryTypes (q0, q1, q2, q3, q4, q5, q6, q7) = Set.unions [queryTypes q0, queryTypes q1, queryTypes q2, queryTypes q3, queryTypes q4, queryTypes q5, queryTypes q6, queryTypes q7]++instance {-# OVERLAPPING #-} (Queryable q0 o0, Queryable q1 o1, Queryable q2 o2, Queryable q3 o3, Queryable q4 o4, Queryable q5 o5, Queryable q6 o6, Queryable q7 o7, Queryable q8 o8) => Queryable (q0, q1, q2, q3, q4, q5, q6, q7, q8) (o0, o1, o2, o3, o4, o5, o6, o7, o8) where+  runQueryEntity (q0, q1, q2, q3, q4, q5, q6, q7, q8) world entity = do+    r0 <- runQueryEntity q0 world entity+    r1 <- runQueryEntity q1 world entity+    r2 <- runQueryEntity q2 world entity+    r3 <- runQueryEntity q3 world entity+    r4 <- runQueryEntity q4 world entity+    r5 <- runQueryEntity q5 world entity+    r6 <- runQueryEntity q6 world entity+    r7 <- runQueryEntity q7 world entity+    r8 <- runQueryEntity q8 world entity++    return $ (,,,,,,,,) <$> r0 <*> r1 <*> r2 <*> r3 <*> r4 <*> r5 <*> r6 <*> r7 <*> r8++  runQueryInternal (q0, q1, q2, q3, q4, q5, q6, q7, q8) archetypes world = do+    r0 <- runQueryInternal q0 archetypes world+    r1 <- runQueryInternal q1 archetypes world+    r2 <- runQueryInternal q2 archetypes world+    r3 <- runQueryInternal q3 archetypes world+    r4 <- runQueryInternal q4 archetypes world+    r5 <- runQueryInternal q5 archetypes world+    r6 <- runQueryInternal q6 archetypes world+    r7 <- runQueryInternal q7 archetypes world+    r8 <- runQueryInternal q8 archetypes world++    return $ map (\((e0, b0, r0), (_, b1, r1), (_, b2, r2), (_, b3, r3), (_, b4, r4), (_, b5, r5), (_, b6, r6), (_, b7, r7), (_, b8, r8)) -> (e0, b0 || b1 || b2 || b3 || b4 || b5 || b6 || b7 || b8, (r0, r1, r2, r3, r4, r5, r6, r7, r8))) $ getZipList $ (,,,,,,,,) <$> ZipList r0 <*> ZipList r1 <*> ZipList r2 <*> ZipList r3 <*> ZipList r4 <*> ZipList r5 <*> ZipList r6 <*> ZipList r7 <*> ZipList r8++  queryTypes (q0, q1, q2, q3, q4, q5, q6, q7, q8) = Set.unions [queryTypes q0, queryTypes q1, queryTypes q2, queryTypes q3, queryTypes q4, queryTypes q5, queryTypes q6, queryTypes q7, queryTypes q8]++instance {-# OVERLAPPING #-} (Queryable q0 o0, Queryable q1 o1, Queryable q2 o2, Queryable q3 o3, Queryable q4 o4, Queryable q5 o5, Queryable q6 o6, Queryable q7 o7, Queryable q8 o8, Queryable q9 o9) => Queryable (q0, q1, q2, q3, q4, q5, q6, q7, q8, q9) (o0, o1, o2, o3, o4, o5, o6, o7, o8, o9) where+  runQueryEntity (q0, q1, q2, q3, q4, q5, q6, q7, q8, q9) world entity = do+    r0 <- runQueryEntity q0 world entity+    r1 <- runQueryEntity q1 world entity+    r2 <- runQueryEntity q2 world entity+    r3 <- runQueryEntity q3 world entity+    r4 <- runQueryEntity q4 world entity+    r5 <- runQueryEntity q5 world entity+    r6 <- runQueryEntity q6 world entity+    r7 <- runQueryEntity q7 world entity+    r8 <- runQueryEntity q8 world entity+    r9 <- runQueryEntity q9 world entity++    return $ (,,,,,,,,,) <$> r0 <*> r1 <*> r2 <*> r3 <*> r4 <*> r5 <*> r6 <*> r7 <*> r8 <*> r9++  runQueryInternal (q0, q1, q2, q3, q4, q5, q6, q7, q8, q9) archetypes world = do+    r0 <- runQueryInternal q0 archetypes world+    r1 <- runQueryInternal q1 archetypes world+    r2 <- runQueryInternal q2 archetypes world+    r3 <- runQueryInternal q3 archetypes world+    r4 <- runQueryInternal q4 archetypes world+    r5 <- runQueryInternal q5 archetypes world+    r6 <- runQueryInternal q6 archetypes world+    r7 <- runQueryInternal q7 archetypes world+    r8 <- runQueryInternal q8 archetypes world+    r9 <- runQueryInternal q9 archetypes world++    return $ map (\((e0, b0, r0), (_, b1, r1), (_, b2, r2), (_, b3, r3), (_, b4, r4), (_, b5, r5), (_, b6, r6), (_, b7, r7), (_, b8, r8), (_, b9, r9)) -> (e0, b0 || b1 || b2 || b3 || b4 || b5 || b6 || b7 || b8 || b9, (r0, r1, r2, r3, r4, r5, r6, r7, r8, r9))) $ getZipList $ (,,,,,,,,,) <$> ZipList r0 <*> ZipList r1 <*> ZipList r2 <*> ZipList r3 <*> ZipList r4 <*> ZipList r5 <*> ZipList r6 <*> ZipList r7 <*> ZipList r8 <*> ZipList r9++  queryTypes (q0, q1, q2, q3, q4, q5, q6, q7, q8, q9) = Set.unions [queryTypes q0, queryTypes q1, queryTypes q2, queryTypes q3, queryTypes q4, queryTypes q5, queryTypes q6, queryTypes q7, queryTypes q8, queryTypes q9]++instance {-# OVERLAPPING #-} (Queryable q0 o0, Queryable q1 o1, Queryable q2 o2, Queryable q3 o3, Queryable q4 o4, Queryable q5 o5, Queryable q6 o6, Queryable q7 o7, Queryable q8 o8, Queryable q9 o9, Queryable q10 o10) => Queryable (q0, q1, q2, q3, q4, q5, q6, q7, q8, q9, q10) (o0, o1, o2, o3, o4, o5, o6, o7, o8, o9, o10) where+  runQueryEntity (q0, q1, q2, q3, q4, q5, q6, q7, q8, q9, q10) world entity = do+    r0 <- runQueryEntity q0 world entity+    r1 <- runQueryEntity q1 world entity+    r2 <- runQueryEntity q2 world entity+    r3 <- runQueryEntity q3 world entity+    r4 <- runQueryEntity q4 world entity+    r5 <- runQueryEntity q5 world entity+    r6 <- runQueryEntity q6 world entity+    r7 <- runQueryEntity q7 world entity+    r8 <- runQueryEntity q8 world entity+    r9 <- runQueryEntity q9 world entity+    r10 <- runQueryEntity q10 world entity++    return $ (,,,,,,,,,,) <$> r0 <*> r1 <*> r2 <*> r3 <*> r4 <*> r5 <*> r6 <*> r7 <*> r8 <*> r9 <*> r10++  runQueryInternal (q0, q1, q2, q3, q4, q5, q6, q7, q8, q9, q10) archetypes world = do+    r0 <- runQueryInternal q0 archetypes world+    r1 <- runQueryInternal q1 archetypes world+    r2 <- runQueryInternal q2 archetypes world+    r3 <- runQueryInternal q3 archetypes world+    r4 <- runQueryInternal q4 archetypes world+    r5 <- runQueryInternal q5 archetypes world+    r6 <- runQueryInternal q6 archetypes world+    r7 <- runQueryInternal q7 archetypes world+    r8 <- runQueryInternal q8 archetypes world+    r9 <- runQueryInternal q9 archetypes world+    r10 <- runQueryInternal q10 archetypes world++    return $ map (\((e0, b0, r0), (_, b1, r1), (_, b2, r2), (_, b3, r3), (_, b4, r4), (_, b5, r5), (_, b6, r6), (_, b7, r7), (_, b8, r8), (_, b9, r9), (_, b10, r10)) -> (e0, b0 || b1 || b2 || b3 || b4 || b5 || b6 || b7 || b8 || b9 || b10, (r0, r1, r2, r3, r4, r5, r6, r7, r8, r9, r10))) $ getZipList $ (,,,,,,,,,,) <$> ZipList r0 <*> ZipList r1 <*> ZipList r2 <*> ZipList r3 <*> ZipList r4 <*> ZipList r5 <*> ZipList r6 <*> ZipList r7 <*> ZipList r8 <*> ZipList r9 <*> ZipList r10++  queryTypes (q0, q1, q2, q3, q4, q5, q6, q7, q8, q9, q10) = Set.unions [queryTypes q0, queryTypes q1, queryTypes q2, queryTypes q3, queryTypes q4, queryTypes q5, queryTypes q6, queryTypes q7, queryTypes q8, queryTypes q9, queryTypes q10]++instance {-# OVERLAPPING #-} (Queryable q0 o0, Queryable q1 o1, Queryable q2 o2, Queryable q3 o3, Queryable q4 o4, Queryable q5 o5, Queryable q6 o6, Queryable q7 o7, Queryable q8 o8, Queryable q9 o9, Queryable q10 o10, Queryable q11 o11) => Queryable (q0, q1, q2, q3, q4, q5, q6, q7, q8, q9, q10, q11) (o0, o1, o2, o3, o4, o5, o6, o7, o8, o9, o10, o11) where+  runQueryEntity (q0, q1, q2, q3, q4, q5, q6, q7, q8, q9, q10, q11) world entity = do+    r0 <- runQueryEntity q0 world entity+    r1 <- runQueryEntity q1 world entity+    r2 <- runQueryEntity q2 world entity+    r3 <- runQueryEntity q3 world entity+    r4 <- runQueryEntity q4 world entity+    r5 <- runQueryEntity q5 world entity+    r6 <- runQueryEntity q6 world entity+    r7 <- runQueryEntity q7 world entity+    r8 <- runQueryEntity q8 world entity+    r9 <- runQueryEntity q9 world entity+    r10 <- runQueryEntity q10 world entity+    r11 <- runQueryEntity q11 world entity++    return $ (,,,,,,,,,,,) <$> r0 <*> r1 <*> r2 <*> r3 <*> r4 <*> r5 <*> r6 <*> r7 <*> r8 <*> r9 <*> r10 <*> r11++  runQueryInternal (q0, q1, q2, q3, q4, q5, q6, q7, q8, q9, q10, q11) archetypes world = do+    r0 <- runQueryInternal q0 archetypes world+    r1 <- runQueryInternal q1 archetypes world+    r2 <- runQueryInternal q2 archetypes world+    r3 <- runQueryInternal q3 archetypes world+    r4 <- runQueryInternal q4 archetypes world+    r5 <- runQueryInternal q5 archetypes world+    r6 <- runQueryInternal q6 archetypes world+    r7 <- runQueryInternal q7 archetypes world+    r8 <- runQueryInternal q8 archetypes world+    r9 <- runQueryInternal q9 archetypes world+    r10 <- runQueryInternal q10 archetypes world+    r11 <- runQueryInternal q11 archetypes world++    return $ map (\((e0, b0, r0), (_, b1, r1), (_, b2, r2), (_, b3, r3), (_, b4, r4), (_, b5, r5), (_, b6, r6), (_, b7, r7), (_, b8, r8), (_, b9, r9), (_, b10, r10), (_, b11, r11)) -> (e0, b0 || b1 || b2 || b3 || b4 || b5 || b6 || b7 || b8 || b9 || b10 || b11, (r0, r1, r2, r3, r4, r5, r6, r7, r8, r9, r10, r11))) $ getZipList $ (,,,,,,,,,,,) <$> ZipList r0 <*> ZipList r1 <*> ZipList r2 <*> ZipList r3 <*> ZipList r4 <*> ZipList r5 <*> ZipList r6 <*> ZipList r7 <*> ZipList r8 <*> ZipList r9 <*> ZipList r10 <*> ZipList r11++  queryTypes (q0, q1, q2, q3, q4, q5, q6, q7, q8, q9, q10, q11) = Set.unions [queryTypes q0, queryTypes q1, queryTypes q2, queryTypes q3, queryTypes q4, queryTypes q5, queryTypes q6, queryTypes q7, queryTypes q8, queryTypes q9, queryTypes q10, queryTypes q11]++instance {-# OVERLAPPING #-} (Queryable q0 o0, Queryable q1 o1, Queryable q2 o2, Queryable q3 o3, Queryable q4 o4, Queryable q5 o5, Queryable q6 o6, Queryable q7 o7, Queryable q8 o8, Queryable q9 o9, Queryable q10 o10, Queryable q11 o11, Queryable q12 o12) => Queryable (q0, q1, q2, q3, q4, q5, q6, q7, q8, q9, q10, q11, q12) (o0, o1, o2, o3, o4, o5, o6, o7, o8, o9, o10, o11, o12) where+  runQueryEntity (q0, q1, q2, q3, q4, q5, q6, q7, q8, q9, q10, q11, q12) world entity = do+    r0 <- runQueryEntity q0 world entity+    r1 <- runQueryEntity q1 world entity+    r2 <- runQueryEntity q2 world entity+    r3 <- runQueryEntity q3 world entity+    r4 <- runQueryEntity q4 world entity+    r5 <- runQueryEntity q5 world entity+    r6 <- runQueryEntity q6 world entity+    r7 <- runQueryEntity q7 world entity+    r8 <- runQueryEntity q8 world entity+    r9 <- runQueryEntity q9 world entity+    r10 <- runQueryEntity q10 world entity+    r11 <- runQueryEntity q11 world entity+    r12 <- runQueryEntity q12 world entity++    return $ (,,,,,,,,,,,,) <$> r0 <*> r1 <*> r2 <*> r3 <*> r4 <*> r5 <*> r6 <*> r7 <*> r8 <*> r9 <*> r10 <*> r11 <*> r12++  runQueryInternal (q0, q1, q2, q3, q4, q5, q6, q7, q8, q9, q10, q11, q12) archetypes world = do+    r0 <- runQueryInternal q0 archetypes world+    r1 <- runQueryInternal q1 archetypes world+    r2 <- runQueryInternal q2 archetypes world+    r3 <- runQueryInternal q3 archetypes world+    r4 <- runQueryInternal q4 archetypes world+    r5 <- runQueryInternal q5 archetypes world+    r6 <- runQueryInternal q6 archetypes world+    r7 <- runQueryInternal q7 archetypes world+    r8 <- runQueryInternal q8 archetypes world+    r9 <- runQueryInternal q9 archetypes world+    r10 <- runQueryInternal q10 archetypes world+    r11 <- runQueryInternal q11 archetypes world+    r12 <- runQueryInternal q12 archetypes world++    return $ map (\((e0, b0, r0), (_, b1, r1), (_, b2, r2), (_, b3, r3), (_, b4, r4), (_, b5, r5), (_, b6, r6), (_, b7, r7), (_, b8, r8), (_, b9, r9), (_, b10, r10), (_, b11, r11), (_, b12, r12)) -> (e0, b0 || b1 || b2 || b3 || b4 || b5 || b6 || b7 || b8 || b9 || b10 || b11 || b12, (r0, r1, r2, r3, r4, r5, r6, r7, r8, r9, r10, r11, r12))) $ getZipList $ (,,,,,,,,,,,,) <$> ZipList r0 <*> ZipList r1 <*> ZipList r2 <*> ZipList r3 <*> ZipList r4 <*> ZipList r5 <*> ZipList r6 <*> ZipList r7 <*> ZipList r8 <*> ZipList r9 <*> ZipList r10 <*> ZipList r11 <*> ZipList r12++  queryTypes (q0, q1, q2, q3, q4, q5, q6, q7, q8, q9, q10, q11, q12) = Set.unions [queryTypes q0, queryTypes q1, queryTypes q2, queryTypes q3, queryTypes q4, queryTypes q5, queryTypes q6, queryTypes q7, queryTypes q8, queryTypes q9, queryTypes q10, queryTypes q11, queryTypes q12]++instance {-# OVERLAPPING #-} (Queryable q0 o0, Queryable q1 o1, Queryable q2 o2, Queryable q3 o3, Queryable q4 o4, Queryable q5 o5, Queryable q6 o6, Queryable q7 o7, Queryable q8 o8, Queryable q9 o9, Queryable q10 o10, Queryable q11 o11, Queryable q12 o12, Queryable q13 o13) => Queryable (q0, q1, q2, q3, q4, q5, q6, q7, q8, q9, q10, q11, q12, q13) (o0, o1, o2, o3, o4, o5, o6, o7, o8, o9, o10, o11, o12, o13) where+  runQueryEntity (q0, q1, q2, q3, q4, q5, q6, q7, q8, q9, q10, q11, q12, q13) world entity = do+    r0 <- runQueryEntity q0 world entity+    r1 <- runQueryEntity q1 world entity+    r2 <- runQueryEntity q2 world entity+    r3 <- runQueryEntity q3 world entity+    r4 <- runQueryEntity q4 world entity+    r5 <- runQueryEntity q5 world entity+    r6 <- runQueryEntity q6 world entity+    r7 <- runQueryEntity q7 world entity+    r8 <- runQueryEntity q8 world entity+    r9 <- runQueryEntity q9 world entity+    r10 <- runQueryEntity q10 world entity+    r11 <- runQueryEntity q11 world entity+    r12 <- runQueryEntity q12 world entity+    r13 <- runQueryEntity q13 world entity++    return $ (,,,,,,,,,,,,,) <$> r0 <*> r1 <*> r2 <*> r3 <*> r4 <*> r5 <*> r6 <*> r7 <*> r8 <*> r9 <*> r10 <*> r11 <*> r12 <*> r13++  runQueryInternal (q0, q1, q2, q3, q4, q5, q6, q7, q8, q9, q10, q11, q12, q13) archetypes world = do+    r0 <- runQueryInternal q0 archetypes world+    r1 <- runQueryInternal q1 archetypes world+    r2 <- runQueryInternal q2 archetypes world+    r3 <- runQueryInternal q3 archetypes world+    r4 <- runQueryInternal q4 archetypes world+    r5 <- runQueryInternal q5 archetypes world+    r6 <- runQueryInternal q6 archetypes world+    r7 <- runQueryInternal q7 archetypes world+    r8 <- runQueryInternal q8 archetypes world+    r9 <- runQueryInternal q9 archetypes world+    r10 <- runQueryInternal q10 archetypes world+    r11 <- runQueryInternal q11 archetypes world+    r12 <- runQueryInternal q12 archetypes world+    r13 <- runQueryInternal q13 archetypes world++    return $ map (\((e0, b0, r0), (_, b1, r1), (_, b2, r2), (_, b3, r3), (_, b4, r4), (_, b5, r5), (_, b6, r6), (_, b7, r7), (_, b8, r8), (_, b9, r9), (_, b10, r10), (_, b11, r11), (_, b12, r12), (_, b13, r13)) -> (e0, b0 || b1 || b2 || b3 || b4 || b5 || b6 || b7 || b8 || b9 || b10 || b11 || b12 || b13, (r0, r1, r2, r3, r4, r5, r6, r7, r8, r9, r10, r11, r12, r13))) $ getZipList $ (,,,,,,,,,,,,,) <$> ZipList r0 <*> ZipList r1 <*> ZipList r2 <*> ZipList r3 <*> ZipList r4 <*> ZipList r5 <*> ZipList r6 <*> ZipList r7 <*> ZipList r8 <*> ZipList r9 <*> ZipList r10 <*> ZipList r11 <*> ZipList r12 <*> ZipList r13++  queryTypes (q0, q1, q2, q3, q4, q5, q6, q7, q8, q9, q10, q11, q12, q13) = Set.unions [queryTypes q0, queryTypes q1, queryTypes q2, queryTypes q3, queryTypes q4, queryTypes q5, queryTypes q6, queryTypes q7, queryTypes q8, queryTypes q9, queryTypes q10, queryTypes q11, queryTypes q12, queryTypes q13]++instance {-# OVERLAPPING #-} (Queryable q0 o0, Queryable q1 o1, Queryable q2 o2, Queryable q3 o3, Queryable q4 o4, Queryable q5 o5, Queryable q6 o6, Queryable q7 o7, Queryable q8 o8, Queryable q9 o9, Queryable q10 o10, Queryable q11 o11, Queryable q12 o12, Queryable q13 o13, Queryable q14 o14) => Queryable (q0, q1, q2, q3, q4, q5, q6, q7, q8, q9, q10, q11, q12, q13, q14) (o0, o1, o2, o3, o4, o5, o6, o7, o8, o9, o10, o11, o12, o13, o14) where+  runQueryEntity (q0, q1, q2, q3, q4, q5, q6, q7, q8, q9, q10, q11, q12, q13, q14) world entity = do+    r0 <- runQueryEntity q0 world entity+    r1 <- runQueryEntity q1 world entity+    r2 <- runQueryEntity q2 world entity+    r3 <- runQueryEntity q3 world entity+    r4 <- runQueryEntity q4 world entity+    r5 <- runQueryEntity q5 world entity+    r6 <- runQueryEntity q6 world entity+    r7 <- runQueryEntity q7 world entity+    r8 <- runQueryEntity q8 world entity+    r9 <- runQueryEntity q9 world entity+    r10 <- runQueryEntity q10 world entity+    r11 <- runQueryEntity q11 world entity+    r12 <- runQueryEntity q12 world entity+    r13 <- runQueryEntity q13 world entity+    r14 <- runQueryEntity q14 world entity++    return $ (,,,,,,,,,,,,,,) <$> r0 <*> r1 <*> r2 <*> r3 <*> r4 <*> r5 <*> r6 <*> r7 <*> r8 <*> r9 <*> r10 <*> r11 <*> r12 <*> r13 <*> r14++  runQueryInternal (q0, q1, q2, q3, q4, q5, q6, q7, q8, q9, q10, q11, q12, q13, q14) archetypes world = do+    r0 <- runQueryInternal q0 archetypes world+    r1 <- runQueryInternal q1 archetypes world+    r2 <- runQueryInternal q2 archetypes world+    r3 <- runQueryInternal q3 archetypes world+    r4 <- runQueryInternal q4 archetypes world+    r5 <- runQueryInternal q5 archetypes world+    r6 <- runQueryInternal q6 archetypes world+    r7 <- runQueryInternal q7 archetypes world+    r8 <- runQueryInternal q8 archetypes world+    r9 <- runQueryInternal q9 archetypes world+    r10 <- runQueryInternal q10 archetypes world+    r11 <- runQueryInternal q11 archetypes world+    r12 <- runQueryInternal q12 archetypes world+    r13 <- runQueryInternal q13 archetypes world+    r14 <- runQueryInternal q14 archetypes world++    return $ map (\((e0, b0, r0), (_, b1, r1), (_, b2, r2), (_, b3, r3), (_, b4, r4), (_, b5, r5), (_, b6, r6), (_, b7, r7), (_, b8, r8), (_, b9, r9), (_, b10, r10), (_, b11, r11), (_, b12, r12), (_, b13, r13), (_, b14, r14)) -> (e0, b0 || b1 || b2 || b3 || b4 || b5 || b6 || b7 || b8 || b9 || b10 || b11 || b12 || b13 || b14, (r0, r1, r2, r3, r4, r5, r6, r7, r8, r9, r10, r11, r12, r13, r14))) $ getZipList $ (,,,,,,,,,,,,,,) <$> ZipList r0 <*> ZipList r1 <*> ZipList r2 <*> ZipList r3 <*> ZipList r4 <*> ZipList r5 <*> ZipList r6 <*> ZipList r7 <*> ZipList r8 <*> ZipList r9 <*> ZipList r10 <*> ZipList r11 <*> ZipList r12 <*> ZipList r13 <*> ZipList r14++  queryTypes (q0, q1, q2, q3, q4, q5, q6, q7, q8, q9, q10, q11, q12, q13, q14) = Set.unions [queryTypes q0, queryTypes q1, queryTypes q2, queryTypes q3, queryTypes q4, queryTypes q5, queryTypes q6, queryTypes q7, queryTypes q8, queryTypes q9, queryTypes q10, queryTypes q11, queryTypes q12, queryTypes q13, queryTypes q14]
+ src/Mischief/ECS/World/Query/TH.hs view
@@ -0,0 +1,104 @@+{-# OPTIONS_GHC -Wno-overlapping-patterns #-}++module Mischief.ECS.World.Query.TH (q, s, g) where++import Control.Monad+import Control.Monad.IO.Class+import Data.Maybe+import Data.Text (Text)+import Data.Text qualified as T+import Data.Void+import Language.Haskell.TH+import Language.Haskell.TH qualified+import Language.Haskell.TH.Quote+import Language.Haskell.TH.Syntax+import Mischief.ECS.Collectable+import Mischief.ECS.Components+import Mischief.ECS.Components.Common hiding (Name)+import Mischief.ECS.Entities+import Mischief.ECS.Hidden+import Mischief.ECS.Log+import Mischief.ECS.Utils+import Mischief.ECS.World.Query+import Mischief.ECS.World.Query.QueryFilter+import Mischief.ECS.World.Query.Queryable hiding (Q)+import Mischief.ECS.World.Query.TH.Common+import Mischief.ECS.World.Query.TH.QD+import Mischief.ECS.World.Query.TH.QF (Qf, pCheck, pQf, quoteQf)+import Text.Megaparsec (MonadParsec (eof), Parsec, choice, optional, parse, parseTest, runParserT, some, (<|>))+import Text.Megaparsec.Char+import Text.Megaparsec.Char.Lexer qualified as L++q :: QuasiQuoter+q =+  QuasiQuoter+    { quoteExp = \str -> do+        let x = parse (whitespace *> pQuery <* eof) "inline_input" (T.pack str)+        case x of+          Left f -> error (show f)+          Right x -> quoteQuery x,+      quotePat = undefined,+      quoteType = undefined,+      quoteDec = undefined+    }++data Query = Query Qd (Maybe Qf) deriving (Show)++pQuery :: Parser Query+pQuery = do+  qd <- pQd+  whitespace++  qf <- optional $ do+    void $ char '/'+    whitespace+    pQf++  pure $ Query qd qf++quoteQuery :: Query -> Q Exp+quoteQuery (Query qd Nothing) = AppE (VarE 'query) <$> quoteQd qd+quoteQuery (Query qd (Just qf)) = do+  qd <- quoteQd qd+  qf <- quoteQf qf+  return $ AppE (AppE (VarE 'query') qd) qf++s :: QuasiQuoter+s =+  QuasiQuoter+    { quoteExp = \str -> do+        let x = parse (whitespace *> pQuery <* eof) "inline_input" (T.pack str)+        case x of+          Left f -> error (show f)+          Right x -> quoteSingle x,+      quotePat = undefined,+      quoteType = undefined,+      quoteDec = undefined+    }++quoteSingle :: Query -> Q Exp+quoteSingle (Query qd Nothing) = AppE (VarE 'single) <$> quoteQd qd+quoteSingle (Query qd (Just qf)) = do+  qd <- quoteQd qd+  qf <- quoteQf qf+  return $ AppE (AppE (VarE 'single') qd) qf++g :: QuasiQuoter+g =+  QuasiQuoter+    { quoteExp = \str -> do+        let x = parse (whitespace *> pQuery <* eof) "inline_input" (T.pack str)+        case x of+          Left f -> error (show f)+          Right x -> quoteGet x,+      quotePat = undefined,+      quoteType = undefined,+      quoteDec = undefined+    }++quoteGet :: Query -> Q Exp+quoteGet (Query qd Nothing) = AppE (VarE 'get) <$> quoteQd qd+quoteGet (Query qd (Just qf)) = do+  qd <- quoteQd qd+  qf <- quoteQf qf+  return $ AppE (AppE (VarE 'get') qd) qf
+ src/Mischief/ECS/World/Query/TH/Common.hs view
@@ -0,0 +1,90 @@+module Mischief.ECS.World.Query.TH.Common where++import Control.Monad+import Control.Monad.IO.Class+import Data.Maybe+import Data.Text (Text)+import Data.Text qualified as T+import Data.Void+import Language.Haskell.Meta.Parse as M+import Language.Haskell.TH+import Language.Haskell.TH qualified+import Language.Haskell.TH.Quote+import Language.Haskell.TH.Syntax+import Mischief.ECS.Components (Component)+import Mischief.ECS.World.Query+import Mischief.ECS.World.Query.Markers hiding (Q)+import Mischief.ECS.World.Query.Markers qualified as Markers+import Mischief.ECS.World.Query.QueryFilter+import Mischief.ECS.World.Query.Queryable+import Mischief.ECS.World.Query.Queryable qualified as Queryable+import Text.Megaparsec (MonadParsec (eof, lookAhead, notFollowedBy, try), Parsec, choice, many, manyTill, noneOf, optional, parseTest, some, (<|>))+import Text.Megaparsec.Char+import Text.Megaparsec.Char.Lexer qualified as L++data CompType = Single | Pair Text | PairAny deriving (Show)++type Parser = Parsec Void Text++pTup :: Parser a -> Parser [a]+pTup p = do+  r <- optional p+  whitespace++  comma <- optional $ string ","+  whitespace++  case r of+    Nothing -> return []+    Just r -> do+      case comma of+        (Just _) -> ([r] ++) <$> pTup p+        _ -> return [r]++whitespace :: Parser ()+whitespace =+  L.space+    space1+    (L.skipLineComment "//")+    (L.skipBlockComment "/*" "*/")++pNameTup :: Parser Text+pNameTup = (char '(' *> whitespace) *> pNameRec <* (char ')' *> whitespace)++pNameRec :: Parser Text+pNameRec = do+  s <- T.pack <$> many (alphaNumChar <|> (' ' <$ space1) <|> char ',')+  o <- optional $ (char '(' *> whitespace) *> pNameRec <* (char ')' *> whitespace)++  case o of+    Nothing -> return s+    Just o -> do+      n <- pNameRec+      return $ s <> "(" <> o <> ")" <> n++getTypeName :: Text -> Q Name+getTypeName name = do+  t <- lookupTypeName $ T.unpack name+  return $ fromMaybe (error $ "Invalid type: " ++ T.unpack name ++ ".") t++getValueName :: Text -> Q Name+getValueName name = do+  t <- lookupValueName $ T.unpack name+  return $ fromMaybe (error $ "Invalid value: " ++ T.unpack name ++ ".") t++processC :: Text -> Q Exp+processC name = do+  let t = M.parseType (T.unpack name)+  case t of+    Left e -> error e+    Right t -> return $ AppTypeE (ConE 'C) t++processR :: Text -> Exp -> Q Exp+processR name e = do+  name <- getTypeName name+  return $ AppE (AppTypeE (ConE 'R) (ConT name)) e++relExp :: CompType -> Q Exp+relExp PairAny = return $ ConE 'Any+relExp (Pair x) = VarE <$> getValueName x+relExp _ = undefined
+ src/Mischief/ECS/World/Query/TH/QD.hs view
@@ -0,0 +1,189 @@+module Mischief.ECS.World.Query.TH.QD where++import Control.Monad+import Control.Monad.IO.Class+import Data.Maybe+import Data.Text (Text)+import Data.Text qualified as T+import Data.Void+import Language.Haskell.Meta.Parse as M+import Language.Haskell.TH+import Language.Haskell.TH qualified+import Language.Haskell.TH.Quote+import Language.Haskell.TH.Syntax+import Mischief.ECS.Components (Component)+import Mischief.ECS.World.Query+import Mischief.ECS.World.Query.Markers hiding (Q)+import Mischief.ECS.World.Query.Markers qualified as Markers+import Mischief.ECS.World.Query.QueryFilter+import Mischief.ECS.World.Query.Queryable+import Mischief.ECS.World.Query.Queryable qualified as Queryable+import Mischief.ECS.World.Query.TH.Common+import Mischief.ECS.World.Query.TH.QF qualified as QF+import Text.Megaparsec (MonadParsec (eof, lookAhead, notFollowedBy, try), Parsec, choice, many, manyTill, noneOf, optional, parseTest, some, (<|>))+import Text.Megaparsec.Char+import Text.Megaparsec.Char.Lexer qualified as L++data Qd = Val' Qd | Tup [Qd] | Entity' | Type QdType | Trans QdTrans deriving (Show)++data QdType = QdType {name :: Text, compType :: CompType, mod :: Maybe Mod} deriving (Show)++data QdTrans = QdTrans {name :: Text, exp :: Qd, filter :: Maybe QF.Qf, mod :: Maybe Mod} deriving (Show)++data Mod = M' | H' deriving (Show)++pQd :: Parser Qd+pQd = do+  Tup <$> pTup pEl++pEl :: Parser Qd+pEl = try ((char '(' *> whitespace) *> (Tup <$> pTup pEl) <* (char ')' *> whitespace)) <|> pSingle++-- case bracket of+--   Nothing -> pSingle+--   Just _ -> Tup <$> pTup pEl++data TestG a b = TestG deriving (Component)++pSingle :: Parser Qd+pSingle = do+  try pEntity <|> try pVal <|> try pMaybe <|> try pHas <|> try pValStar <|> try (pTrans Nothing) <|> pType Nothing++pEntity :: Parser Qd+pEntity = do+  void $ choice [string "Entity", string "entity", string "E", string "e"] <* notFollowedBy alphaNumChar+  whitespace++  return Entity'++pValStar :: Parser Qd+pValStar = do+  void $ char '*'+  whitespace+  Val' <$> pEl++pVal :: Parser Qd+pVal = do+  void $ choice [string "Val", string "val", string "V", string "v"] <* notFollowedBy alphaNumChar+  whitespace++  Val' <$> pEl++pMaybe :: Parser Qd+pMaybe = do+  void $ choice [string "Maybe", string "maybe", string "M", string "m"] <* notFollowedBy alphaNumChar+  whitespace++  try (pTrans (Just M')) <|> pType (Just M')++pHas :: Parser Qd+pHas = do+  void $ choice [string "Has", string "has", string "H", string "h"] <* notFollowedBy alphaNumChar+  whitespace++  try (pTrans (Just H')) <|> pType (Just H')++pTrans :: Maybe Mod -> Parser Qd+pTrans mod = do+  name <- pNameTup <|> T.pack <$> some alphaNumChar+  whitespace++  void $ string "->"+  whitespace++  qd <- (char '(' *> whitespace) *> (Tup <$> pTup pEl) <* whitespace++  qf <- optional $ do+    void $ char '/'+    whitespace+    QF.pQf++  whitespace+  void $ char ')'+  whitespace++  return . Trans $+    QdTrans+      { name,+        mod,+        filter = qf,+        exp = qd+      }++pType :: Maybe Mod -> Parser Qd+pType mod = do+  -- name <- pTypeGeneric <|> T.pack <$> some alphaNumChar+  name <- pNameTup <|> T.pack <$> some alphaNumChar+  whitespace++  target <- optional $ do+    void $ string "->"+    whitespace+    r <- string "*" <|> T.pack <$> some alphaNumChar+    whitespace+    return r++  let compType = case target of+        Nothing -> Single+        Just "*" -> PairAny+        Just e -> Pair e++  return . Type $+    QdType+      { name,+        compType,+        mod+      }++pName :: Parser Text+pName = T.pack <$> some alphaNumChar <|> pNameTup++pTypeGeneric :: Parser Text+pTypeGeneric = T.pack <$> (char '{' *> manyTill L.charLiteral (char '}'))++quoteQd :: Qd -> Q Exp+quoteQd (Type QdType {name, compType = Single, mod = Nothing}) = processC name+quoteQd (Type QdType {name, compType = Single, mod = Just M'}) = processM name+quoteQd (Type QdType {name, compType = Single, mod = Just H'}) = processH name+quoteQd (Type QdType {name, compType, mod = Nothing}) = processR name =<< relExp compType+quoteQd (Type QdType {name, compType, mod = Just M'}) = processMR name =<< relExp compType+quoteQd (Type QdType {name, compType, mod = Just H'}) = processHR name =<< relExp compType+quoteQd (Trans QdTrans {name, exp, mod = Nothing, filter}) = processR name =<< relTrans exp filter+quoteQd (Trans QdTrans {name, exp, mod = Just M', filter}) = processMR name =<< relTrans exp filter+quoteQd (Trans QdTrans {name, exp, mod = Just H', filter}) = processHR name =<< relTrans exp filter+quoteQd (Val' qd) = processVal <$> quoteQd qd+quoteQd (Tup []) = return $ ConE '()+quoteQd (Tup [x]) = quoteQd x+quoteQd (Tup t) = TupE <$> mapM (fmap Just . quoteQd) t+quoteQd Entity' = return $ ConE 'E++relTrans :: Qd -> Maybe QF.Qf -> Q Exp+relTrans exp Nothing = AppE (ConE 'Markers.Q) <$> quoteQd exp+relTrans exp (Just f) = do+  qd <- quoteQd exp+  qf <- QF.quoteQf f++  pure $ AppE (AppE (ConE 'Markers.Q') qd) qf++processVal :: Exp -> Exp+processVal = AppE (ConE 'Val)++processM :: Text -> Q Exp+processM name = do+  name <- getTypeName name+  return $ AppTypeE (ConE 'M) (ConT name)++processMR :: Text -> Exp -> Q Exp+processMR name e = do+  name <- getTypeName name+  return $ AppE (AppTypeE (ConE 'MR) (ConT name)) e++processH :: Text -> Q Exp+processH name = do+  name <- getTypeName name+  return $ AppTypeE (ConE 'Has) (ConT name)++processHR :: Text -> Exp -> Q Exp+processHR name e = do+  name <- getTypeName name+  return $ AppE (AppTypeE (ConE 'HasR) (ConT name)) e
+ src/Mischief/ECS/World/Query/TH/QF.hs view
@@ -0,0 +1,173 @@+module Mischief.ECS.World.Query.TH.QF where++import Control.Monad+import Control.Monad.IO.Class+import Data.Maybe+import Data.Text (Text)+import Data.Text qualified as T+import Data.Void+import Language.Haskell.Meta.Parse+import Language.Haskell.Meta.Parse as M+import Language.Haskell.TH+import Language.Haskell.TH qualified+import Language.Haskell.TH.Quote+import Language.Haskell.TH.Syntax+import Mischief.ECS.Components (Component)+import Mischief.ECS.World.Query+import Mischief.ECS.World.Query.Markers hiding (Q)+import Mischief.ECS.World.Query.QueryFilter+import Mischief.ECS.World.Query.Queryable hiding (Q)+import Mischief.ECS.World.Query.TH.Common+-- import Mischief.ECS.World.Query.TH.QD (CompType (..), Parser, pTup, whitespace)+-- import Mischief.ECS.World.Query.TH.QD qualified as QD+import Text.Megaparsec (MonadParsec (eof, lookAhead, notFollowedBy, try), Parsec, choice, many, manyTill, noneOf, optional, parseTest, satisfy, some, (<|>))+import Text.Megaparsec.Char+import Text.Megaparsec.Char.Lexer qualified as L++data Qf = With' [QfType] | Added' [QfType] | Changed' [QfType] | Not' Qf | Tup' [Qf] | Or' Qf Qf | Check' CompType Text deriving (Show)++data QfType = QfType {name :: Text, compType :: CompType} deriving (Show)++pQf :: Parser Qf+pQf = Tup' . concat <$> pTup pTup'++pTup' :: Parser [Qf]+pTup' = try ((char '(' *> whitespace) *> (concat <$> pTup pTup') <* (char ')' *> whitespace)) <|> (: []) <$> pOr++pOr :: Parser Qf+pOr = do+  s <- pSingle+  whitespace++  or <- optional $ choice [string "|.", string "||", string "or", string "OR", string "Or"] <* whitespace+  case or of+    Nothing -> return s+    Just _ -> foldr Or' s <$> pTup'++pSingle :: Parser Qf+pSingle = try pWith <|> pWithout <|> pAdded <|> try pChanged <|> pCheck <|> pNot++pNot :: Parser Qf+pNot = do+  void $ choice [string "Not", string "not", string "!"]+  whitespace++  Tup' <$> pTup'++pWith :: Parser Qf+pWith = do+  void $ choice [string "With", string "with"] <* notFollowedBy alphaNumChar+  whitespace+  With' <$> pTypes++pWithout :: Parser Qf+pWithout = do+  void $ choice [string "Without", string "without"] <* notFollowedBy alphaNumChar+  whitespace+  Not' . With' <$> pTypes++pAdded :: Parser Qf+pAdded = do+  void $ choice [string "Added", string "added"] <* notFollowedBy alphaNumChar+  whitespace+  Added' <$> pTypes++pChanged :: Parser Qf+pChanged = do+  void $ choice [string "Changed", string "changed"] <* notFollowedBy alphaNumChar+  whitespace+  Changed' <$> pTypes++pCheck :: Parser Qf+pCheck = do+  void $ choice [string "Check", string "check"] <* notFollowedBy alphaNumChar+  whitespace++  f <- pF+  whitespace++  target <- optional $ do+    void $ string "->"+    whitespace+    r <- string "*" <|> T.pack <$> some alphaNumChar+    whitespace+    return r++  let compType = case target of+        Nothing -> Single+        Just "*" -> PairAny+        Just e -> Pair e++  return $ Check' compType f++pF :: Parser Text+pF = try ((char '(' *> whitespace) *> pfLambda "(" <* whitespace) <|> T.pack <$> some alphaNumChar++pfLambda :: String -> Parser Text+pfLambda str = do+  x <- many (satisfy (/= ')'))+  void $ char ')'+  let str' = str ++ x ++ [')']+  case parseExp str' of+    Left _ -> do+      pfLambda str'+    Right _ -> return $ T.pack str'++pTypes :: Parser [QfType]+pTypes = try ((char '(' *> whitespace) *> (concat <$> pTup pTypes) <* (char ')' *> whitespace)) <|> (: []) <$> pType++pType :: Parser QfType+pType = do+  name <- pNameTup <|> T.pack <$> some alphaNumChar+  whitespace++  target <- optional $ do+    void $ string "->"+    whitespace+    r <- string "*" <|> T.pack <$> some alphaNumChar+    whitespace+    return r++  let compType = case target of+        Nothing -> Single+        Just "*" -> PairAny+        Just e -> Pair e++  return $+    QfType+      { name,+        compType+      }++quoteQf :: Qf -> Q Exp+quoteQf (Tup' qf) = processTup qf+quoteQf (With' x) = AppE (ConE 'With) <$> processTypes x+quoteQf (Changed' x) = AppE (ConE 'Changed) <$> processTypes x+quoteQf (Added' x) = AppE (ConE 'Added) <$> processTypes x+quoteQf (Or' x y) = do+  x <- quoteQf x+  y <- quoteQf y+  return $ AppE (AppE (ConE 'Or) x) y+quoteQf (Not' x) = AppE (ConE 'Not) <$> quoteQf x+quoteQf (Check' c f) = case parseExp (T.unpack f) of+  Left x -> error x+  Right x -> processCheck c x++processCheck :: CompType -> Exp -> Q Exp+processCheck Single f = return $ AppE (ConE 'Check) f+processCheck (Pair e') f = do+  e <- getValueName e'+  return $ AppE (AppE (ConE 'CheckR) (VarE e)) f+processCheck PairAny f = return $ AppE (AppE (ConE 'CheckR) (ConE 'Any)) f++processTup :: [Qf] -> Q Exp+processTup [x] = quoteQf x+processTup t = TupE . map Just <$> forM t quoteQf++processTypes :: [QfType] -> Q Exp+processTypes [x] = processType x+processTypes t = TupE . map Just <$> forM t processType++processType :: QfType -> Q Exp+processType (QfType {name, compType = Single}) = processC name+processType (QfType {name, compType}) = processR name =<< relExp compType
+ src/Mischief/ECS/World/Remove.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++module Mischief.ECS.World.Remove (remove, delete, removeRel, triggerRemoveEvent) where++import Control.Monad+import Control.Monad.Reader+import Data.Data+import Data.Foldable+import Data.IORef+import Data.Map qualified as Map+import Data.Maybe+import Data.Set (Set)+import Data.Set qualified as Set+import GHC.Base (Int (..), eqWord#, isTrue#)+import Mischief.ECS.Archetypes+import Mischief.ECS.Archetypes.Graph+import Mischief.ECS.Collectable+import Mischief.ECS.Components+import Mischief.ECS.Components.Common+import Mischief.ECS.Components.Spawn+import Mischief.ECS.Entities+import Mischief.ECS.EntityDef+import Mischief.ECS.EventDef+import Mischief.ECS.Events+import Mischief.ECS.Log+import Mischief.ECS.Tables+import Mischief.ECS.World+import Mischief.ECS.World.Change (changeArchetype)+import Mischief.ECS.World.Query+import Mischief.ECS.World.Query.Markers+import Mischief.ECS.World.Query.Queryable+import Mischief.ECS.World.Utils++newtype ToRemove = ToRemove {inner :: [(ComponentType, Maybe Entity, Maybe Any)]} deriving newtype (Semigroup)++instance (Component c) => EraseIntoStorage (C c) ToRemove where+  erase _ = ToRemove [(ComponentType $ Proxy @c, Nothing, Nothing)]++instance (Component c) => EraseIntoStorage (R c Entity) ToRemove where+  erase (R e) = ToRemove [(ComponentType $ Proxy @c, Just e, Nothing)]++instance (Component c) => EraseIntoStorage (R c Any) ToRemove where+  erase _ = ToRemove [(ComponentType $ Proxy @c, Nothing, Just Any)]++-- remove :: forall r. (Removable r) => Entity -> System ()+-- remove entity = do+--   types <- getTypes (Proxy @r)+--   removeFromEntity (Set.toList types) entity++class Delete r where+  delete :: r -> System ()++class Delete' r isRel where+  delete' :: r -> System ()++instance (Delete' (Result r) (IsComp r)) => Delete (Result r) where+  delete = delete' @(Result r) @(IsComp r)++instance (Component c) => Delete' (Result c) True where+  delete' :: Result c -> System ()+  delete' result = remove (C @c) (entityOf result)++instance (Component c) => Delete' (Result (Rel c)) False where+  delete' :: Result (Rel c) -> System ()+  delete' result = remove (R @c result.target) (entityOf result)++remove :: (Collectable c ToRemove) => c -> Entity -> System ()+remove c entity = do+  let list :: ToRemove = collect c+  for_ list.inner $ \case+    (x, Nothing, Nothing) -> do+      comp <- getOrAddComponentId x+      removeFromEntity [comp] entity+    (x, Just target, _) -> do+      comp <- getOrAddPairId (Pair (x, target))+      removeFromEntity [comp] entity+    (x, _, Just _) -> do+      removeRelationshipsFromEntity x entity++removeRel :: forall c. (Component c) => Entity -> Entity -> System ()+removeRel = removeRelationshipFromEntity @c++removeRelationshipFromEntity :: forall c. (Component c) => Entity -> Entity -> System ()+removeRelationshipFromEntity target entity = do+  componentId <- getOrAddPairId (Pair (ComponentType $ Proxy @c, target))+  removeFromEntity [componentId] entity++removeRelationshipsFromEntity :: ComponentType -> Entity -> System ()+removeRelationshipsFromEntity x entity = do+  world <- unsafeGetWorld+  ids <- liftIO $ findComponentsOfEntity world entity+  (ComponentId (# id, _ #)) <- getOrAddComponentId x+  for_ ids $ \ids' -> do+    let ids = filter (\(ComponentId (# id', _ #)) -> isTrue# $ eqWord# id id') ids'+    removeFromEntity ids entity++removeFromEntity :: [ComponentId] -> Entity -> System ()+removeFromEntity components entity = do+  world <- unsafeGetWorld+  pointer <- liftIO $ getPointer entity world.entities++  case pointer of+    Nothing -> warn $ "Removal failed: Entity " <> text entity <> " is not alive."+    Just pointer -> do+      (EntityPointer (# archetypeId, _ #)) <- liftIO $ readIORef pointer++      (newArchetype, removedComponents) <- getArchetypeOnRemove (ArchetypeId $ I# archetypeId) components+      triggerRemoveEvent removedComponents entity++      void $ changeArchetype entity newArchetype Nothing++triggerRemoveEvent :: [ComponentId] -> Entity -> System ()+triggerRemoveEvent components entity = do+  for_ components $ \(ComponentId (# id, target #)) -> do+    Just t <- get (C @ComponentType) (Entity (# id, 0## #))+    case target of+      Nothing -> triggerRemoveEventC (value t) entity+      Just target -> triggerRemoveEventR (value t) target entity++triggerRemoveEventC :: ComponentType -> Entity -> System ()+triggerRemoveEventC (ComponentType (_ :: Proxy t)) entity =+  runEvent $ eraseEvent $ OnRemove @t entity++triggerRemoveEventR :: ComponentType -> Entity -> Entity -> System ()+triggerRemoveEventR (ComponentType (_ :: Proxy t)) target entity =+  runEvent $ eraseEvent $ OnRemoveRel @t entity target
+ src/Mischief/ECS/World/Spawn.hs view
@@ -0,0 +1,127 @@+module Mischief.ECS.World.Spawn where++import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Reader (MonadReader (..), ReaderT (runReaderT))+import Data.Data+import Data.IORef+import Data.Map qualified as Map+import Data.Maybe+import Data.Set qualified as Set+import GHC.Base (Int (..))+import GHC.Stack+import Mischief.ECS.Archetypes.Graph (getArchetypeOnSpawn)+import Mischief.ECS.Components+import Mischief.ECS.Components.Bundle+import Mischief.ECS.Components.Common+import Mischief.ECS.Entities+import Mischief.ECS.EventDef+import Mischief.ECS.Hidden+import Mischief.ECS.Log+import Mischief.ECS.Observer+import Mischief.ECS.Tables+import Mischief.ECS.Vec qualified as Vec+import Mischief.ECS.World+import Mischief.ECS.World.Change+import Mischief.ECS.World.Defer+import Mischief.ECS.World.Insert+import Mischief.ECS.World.Prefs+import Mischief.ECS.World.Remove+import Mischief.ECS.World.Utils++-- | Spawn an entity given a bundle of components.+spawn :: (HasCallStack, Bundle b) => b -> System Entity+spawn bundle =+  do+    world <- unsafeGetWorld+    entity <- liftIO $ getNewEntity world.entities++    spawnEntity entity bundle+    return entity++spawnDefer :: (Bundle b) => b -> ParSystem Entity+spawnDefer bundle = do+  world <- unsafeGetWorld+  entity <- liftIO $ getNewEntity world.entities++  defer $ spawnEntity entity bundle+  return entity++data SpawnEventsSettings = WithSpawnEvents | WithoutSpawnEvents++spawnEntity :: (HasCallStack, Bundle b) => Entity -> b -> System ()+spawnEntity entity bundle = do+  world <- unsafeGetWorld+  let BundleData {elements} = addComponentToBundleData (Name (show entity)) $ bundleData bundle++  currentTick <- liftIO $ readIORef world.tick+  bundleD <- liftIO $ processBundleElements world ComponentTicks {changed = currentTick, added = currentTick} elements++  archetype <- getArchetypeOnSpawn $ map (\x -> x.id) bundleD.elements++  entityPointer <- liftIO $ newIORef $ EntityPointer (# 0#, 0# #)++  liftIO $ insertEntityIntoTables (ProcessedBundleData {elements = []}) world.tables (ArchetypeId 0) (entity, entityPointer)++  liftIO $ insertPointer entity entityPointer world.entities++  ChangeResult {requiredComponentsAdded} <- changeArchetype entity archetype (Just bundleD)++  unless world.prefs.supressEvents $ do+    triggerInsertEvent (ProcessedBundleData $ requiredComponentsAdded ++ bundleD.elements) entity++-- insertNew (Name (show entity)) entity++spawnEntityByInsert :: (Bundle b) => Entity -> b -> System ()+spawnEntityByInsert entity bundle = do+  world <- unsafeGetWorld++  entityPointer <- liftIO $ newIORef $ EntityPointer (# 0#, 0# #)++  liftIO $ insertEntityIntoTables (ProcessedBundleData {elements = []}) world.tables (ArchetypeId 0) (entity, entityPointer)++  liftIO $ insertPointer entity entityPointer world.entities++  insert bundle entity++  insertNew (Name (show entity)) entity++spawnObserverOrdered :: forall e. (Event e) => Observer e -> Int -> System ()+spawnObserverOrdered observer order = do+  void $ spawn (observer, ObserverOrder order)++spawnObserver :: forall e. (Event e) => Observer e -> System ()+spawnObserver e = spawnObserverOrdered e 0++-- | Spawn an entity given a bundle of components.+spawnIO :: (Bundle b) => World -> b -> IO Entity+spawnIO world bundle =+  do+    entity <- liftIO $ getNewEntity world.entities++    runSystem (spawnEntity entity bundle) world+    return entity++-- | Despawn an entity.+despawn :: Entity -> System ()+despawn entity =+  do+    world <- unsafeGetWorld+    pointer <- liftIO $ getPointer entity world.entities+    case pointer of+      Nothing -> warn $ "Despawn failed: Entity " <> text entity <> " is not alive."+      Just pointer -> do+        let Tables tables = world.tables++        (EntityPointer (# archetypeId, _ #)) <- liftIO $ readIORef pointer++        table <- Vec.read tables (I# archetypeId)++        c <- liftIO $ collectComponentIdsFromTable table+        triggerRemoveEvent c entity++        (EntityPointer (# newArchetypeId, newRowIndex #)) <- liftIO $ readIORef pointer++        table <- Vec.read tables (I# newArchetypeId)+        void $ liftIO $ takeComponentsFromTable (EntityPointer (# newArchetypeId, newRowIndex #)) table+        liftIO $ removeEntity entity world.entities
+ src/Mischief/ECS/World/Systems.hs view
@@ -0,0 +1,1 @@+module Mischief.ECS.World.Systems where
+ src/Mischief/ECS/World/Utils.hs view
@@ -0,0 +1,249 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++module Mischief.ECS.World.Utils where++import Control.Concurrent.STM+import Control.Monad+import Control.Monad.IO.Class (MonadIO (liftIO))+import Control.Monad.Primitive (PrimMonad (..))+import Control.Monad.Reader.Class (MonadReader (..), asks)+import Control.Monad.Trans (MonadTrans (..))+import Control.Monad.Trans.Reader (ReaderT (runReaderT))+import Data.Bifunctor qualified+import Data.IORef+import Data.List+import Data.Map qualified as Map+import Data.Maybe (fromMaybe, isNothing)+import Data.Proxy+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Typeable+import GHC.Stack+import Mischief.ECS.Archetypes+import Mischief.ECS.Components+import Mischief.ECS.Components.Bundle+import Mischief.ECS.Components.Spawn+import Mischief.ECS.Entities+import Mischief.ECS.EntityDef+import Mischief.ECS.EventDef+import Mischief.ECS.Hidden+import Mischief.ECS.Log+import Mischief.ECS.Tables+import Mischief.ECS.Utils+import Mischief.ECS.World+import Mischief.ECS.World.Prefs++-- | Process a 'BundleElement', turning its 'TypeRep' into a 'ComponentId'.+processBundleElement :: World -> ComponentTicks -> (BundleElement ErasedComponent) -> IO ProcessedBundleElement+processBundleElement world ticks BundleElement {rep = (ComponentRep r), component} =+  do+    id <- runSystem (getOrAddComponentId r) world+    return+      ProcessedBundleElement+        { id,+          component =+            ComponentData+              { value = component,+                ticks+              }+        }+processBundleElement world ticks BundleElement {rep = (PairRep (r, entity)), component} =+  do+    id <- runSystem (getOrAddPairId (Pair (r, entity))) world+    return+      ProcessedBundleElement+        { id,+          component =+            ComponentData+              { value = component,+                ticks+              }+        }++-- | Process a set of 'BundleElement's into a 'ProcessedBundleData'.+processBundleElements :: World -> ComponentTicks -> Set (BundleElement ErasedComponent) -> IO ProcessedBundleData+processBundleElements world ticks elements =+  do+    elements <- mapM (processBundleElement world ticks) (Set.toList elements)+    return+      ProcessedBundleData {elements}++-- | Combine two 'ProcessedBundleData's, merging their sets of elements.+combineProcessedBundles :: ProcessedBundleData -> ProcessedBundleData -> ProcessedBundleData+combineProcessedBundles bundle1 bundle2 =+  let elements = Set.toList $ Set.union (Set.fromList bundle1.elements) (Set.fromList bundle2.elements)+   in ProcessedBundleData {elements}++-- | Check if a 'ComponentId' is inside a 'ProcessedBundleData'.+isInProcessedBundle :: ProcessedBundleData -> ComponentId -> Bool+isInProcessedBundle ProcessedBundleData {elements} id = id `elem` map (\element -> element.id) elements++-- | Sets the change tick of certain elements of the bundle to the specified 'Tick'.+setChangedTickOfComponents :: ProcessedBundleData -> (ComponentId -> Bool) -> Tick -> ProcessedBundleData+setChangedTickOfComponents ProcessedBundleData {elements} shouldChange tick =+  ProcessedBundleData+    { elements =+        map+          ( \ProcessedBundleElement {id, component = ComponentData {value, ticks = ComponentTicks {added, changed}}} ->+              if shouldChange id+                then ProcessedBundleElement {id, component = ComponentData {value, ticks = ComponentTicks {added, changed = tick}}}+                else ProcessedBundleElement {id, component = ComponentData {value, ticks = ComponentTicks {added, changed}}}+          )+          elements+    }++-- | Sets the added tick of certain elements of the bundle to the specified 'Tick'.+setAddedTickOfComponents :: ProcessedBundleData -> (ComponentId -> Bool) -> Tick -> ProcessedBundleData+setAddedTickOfComponents ProcessedBundleData {elements} shouldChange tick =+  ProcessedBundleData+    { elements =+        map+          ( \ProcessedBundleElement {id, component = ComponentData {value, ticks = ComponentTicks {added, changed}}} ->+              if shouldChange id+                then ProcessedBundleElement {id, component = ComponentData {value, ticks = ComponentTicks {added = tick, changed}}}+                else ProcessedBundleElement {id, component = ComponentData {value, ticks = ComponentTicks {added, changed}}}+          )+          elements+    }++removeComponentFromProcessedBundle :: ComponentId -> ProcessedBundleData -> ProcessedBundleData+removeComponentFromProcessedBundle componentId bundle =+  do+    let elements = filter (\x -> x.id /= componentId) bundle.elements+     in ProcessedBundleData {elements}++tryGetEntityRelCollection :: forall c. (Component c) => World -> Entity -> IO (Maybe (Maybe [Result (Rel c)]))+tryGetEntityRelCollection world entity =+  do+    componentId <- getComponentId (typeRep $ Proxy @c) world.components+    case componentId of+      Nothing -> return Nothing+      Just componentId -> do+        pointer <- getPointer entity world.entities+        case pointer of+          Nothing -> do+            return Nothing+          Just pointer ->+            do+              pointer <- readIORef pointer+              res <- tryGetRelCollectionFromTables world.tables entity pointer componentId+              return $ Just res++tryGetEntityComponent :: forall c. (Component c) => World -> Entity -> IO (Maybe (Maybe c))+tryGetEntityComponent world entity =+  do+    pointer <- getPointer entity world.entities++    case pointer of+      Nothing -> return Nothing+      Just pointer ->+        do+          componentId <- getComponentId (typeRep $ Proxy @c) world.components+          case componentId of+            Nothing -> return $ Just Nothing+            Just componentId -> do+              pointer <- readIORef pointer+              res <- tryGetComponentFromTables world.tables pointer componentId+              return $ Just res++tryGetEntityRel :: forall c. (Component c) => Entity -> World -> Entity -> IO (Maybe (Maybe c))+tryGetEntityRel target world entity =+  do+    pointer <- getPointer entity world.entities++    case pointer of+      Nothing -> return Nothing+      Just pointer ->+        do+          componentId <- getComponentId (typeRep $ Proxy @c) world.components+          case componentId of+            Nothing -> return Nothing+            Just (ComponentId (# id, _ #)) -> do+              pointer <- readIORef pointer+              res <- tryGetComponentFromTables world.tables pointer (ComponentId (# id, Just target #))+              return $ Just res++tryGetRelCollections :: forall c. (Component c) => World -> [ArchetypeId] -> IO [(Entity, [Result (Rel c)])]+tryGetRelCollections world archetypes =+  do+    componentId <- getComponentId (typeRep $ Proxy @c) world.components+    case componentId of+      Nothing -> return []+      Just componentId ->+        tryGetRelCollectionsFromTables world.tables archetypes componentId++tryGetComponents :: forall c. (Component c) => World -> [ArchetypeId] -> IO [(Entity, Result c)]+tryGetComponents world archetypes =+  do+    componentId <- getComponentId (typeRep $ Proxy @c) world.components+    case componentId of+      Nothing -> return []+      Just componentId ->+        tryGetComponentsFromTables world.tables archetypes componentId++tryGetEntities :: World -> [ArchetypeId] -> IO [Entity]+tryGetEntities world = tryGetEntitiesFromTables world.tables++tryGetRels :: forall c. (Component c) => Entity -> World -> [ArchetypeId] -> IO [(Entity, Result (Rel c))]+tryGetRels target world archetypes =+  do+    componentId <- getComponentId (typeRep $ Proxy @c) world.components+    case componentId of+      Nothing -> return []+      Just componentId -> do+        res <- tryGetComponentsFromTables world.tables archetypes (setCompIdTarget (Just target) componentId) -- {entity = Just target}+        return $ map (\(e, res) -> (e, Result (Rel (value res) target, entityOf res))) res++tryGetRelsMaybe :: forall c. (Component c) => Entity -> World -> [ArchetypeId] -> IO [(Entity, Maybe (Result (Rel c)))]+tryGetRelsMaybe target world archetypes =+  do+    componentId <- getComponentId (typeRep $ Proxy @c) world.components+    case componentId of+      Nothing -> do+        e <- tryGetEntities world archetypes+        return $ map (,Nothing) e+      Just componentId -> do+        res <- tryGetComponentsFromTablesMaybe world.tables archetypes (setCompIdTarget (Just target) componentId) -- {entity = Just target}+        return $+          map+            ( Data.Bifunctor.second+                (fmap (\res -> Result (Rel (value res) target, entityOf res)))+            )+            res++tryGetComponentsMaybe :: forall c. (Component c) => World -> [ArchetypeId] -> IO [(Entity, Maybe (Result c))]+tryGetComponentsMaybe world archetypes =+  do+    componentId <- getComponentId (typeRep $ Proxy @c) world.components+    case componentId of+      Nothing -> do+        e <- tryGetEntities world archetypes+        return $ map (,Nothing) e+      Just componentId ->+        tryGetComponentsFromTablesMaybe world.tables archetypes componentId++tryGetTicks :: ComponentId -> World -> [ArchetypeId] -> IO [Maybe ComponentTicks]+tryGetTicks componentId world archetypes = tryGetTicksFromTables world.tables archetypes componentId++tryGetEntityTicks :: Entity -> ComponentId -> World -> IO (Maybe ComponentTicks)+tryGetEntityTicks entity componentId world = do+  pointer <- getPointer entity world.entities+  case pointer of+    Nothing -> return Nothing+    Just pointer -> do+      pointer <- readIORef pointer+      tryGetEntityTicksFromTables world.tables pointer componentId++isAlive :: forall m w. (MonadSystem w m) => Entity -> m Bool+isAlive entity = do+  world <- unsafeGetWorld+  liftIO $ isAliveIO entity world.entities++expect :: (HasCallStack) => forall m w a. (MonadSystem w m) => Text -> Maybe a -> m a+expect t a = withFrozenCallStack $ do+  case a of+    Nothing -> panic t >>= const undefined+    Just x -> return x++newtype GetSystem = GetSystem (forall c. (Component c) => Proxy c -> Entity -> System (Maybe c))
+ test/Main.hs view
@@ -0,0 +1,334 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE MultiWayIf #-}++{- HLINT ignore "Use newtype instead of data" -}++module Main where++import Control.Monad (void, when)+import Control.Monad.IO.Class+import Data.Default+import Data.Foldable+import Data.List ((!?))+import Data.Traversable+import Mischief.ECS.Hooks qualified as Hooks+import Mischief.ECS.Interval qualified as Interval+import Mischief.ECS.Observers qualified as Observers+import Mischief.ECS.Prelude+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.Timer qualified as Timer+import System.Exit+import System.Random+import System.Random.Stateful++main :: IO ()+main = do+  app <- newApp MainPlugin+  runApp app++data MainPlugin = MainPlugin deriving (Eq)++instance Plugin MainPlugin where+  init _ = do+    Stdin.init+    Systems.add Startup (spawnGrid, spawnWalls)+    Systems.add Update printGrid++    interval <- Interval.start 2000000 spawnCoin++    insertRes =<< newGen+    insertRes $ Coins 0++  plugins _ = plug (PlayerPlugin, EnemyPlugin, TimePlugin)++data PlayerPlugin = PlayerPlugin deriving (Eq)++instance Plugin PlayerPlugin where+  init _ = do+    Systems.add Startup $ spawnPlayer `after` spawnGrid+    Systems.add Update movePlayer+    Systems.add Update $ collectCoins `after` movePlayer++    void $ Observers.spawn onDamage++data EnemyPlugin = EnemyPlugin deriving (Eq)++instance Plugin EnemyPlugin where+  init _ = do+    Systems.add Startup spawnEnemies+    Systems.add Update moveEnemies+    Systems.add Update $ tryDamage `after` movePlayer `after` moveEnemies++data Tile = Tile deriving (Component)++newtype Pos = Pos {pos :: (Int, Int)} deriving (Component, Show)++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++gridW :: Int+gridW = 20++spawnGrid :: System ()+spawnGrid = do+  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)++data Player = Player++instance Component Player where+  required = require @Health++data OnTile = OnTile++instance Component OnTile where+  type RelExclusivity OnTile = Exclusive++spawnPlayer :: System ()+spawnPlayer = do+  Just tile <- getTile (5, 5)+  void $ spawn (Player, Rel OnTile tile)++data Wall = Wall deriving (Component)++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)++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 -> '.'++showGrid :: System String+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++printGrid :: System ()+printGrid = do+  grid <- showGrid+  health <- showHealth+  coins <- showCoins+  printClear $ health ++ "\n" ++ grid ++ "\n" ++ coins ++ "\n"++movePlayer :: System ()+movePlayer = do+  c <- Stdin.readLast+  for_ c $ \case+    'w' -> movePlayerBy (-1, 0)+    's' -> movePlayerBy (1, 0)+    'a' -> movePlayerBy (0, -1)+    '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+newGen = Rand <$> (newIOGenM =<< initStdGen)++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+  return (i, j)++randomTile :: System Entity+randomTile = unwrap <$> (getTile =<< randomPos)++spawnEnemy :: System Entity+spawnEnemy = do+  tile <- randomTile+  spawn (Enemy, Rel OnTile tile)++spawnEnemies :: System ()+spawnEnemies = for_ [0 .. 4] $ const spawnEnemy++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)++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.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++tileHas :: forall c. (QueryType c) => Entity -> System Bool+tileHas tile = not . null <$> [q|Entity / With (c, OnTile -> tile)|]++tileAtPosIsFree :: (Int, Int) -> System Bool+tileAtPosIsFree pos = do+  tile <- getTile pos+  maybe (pure False) tileIsFree tile++tileIsFree :: Entity -> System Bool+tileIsFree tile = do+  wall <- tileHas @Wall tile+  enemy <- tileHas @Enemy tile+  player <- tileHas @Player tile+  pure $ not (wall || enemy || player)++data Health = Health {hp :: Int} deriving (Component)++instance Default Health where+  def = Health 100++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++    insert Invincible entity+    delay 1000000 $ remove (C @Invincible) entity++    Just health <- update health+    when (health.hp == 0) $ liftIO exitSuccess++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)++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)++spawnCoin :: System ()+spawnCoin = do+  tile <- randomTile+  free <- tileIsFree tile+  if free+    then+      void $ spawn (Coin, Rel OnTile tile)+    else+      spawnCoin++data Coins = Coins Int deriving (Component)++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++data Likes = Likes Int deriving (Component)++a :: System ()+a = do+  people <- query (C @Name, R @Likes (Q (C @Name)))+  for_ people $ \(name, names) -> do+    info $ text name <> " likes " <> text names
+ test/Relationships.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}++module Relationships where++import Control.Concurrent+import Control.Monad+import Control.Monad.IO.Class+import Data.Foldable hiding (and, or)+import Data.Maybe+import GHC.Exts+import Mischief.ECS+import Mischief.ECS.Components.Common+import Mischief.ECS.Components.Spawn (meta)+import System.Exit (exitSuccess)+import Prelude hiding (and)++data Parent1 = Parent1 deriving (Component)++data Parent2 = Parent2 deriving (Component)++-- testRelationships :: IO ()+-- testRelationships = do+--   app <- newApp plugin+--   runApp app++-- plugin :: Plugin ()+-- plugin = do+--   run $ addSystems Startup setup+--   run $ addSystems Startup $ exit `after` setup+--   addObserver observer++-- setup :: System ()+-- setup = do+--   p1 <- spawn (Parent1, Name "Parent 1")+--   p2 <- spawn (Parent2, Name "Parent 2")++--   _ <- spawn (Rel (ChildOf, p1), Name "Child 1")+--   _ <- spawn (Rel (ChildOf, p1), Name "Child 2")+--   _ <- spawn (Rel (ChildOf, p1), Name "Child 3")++--   _ <- spawn (Rel (ChildOf, p2), Name "Child 4")+--   _ <- spawn ((Rel (ChildOf, p2), Rel (ChildOf, p1)), Name "Child 5")++--   q4 <- query @(Name, Rel ChildOf)+--   for_ q4 $ \(name, result) ->+--     for_ result $ \rel -> do+--       liftIO $ putStrLn $ show name ++ " is child of " ++ show (target rel)+--       Just parentName <- get @Name (target rel)+--       liftIO $ print parentName++-- observer :: OnInsertRel ChildOf -> System ()+-- observer event = liftIO $ putStrLn $ show event.entity ++ " is now a child of " ++ show event.target++-- exit :: System ()+-- exit = do+--   liftIO exitSuccess