packages feed

apecs-roaring (empty) → 1.0

raw patch · 11 files changed

+1083/−0 lines, 11 filesdep +QuickCheckdep +apecsdep +apecs-roaringsetup-changed

Dependencies added: QuickCheck, apecs, apecs-roaring, base, containers, croaring-ffi, deepseq, primitive, tasty, tasty-bench, vector

Files

+ CHANGELOG.md view
@@ -0,0 +1,14 @@+# Changelog for `apecs-roaring`++All notable changes to this project will be documented in this file.++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),+and this project adheres to the+[Haskell Package Versioning Policy](https://pvp.haskell.org/).++## Unreleased++## 1.0 - 2026-11-09++Initial release.+
+ LICENSE view
@@ -0,0 +1,26 @@+Copyright 2026 IC Rainbow++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1.  Redistributions of source code must retain the above copyright notice, this+    list of conditions and the following disclaimer.++2.  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.++3.  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.
+ README.md view
@@ -0,0 +1,58 @@+# apecs-roaring++[apecs](https://github.com/jonascarpay/apecs) stores for flag-like components and bitmap joins, backed by [CRoaring](https://github.com/RoaringBitmap/CRoaring) 64-bit bitmaps.++See the [benchmark results](https://dpwiz.gitlab.io/apecs-roaring) for how they compare with `Map` and `Cache` (tldr: counting, filtering, saving space on large-ish collections).++## Usage++```haskell+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++import Apecs (Cache, Component (..), Map, cfold, makeWorld, newEntity_, runWith)+import Apecs.Stores.Flags (Flags)+import Apecs.Stores.Roaring (Roaring)+import GHC.Generics (Generic)++data Enemy = Enemy deriving (Generic)++instance Component Enemy where+  type Storage Enemy = Flags Enemy++data Dead = Dead deriving (Generic)++instance Component Dead where+  type Storage Dead = Flags Dead++newtype Health = Health Int++instance Component Health where+  type Storage Health = Roaring (Cache 1024 (Map Health))++makeWorld "World" [''Enemy, ''Dead, ''Health]++main :: IO ()+main = do+  world <- initWorld+  totalHealth <- runWith world $ do+    newEntity_ (Enemy, Health 30)+    newEntity_ (Enemy, Health 10, Dead)+    newEntity_ $ Health 50+    cfold (\total (Health health) -> total + health) 0+  print totalHealth+```++`Query.count` from `Apecs.Stores.Query` reads a store's size off its bitmap without visiting any entity:++```haskell+enemies <- Query.count @Enemy+```++`Every` from the same module joins a tuple by intersecting bitmaps, subtracting any `Not` terms, and `Query.count` sizes the join without listing it:++```haskell+cmap $ \(Every (Enemy, Health health, _ :: Not Dead)) -> Health $ health - 1+livingEnemies <- Query.count @(Every (Enemy, Not Dead))+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ apecs-roaring.cabal view
@@ -0,0 +1,84 @@+cabal-version: 2.2++-- This file has been generated from package.yaml by hpack version 0.39.6.+--+-- see: https://github.com/sol/hpack++name:           apecs-roaring+version:        1.0+synopsis:       Roaring bitmap stores for apecs+description:    Apecs stores for flag-like components backed by CRoaring 64-bit bitmaps.+category:       Game, Control, Data+author:         IC Rainbow+maintainer:     aenor.realm@gmail.com+copyright:      2026 IC Rainbow+license:        BSD-3-Clause+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    CHANGELOG.md++source-repository head+  type: git+  location: https://gitlab.com/dpwiz/apecs-roaring++library+  exposed-modules:+      Apecs.Stores.Flags+      Apecs.Stores.Index+      Apecs.Stores.Query+      Apecs.Stores.Roaring+  other-modules:+      Paths_apecs_roaring+  autogen-modules:+      Paths_apecs_roaring+  hs-source-dirs:+      src+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints+  build-depends:+      apecs ==0.10.*+    , base >=4.20 && <5+    , croaring-ffi ==1.0.*+    , primitive ==0.9.*+    , vector ==0.13.*+  default-language: GHC2021++test-suite apecs-roaring-test+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      Paths_apecs_roaring+  autogen-modules:+      Paths_apecs_roaring+  hs-source-dirs:+      test+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      QuickCheck >=2.10 && <3+    , apecs+    , apecs-roaring+    , base >=4.20 && <5+    , containers+    , vector+  default-language: GHC2021++benchmark apecs-roaring-bench+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      Paths_apecs_roaring+  autogen-modules:+      Paths_apecs_roaring+  hs-source-dirs:+      bench+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -O2 -rtsopts "-with-rtsopts=-A32m -C10"+  build-depends:+      apecs+    , apecs-roaring+    , base >=4.20 && <5+    , deepseq+    , tasty+    , tasty-bench ==0.4.*+    , vector+  default-language: GHC2021
+ bench/Main.hs view
@@ -0,0 +1,325 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++import Apecs (Cache, Component (..), Destroy, Entity (..), Get, Map, Members, Not (..), Proxy (..), Set, System, cfold, cmap, destroy, exists, makeWorld, runSystem, set)+import Apecs.Stores.Flags (Flags)+import Apecs.Stores.Flags qualified as Flags+import Apecs.Stores.Query (Every (..))+import Apecs.Stores.Query qualified as Query+import Apecs.Stores.Roaring (Roaring)+import Control.DeepSeq (NFData (..), rwhnf)+import Control.Monad (unless)+import Data.List (nub)+import Data.Vector.Unboxed qualified as Unboxed+import GHC.Generics (Generic)+import Test.Tasty.Bench (Benchmark, bcompare, bench, bgroup, defaultMain, env, locateBenchmark, mapLeafBenchmarks, whnfIO)+import Test.Tasty.Patterns.Printer (printAwkExpr)++data MapFlag = MapFlag++instance Component MapFlag where+  type Storage MapFlag = Map MapFlag++data CachedFlag = CachedFlag++instance Component CachedFlag where+  type Storage CachedFlag = Cache 10000 (Map CachedFlag)++data RoaringFlag = RoaringFlag+  deriving (Generic)++instance Component RoaringFlag where+  type Storage RoaringFlag = Flags RoaringFlag++newtype MapHealth = MapHealth Int++instance Component MapHealth where+  type Storage MapHealth = Map MapHealth++newtype CachedHealth = CachedHealth Int++instance Component CachedHealth where+  type Storage CachedHealth = Cache 10000 (Map CachedHealth)++newtype RoaringHealth = RoaringHealth Int++instance Component RoaringHealth where+  type Storage RoaringHealth = Roaring (Cache 10000 (Map RoaringHealth))++makeWorld "MapFlagWorld" [''MapFlag]+makeWorld "CachedFlagWorld" [''CachedFlag]+makeWorld "RoaringFlagWorld" [''RoaringFlag]+makeWorld "MapHealthWorld" [''MapHealth]+makeWorld "CachedHealthWorld" [''CachedHealth]+makeWorld "RoaringHealthWorld" [''RoaringHealth]+makeWorld "MapJoinWorld" [''MapFlag, ''MapHealth]+makeWorld "CachedJoinWorld" [''CachedFlag, ''CachedHealth]+makeWorld "RoaringJoinWorld" [''RoaringFlag, ''RoaringHealth]++instance NFData MapFlagWorld where rnf = rwhnf+instance NFData CachedFlagWorld where rnf = rwhnf+instance NFData RoaringFlagWorld where rnf = rwhnf+instance NFData MapHealthWorld where rnf = rwhnf+instance NFData CachedHealthWorld where rnf = rwhnf+instance NFData RoaringHealthWorld where rnf = rwhnf+instance NFData MapJoinWorld where rnf = rwhnf+instance NFData CachedJoinWorld where rnf = rwhnf+instance NFData RoaringJoinWorld where rnf = rwhnf++type Contender w c = (NFData w, Get w IO c, Set w IO c, Destroy w IO c, Members w IO c)++data Store w c = Store+  { label :: String+  , initWorld :: IO w+  , make :: Int -> c+  , weigh :: c -> Int+  , count :: System w Int+  , clear :: System w ()+  }++data Join w = Join+  { label :: String+  , initWorld :: IO w+  , populate :: Pairs -> System w ()+  , total :: System w Int+  , overlap :: System w Int+  }++data Layout = Layout+  { name :: String+  , present :: Int -> Unboxed.Vector Int+  , absent :: Int -> Unboxed.Vector Int+  }++data Ids = Ids+  { size :: Int+  , present :: Unboxed.Vector Int+  , probes :: Unboxed.Vector Int+  }++instance NFData Ids where+  rnf ids = rnf ids.present `seq` rnf ids.probes++data Pairs = Pairs+  { flagged :: Unboxed.Vector Int+  , healthy :: Unboxed.Vector Int+  , overlap :: Int+  , total :: Int+  }++instance NFData Pairs where+  rnf pairs = rnf pairs.flagged `seq` rnf pairs.healthy++baseline :: String+baseline = "Cache 10000 Map"++sizes :: [Int]+sizes = [1000, 10000, 100000, 1000000]++main :: IO ()+main =+  defaultMain+    . map (mapLeafBenchmarks compareToBaseline)+    $ [ bgroup "flags" $ map (layoutGroup flagsGroup) [dense, sparse]+      , bgroup "payload" $ map (layoutGroup payloadGroup) [dense, sparse]+      , bgroup "join" $ map (layoutGroup joinGroup) [dense, sparse]+      ]++compareToBaseline :: [String] -> Benchmark -> Benchmark+compareToBaseline = \case+  leaf : path | leaf /= baseline -> bcompare . printAwkExpr . locateBenchmark $ baseline : path+  _ -> id++dense :: Layout+dense =+  Layout+    { name = "dense"+    , present = Unboxed.enumFromN 0+    , absent = \count -> Unboxed.enumFromN count count+    }++sparse :: Layout+sparse =+  Layout+    { name = "sparse"+    , present = Unboxed.enumFromStepN 0 37+    , absent = Unboxed.enumFromStepN 1 37+    }++layoutGroup :: (Layout -> Int -> Benchmark) -> Layout -> Benchmark+layoutGroup sizeGroup layout = bgroup layout.name $ map (sizeGroup layout) sizes++idsFor :: Layout -> Int -> Ids+idsFor layout count =+  Ids+    { size = count+    , present = layout.present count+    , probes = layout.present count <> layout.absent count+    }++pairsFor :: Layout -> Int -> Pairs+pairsFor layout count =+  Pairs+    { flagged = every 2+    , healthy = every 3+    , overlap = Unboxed.length common+    , total = Unboxed.sum common+    }+  where+    spread = layout.present count+    every step = Unboxed.ifilter (\position _ -> position `mod` step == 0) spread+    common = every 6++flagsGroup :: Layout -> Int -> Benchmark+flagsGroup layout count =+  env (pure $ idsFor layout count) $ \ids ->+    bgroup (show count) $ byOperation [flagOperations ids mapFlags, flagOperations ids cachedFlags, flagOperations ids roaringFlags]++payloadGroup :: Layout -> Int -> Benchmark+payloadGroup layout count =+  env (pure $ idsFor layout count) $ \ids ->+    bgroup (show count) $ byOperation [operations ids mapHealth, operations ids cachedHealth, operations ids roaringHealth]++joinGroup :: Layout -> Int -> Benchmark+joinGroup layout count =+  env (pure $ pairsFor layout count) $ \pairs ->+    bgroup (show count) $ byOperation [joinOperations pairs mapJoin, joinOperations pairs cachedJoin, joinOperations pairs tupleJoin, joinOperations pairs everyJoin]++byOperation :: [[(String, Benchmark)]] -> [Benchmark]+byOperation perStore = [bgroup operation [benchmark | named <- perStore, (candidate, benchmark) <- named, candidate == operation] | operation <- names]+  where+    names = nub [operation | named <- perStore, (operation, _) <- named]++mapFlags :: Store MapFlagWorld MapFlag+mapFlags = Store{label = "Map", initWorld = initMapFlagWorld, make = const MapFlag, weigh = const 1, count = countAll @MapFlag, clear = clearAll @MapFlag}++cachedFlags :: Store CachedFlagWorld CachedFlag+cachedFlags = Store{label = baseline, initWorld = initCachedFlagWorld, make = const CachedFlag, weigh = const 1, count = countAll @CachedFlag, clear = clearAll @CachedFlag}++roaringFlags :: Store RoaringFlagWorld RoaringFlag+roaringFlags = Store{label = "Flags", initWorld = initRoaringFlagWorld, make = const RoaringFlag, weigh = const 1, count = Query.count @RoaringFlag, clear = Flags.clear @RoaringFlag}++mapHealth :: Store MapHealthWorld MapHealth+mapHealth = Store{label = "Map", initWorld = initMapHealthWorld, make = MapHealth, weigh = \(MapHealth hp) -> hp, count = countAll @MapHealth, clear = clearAll @MapHealth}++cachedHealth :: Store CachedHealthWorld CachedHealth+cachedHealth = Store{label = baseline, initWorld = initCachedHealthWorld, make = CachedHealth, weigh = \(CachedHealth hp) -> hp, count = countAll @CachedHealth, clear = clearAll @CachedHealth}++roaringHealth :: Store RoaringHealthWorld RoaringHealth+roaringHealth = Store{label = "Roaring Cache 10000 Map", initWorld = initRoaringHealthWorld, make = RoaringHealth, weigh = \(RoaringHealth hp) -> hp, count = Query.count @RoaringHealth, clear = clearAll @RoaringHealth}++mapJoin :: Join MapJoinWorld+mapJoin =+  Join+    { label = "Map"+    , initWorld = initMapJoinWorld+    , populate = fill MapFlag MapHealth+    , total = cfold (\running (MapFlag, MapHealth hp) -> running + hp) 0+    , overlap = cfold (\found (MapFlag, MapHealth _) -> found + 1) 0+    }++cachedJoin :: Join CachedJoinWorld+cachedJoin =+  Join+    { label = baseline+    , initWorld = initCachedJoinWorld+    , populate = fill CachedFlag CachedHealth+    , total = cfold (\running (CachedFlag, CachedHealth hp) -> running + hp) 0+    , overlap = cfold (\found (CachedFlag, CachedHealth _) -> found + 1) 0+    }++tupleJoin :: Join RoaringJoinWorld+tupleJoin =+  Join+    { label = "Flags and Roaring tuple"+    , initWorld = initRoaringJoinWorld+    , populate = fill RoaringFlag RoaringHealth+    , total = cfold (\running (RoaringFlag, RoaringHealth hp) -> running + hp) 0+    , overlap = cfold (\found (RoaringFlag, RoaringHealth _) -> found + 1) 0+    }++everyJoin :: Join RoaringJoinWorld+everyJoin =+  Join+    { label = "Flags and Roaring Every"+    , initWorld = initRoaringJoinWorld+    , populate = fill RoaringFlag RoaringHealth+    , total = cfold (\running (Every (RoaringFlag, RoaringHealth hp)) -> running + hp) 0+    , overlap = Query.count @(RoaringFlag, RoaringHealth)+    }++fill :: (Set w IO f, Set w IO h) => f -> (Int -> h) -> Pairs -> System w ()+fill flag health pairs = do+  Unboxed.mapM_ (\ety -> set (Entity ety) flag) pairs.flagged+  Unboxed.mapM_ (\ety -> set (Entity ety) $ health ety) pairs.healthy+{-# INLINE fill #-}++flagOperations :: (Contender w c) => Ids -> Store w c -> [(String, Benchmark)]+flagOperations ids store = operations ids store <> [("reset", withPopulated ids store . runSystem $ store.clear >> raise store ids.present)]+{-# INLINE flagOperations #-}++operations :: forall w c. (Contender w c) => Ids -> Store w c -> [(String, Benchmark)]+operations ids store =+  [ ("set", bench store.label . whnfIO $ store.initWorld >>= runSystem (raise store ids.present))+  , ("exists", withPopulated ids store $ runSystem (countExisting @c ids.probes))+  , ("cfold", withPopulated ids store . runSystem $ cfold (\running component -> running + store.weigh component) 0)+  , ("toggle", withPopulated ids store . runSystem $ lower @c ids.present >> raise store ids.present)+  , ("count", withPopulated ids store $ runSystem store.count)+  ]+{-# INLINE operations #-}++joinOperations :: (NFData w) => Pairs -> Join w -> [(String, Benchmark)]+joinOperations pairs contender =+  [ ("sum", prepared contender.total)+  , ("count", prepared contender.overlap)+  ]+  where+    prepared measure = env prepare $ bench contender.label . whnfIO . runSystem measure+    prepare = do+      world <- contender.initWorld+      (found, summed) <- flip runSystem world $ do+        contender.populate pairs+        (,) <$> contender.overlap <*> contender.total+      unless (found == pairs.overlap && summed == pairs.total) . fail $+        contender.label <> ": joined " <> show found <> " summing " <> show summed <> ", expected " <> show pairs.overlap <> " summing " <> show pairs.total+      pure world+{-# INLINE joinOperations #-}++withPopulated :: forall w c a. (Contender w c) => Ids -> Store w c -> (w -> IO a) -> Benchmark+withPopulated ids store action = env populate $ bench store.label . whnfIO . action+  where+    populate = do+      world <- store.initWorld+      counted <- flip runSystem world $ raise store ids.present >> countAll @c+      unless (counted == ids.size) . fail $ store.label <> ": populated " <> show counted <> " of " <> show ids.size+      pure world+{-# INLINE withPopulated #-}++raise :: (Contender w c) => Store w c -> Unboxed.Vector Int -> System w ()+raise store = Unboxed.mapM_ $ \ety -> set (Entity ety) $ store.make ety+{-# INLINE raise #-}++lower :: forall c w. (Contender w c) => Unboxed.Vector Int -> System w ()+lower = Unboxed.mapM_ $ \ety -> destroy (Entity ety) $ Proxy @c+{-# INLINE lower #-}++countExisting :: forall c w. (Contender w c) => Unboxed.Vector Int -> System w Int+countExisting = Unboxed.foldM' probe 0+  where+    probe found ety = do+      present <- exists (Entity ety) $ Proxy @c+      pure $ if present then found + 1 else found+{-# INLINE countExisting #-}++countAll :: forall c w. (Get w IO c, Members w IO c) => System w Int+countAll = cfold (\found (_ :: c) -> found + 1) 0+{-# INLINE countAll #-}++clearAll :: forall c w. (Get w IO c, Members w IO c, Destroy w IO c) => System w ()+clearAll = cmap $ \(_ :: c) -> Not @c+{-# INLINE clearAll #-}
+ src/Apecs/Stores/Flags.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++{-| A store for flag-like components backed by an off-heap 'Index'.++A flag component has exactly one value, so the store keeps only membership.+Derive 'Generic' for the component to let the store produce that value:++@+data Dead = Dead deriving (Generic)+instance Component Dead where type Storage Dead = Flags Dead+@+-}+module Apecs.Stores.Flags+  ( Flags (..)+  , Unit (..)+  , clear+  ) where++import Apecs.Core (Component (..), Elem, ExplDestroy (..), ExplGet (..), ExplInit (..), ExplMembers (..), ExplSet (..), Has (..), SystemT)+import Apecs.Stores.Index (HasIndex (..), Index)+import Apecs.Stores.Index qualified as Index+import Control.Monad.IO.Class (MonadIO (..))+import GHC.Generics (Generic (..), M1 (..), U1 (..))++newtype Flags c = Flags Index++type instance Elem (Flags c) = c++class Unit f where+  unit :: f p++instance Unit U1 where+  unit = U1++instance (Unit f) => Unit (M1 i meta f) where+  unit = M1 unit++instance (MonadIO m) => ExplInit m (Flags c) where+  explInit = liftIO $ Flags <$> Index.new++instance (MonadIO m, Generic c, Unit (Rep c)) => ExplGet m (Flags c) where+  explGet _ _ = pure $ to unit+  {-# INLINE explGet #-}+  explExists (Flags index) = liftIO . Index.member index+  {-# INLINE explExists #-}++instance (MonadIO m) => ExplSet m (Flags c) where+  explSet (Flags index) ety _ = liftIO $ Index.insert index ety+  {-# INLINE explSet #-}++instance (MonadIO m) => ExplDestroy m (Flags c) where+  explDestroy (Flags index) = liftIO . Index.delete index+  {-# INLINE explDestroy #-}++instance (MonadIO m) => ExplMembers m (Flags c) where+  explMembers (Flags index) = liftIO $ Index.toVector index+  {-# INLINE explMembers #-}++instance HasIndex (Flags c) where+  getIndex (Flags index) = index++clear :: forall c w m. (Has w m c, Storage c ~ Flags c, MonadIO m) => SystemT w m ()+clear = do+  Flags index <- getStore @w @m @c+  liftIO $ Index.clear index
+ src/Apecs/Stores/Index.hs view
@@ -0,0 +1,85 @@+{-| An off-heap set of entity ids in a CRoaring 64-bit bitmap, freed by the garbage collector.++Stores that keep one expose it through 'HasIndex', so queries can combine them without touching the Haskell heap.+-}+module Apecs.Stores.Index+  ( Index+  , HasIndex (..)+  , new+  , insert+  , delete+  , member+  , size+  , clear+  , toVector+  , with+  , bitmapToVector+  , checked+  ) where++import Control.Exception (throwIO)+import Data.Bitmap.Roaring.FFI.Bitmap64 (Bitmap64 (..))+import Data.Bitmap.Roaring.FFI.Bitmap64 qualified as Bitmap64+import Data.Bitmap.Roaring.FFI.NullHandle qualified as NullHandle+import Data.Primitive.ByteArray (newPinnedByteArray, unsafeFreezeByteArray, withMutableByteArrayContents)+import Data.Vector.Primitive qualified as Primitive+import Data.Vector.Unboxed qualified as Unboxed+import Data.Vector.Unboxed.Base qualified as Unboxed.Base+import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, withForeignPtr)+import Foreign.Ptr (castPtr, nullPtr)+import Foreign.Storable (sizeOf)+import GHC.ForeignPtr (unsafeWithForeignPtr)++newtype Index = Index (ForeignPtr Bitmap64)++class HasIndex s where+  getIndex :: s -> Index++new :: IO Index+new = do+  Bitmap64 handle <- Bitmap64.create >>= checked "Apecs.Stores.Index.new"+  Index <$> newForeignPtr Bitmap64.finalizerFree handle++checked :: String -> Bitmap64 -> IO Bitmap64+checked function bitmap@(Bitmap64 handle)+  | handle == nullPtr = throwIO $ NullHandle.NullHandle function+  | otherwise = pure bitmap++with :: Index -> (Bitmap64 -> IO a) -> IO a+with (Index foreignPtr) action = withForeignPtr foreignPtr $ action . Bitmap64+{-# INLINE with #-}++withCall :: Index -> (Bitmap64 -> IO a) -> IO a+withCall (Index foreignPtr) action = unsafeWithForeignPtr foreignPtr $ action . Bitmap64+{-# INLINE withCall #-}++insert :: Index -> Int -> IO ()+insert index ety = withCall index $ \bitmap -> Bitmap64.add bitmap $ fromIntegral ety+{-# INLINE insert #-}++delete :: Index -> Int -> IO ()+delete index ety = withCall index $ \bitmap -> Bitmap64.remove bitmap $ fromIntegral ety+{-# INLINE delete #-}++member :: Index -> Int -> IO Bool+member index ety = withCall index $ \bitmap -> Bitmap64.contains bitmap $ fromIntegral ety+{-# INLINE member #-}++size :: Index -> IO Int+size index = withCall index $ fmap fromIntegral . Bitmap64.getCardinality+{-# INLINE size #-}++clear :: Index -> IO ()+clear index = withCall index Bitmap64.clear+{-# INLINE clear #-}++toVector :: Index -> IO (Unboxed.Vector Int)+toVector index = with index bitmapToVector+{-# INLINE toVector #-}++bitmapToVector :: Bitmap64 -> IO (Unboxed.Vector Int)+bitmapToVector bitmap = do+  count <- fromIntegral <$> Bitmap64.getCardinality bitmap+  buffer <- newPinnedByteArray $ count * sizeOf (0 :: Int)+  withMutableByteArrayContents buffer $ Bitmap64.toUint64Array bitmap . castPtr+  Unboxed.Base.V_Int . Primitive.Vector 0 count <$> unsafeFreezeByteArray buffer
+ src/Apecs/Stores/Query.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++{-| Joins over Roaring-indexed stores ('Apecs.Stores.Flags.Flags' and 'Apecs.Stores.Roaring.Roaring'), computed as bitmap operations.++Wrap a tuple in 'Every' to iterate the entities that have every component in it:++@+cmap $ \\(Every (Enemy, Health hp, _ :: Not Dead)) -> Health (hp - 1)+@++The members of an 'Every' come from intersecting the indexes and subtracting the 'Apecs.Not' ones, without visiting entities outside the result.+'count' sizes the same join without listing it.+At least one term must not be wrapped in 'Apecs.Not'.+-}+module Apecs.Stores.Query+  ( Every (..)+  , EveryStore (..)+  , Indexes (..)+  , Plan+  , count+  ) where++import Apecs.Components (NotStore (..))+import Apecs.Core (Component (..), Elem, ExplGet (..), ExplMembers (..), Has (..), SystemT)+import Apecs.Stores.Flags (Flags)+import Apecs.Stores.Index (HasIndex (..), Index)+import Apecs.Stores.Index qualified as Index+import Apecs.Stores.Roaring (Roaring)+import Control.Exception (bracket)+import Control.Monad (forM_)+import Control.Monad.IO.Class (MonadIO (..))+import Data.Bitmap.Roaring.FFI.Bitmap64 (Bitmap64)+import Data.Bitmap.Roaring.FFI.Bitmap64 qualified as Bitmap64+import Data.Vector.Unboxed qualified as Unboxed++newtype Every t = Every t++newtype EveryStore s = EveryStore s++type instance Elem (EveryStore s) = Every (Elem s)++instance (Component t) => Component (Every t) where+  type Storage (Every t) = EveryStore (Storage t)++instance (Has w m t) => Has w m (Every t) where+  getStore = EveryStore <$> getStore+  {-# INLINE getStore #-}++instance (ExplGet m s) => ExplGet m (EveryStore s) where+  explGet (EveryStore s) ety = Every <$> explGet s ety+  {-# INLINE explGet #-}+  explExists (EveryStore s) = explExists s+  {-# INLINE explExists #-}++instance (MonadIO m, Indexes s) => ExplMembers m (EveryStore s) where+  explMembers (EveryStore s) = liftIO . members $ plan s+  {-# INLINE explMembers #-}++data Plan = Plan [Index] [Index]++instance Semigroup Plan where+  Plan required excluded <> Plan required' excluded' = Plan (required <> required') (excluded <> excluded')++class Indexes s where+  plan :: s -> Plan++instance Indexes (Flags c) where+  plan flags = Plan [getIndex flags] []++instance Indexes (Roaring s) where+  plan roaring = Plan [getIndex roaring] []++instance (HasIndex s) => Indexes (NotStore s) where+  plan (NotStore s) = Plan [] [getIndex s]++instance (Indexes s) => Indexes (EveryStore s) where+  plan (EveryStore s) = plan s++instance (Indexes a, Indexes b) => Indexes (a, b) where+  plan (a, b) = plan a <> plan b++instance (Indexes a, Indexes b, Indexes c) => Indexes (a, b, c) where+  plan (a, b, c) = plan a <> plan b <> plan c++instance (Indexes a, Indexes b, Indexes c, Indexes d) => Indexes (a, b, c, d) where+  plan (a, b, c, d) = plan a <> plan b <> plan c <> plan d++count :: forall c w m. (Has w m c, Indexes (Storage c), MonadIO m) => SystemT w m Int+count = do+  store <- getStore @w @m @c+  liftIO . cardinality $ plan store++members :: Plan -> IO (Unboxed.Vector Int)+members = \case+  Plan [index] [] -> Index.toVector index+  joined -> evaluate joined Index.bitmapToVector++cardinality :: Plan -> IO Int+cardinality = \case+  Plan [index] [] -> Index.size index+  Plan [left, right] [] -> fromIntegral <$> pairwise Bitmap64.andCardinality left right+  Plan [left] [right] -> fromIntegral <$> pairwise Bitmap64.andnotCardinality left right+  joined -> evaluate joined $ fmap fromIntegral . Bitmap64.getCardinality++pairwise :: (Bitmap64 -> Bitmap64 -> IO a) -> Index -> Index -> IO a+pairwise operation left right = Index.with left $ \leftBitmap -> Index.with right $ operation leftBitmap++evaluate :: Plan -> (Bitmap64 -> IO a) -> IO a+evaluate (Plan required excluded) action = case required of+  [] -> fail "Apecs.Stores.Query: a query needs at least one term outside Not"+  first : rest -> bracket (seed first rest excluded) Bitmap64.free $ \scratch -> do+    forM_ (drop 1 rest) $ \index -> Index.with index $ Bitmap64.andInplace scratch+    forM_ (dropSeeded rest excluded) $ \index -> Index.with index $ Bitmap64.andnotInplace scratch+    action scratch+  where+    seed first rest exclusions = case (rest, exclusions) of+      (second : _, _) -> fresh $ pairwise Bitmap64.and first second+      ([], exclusion : _) -> fresh $ pairwise Bitmap64.andnot first exclusion+      ([], []) -> fresh $ Index.with first Bitmap64.copy+    dropSeeded rest exclusions = case rest of+      [] -> drop 1 exclusions+      _ -> exclusions+    fresh construct = construct >>= Index.checked "Apecs.Stores.Query.evaluate"
+ src/Apecs/Stores/Roaring.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++{-| Keeps an off-heap Roaring 'Index' of a store's members next to the store itself.++Reads go straight to the wrapped store, so @Roaring (Cache n (Map c))@ keeps the cache's lookup speed.+Members come from the index, which lets queries over several indexed stores run as bitmap operations.++Only stores that behave like a plain map can be wrapped ('Cachable'), since the index must see every write and removal.+Put @Roaring@ outside any 'Apecs.Stores.Cache'.+-}+module Apecs.Stores.Roaring+  ( Roaring (..)+  ) where++import Apecs.Core (Elem, ExplDestroy (..), ExplGet (..), ExplInit (..), ExplMembers (..), ExplSet (..))+import Apecs.Stores (Cachable)+import Apecs.Stores.Index (HasIndex (..), Index)+import Apecs.Stores.Index qualified as Index+import Control.Monad.IO.Class (MonadIO (..))++data Roaring s = Roaring {-# UNPACK #-} !Index !s++type instance Elem (Roaring s) = Elem s++instance (MonadIO m, ExplInit m s, Cachable s) => ExplInit m (Roaring s) where+  explInit = Roaring <$> liftIO Index.new <*> explInit++instance (ExplGet m s) => ExplGet m (Roaring s) where+  explGet (Roaring _ s) = explGet s+  {-# INLINE explGet #-}+  explExists (Roaring _ s) = explExists s+  {-# INLINE explExists #-}++instance (MonadIO m, ExplSet m s) => ExplSet m (Roaring s) where+  explSet (Roaring index s) ety c = do+    explSet s ety c+    liftIO $ Index.insert index ety+  {-# INLINE explSet #-}++instance (MonadIO m, ExplDestroy m s) => ExplDestroy m (Roaring s) where+  explDestroy (Roaring index s) ety = do+    explDestroy s ety+    liftIO $ Index.delete index ety+  {-# INLINE explDestroy #-}++instance (MonadIO m) => ExplMembers m (Roaring s) where+  explMembers (Roaring index _) = liftIO $ Index.toVector index+  {-# INLINE explMembers #-}++instance HasIndex (Roaring s) where+  getIndex (Roaring index _) = index
+ test/Main.hs view
@@ -0,0 +1,243 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++import Apecs (Cache, Component (..), Entity (..), Has (..), Map, Not (..), Proxy (..), System, cfold, destroy, exists, get, makeWorld, runSystem, set)+import Apecs.Core (ExplMembers, explMembers)+import Apecs.Stores.Flags (Flags)+import Apecs.Stores.Flags qualified as Flags+import Apecs.Stores.Query (Every (..), Indexes)+import Apecs.Stores.Query qualified as Query+import Apecs.Stores.Roaring (Roaring)+import Control.Monad (forM, forM_, unless)+import Control.Monad.IO.Class (liftIO)+import Data.IntMap.Strict qualified as IntMap+import Data.IntSet qualified as IntSet+import Data.List (sort)+import Data.Vector.Unboxed qualified as Unboxed+import GHC.Generics (Generic)+import System.Exit (exitFailure)+import Test.QuickCheck (Arbitrary (..), Gen, Property, Testable (..), conjoin, counterexample, isSuccess, quickCheckWithResult, stdArgs, (.&&.), (===))+import Test.QuickCheck qualified as QuickCheck+import Test.QuickCheck.Monadic (monadicIO, run)++data Flag = Flag+  deriving (Eq, Show, Generic)++instance Component Flag where+  type Storage Flag = Flags Flag++data Enemy = Enemy+  deriving (Generic)++instance Component Enemy where+  type Storage Enemy = Flags Enemy++data Dead = Dead+  deriving (Generic)++instance Component Dead where+  type Storage Dead = Flags Dead++newtype Health = Health Int+  deriving (Eq, Show)++instance Component Health where+  type Storage Health = Roaring (Cache 2 (Map Health))++makeWorld "World" [''Flag, ''Enemy, ''Dead, ''Health]++entityId :: Gen Int+entityId =+  QuickCheck.frequency+    [ (4, QuickCheck.choose (-16, 64))+    , (1, arbitrary)+    , (1, QuickCheck.elements [minBound, maxBound, -1, -2])+    ]++data Op+  = Raise Int+  | Lower Int+  deriving (Show)++instance Arbitrary Op where+  arbitrary = QuickCheck.oneof [Raise <$> entityId, Lower <$> entityId]++model :: [Op] -> IntSet.IntSet+model = foldl step IntSet.empty+  where+    step flagged = \case+      Raise ety -> IntSet.insert ety flagged+      Lower ety -> IntSet.delete ety flagged++listed :: forall c. (Has World IO c, ExplMembers IO (Storage c)) => System World [Int]+listed = do+  store <- getStore @World @IO @c+  Unboxed.toList <$> liftIO (explMembers store)++prop_flagsMatchModel :: [Op] -> [Int] -> Property+prop_flagsMatchModel ops probes = monadicIO $ do+  (memberIds, probed, folded) <- run $ do+    world <- initWorld+    flip runSystem world $ do+      forM_ ops $ \case+        Raise ety -> set (Entity ety) Flag+        Lower ety -> destroy (Entity ety) $ Proxy @Flag+      memberIds <- listed @Flag+      probed <- forM (IntSet.toList expected <> probes) $ \ety -> (,) ety <$> exists (Entity ety) (Proxy @Flag)+      folded <- cfold (\total Flag -> total + 1) (0 :: Int)+      pure (memberIds, probed, folded)+  pure $+    counterexample "members" (sort memberIds === IntSet.toAscList expected)+      .&&. counterexample "exists" (probed === [(ety, IntSet.member ety expected) | (ety, _) <- probed])+      .&&. counterexample "cfold" (folded === IntSet.size expected)+  where+    expected = model ops++prop_flagsClear :: [Int] -> Property+prop_flagsClear marked = monadicIO $ do+  (counted, memberIds, remaining, restored) <- run $ do+    world <- initWorld+    flip runSystem world $ do+      forM_ marked $ \ety -> set (Entity ety) Flag+      Flags.clear @Flag+      counted <- Query.count @Flag+      memberIds <- listed @Flag+      remaining <- or <$> forM marked (\ety -> exists (Entity ety) $ Proxy @Flag)+      forM_ marked $ \ety -> set (Entity ety) Flag+      restored <- Query.count @Flag+      pure (counted, memberIds, remaining, restored)+  pure $+    counted === 0+      .&&. memberIds === []+      .&&. remaining === False+      .&&. restored === IntSet.size (IntSet.fromList marked)++data Edit+  = SetEnemy Int+  | DropEnemy Int+  | SetDead Int+  | DropDead Int+  | SetHealth Int Int+  | DropHealth Int+  deriving (Show)++instance Arbitrary Edit where+  arbitrary =+    QuickCheck.frequency+      [ (3, SetEnemy <$> cachedId)+      , (1, DropEnemy <$> cachedId)+      , (3, SetDead <$> cachedId)+      , (1, DropDead <$> cachedId)+      , (3, SetHealth <$> cachedId <*> arbitrary)+      , (1, DropHealth <$> cachedId)+      ]+    where+      cachedId = QuickCheck.frequency [(8, QuickCheck.choose (-4, 24)), (1, entityId)] `QuickCheck.suchThat` (/= cacheVacancy)++cacheVacancy :: Int+cacheVacancy = -2++data World' = World'+  { enemies :: IntSet.IntSet+  , dead :: IntSet.IntSet+  , healths :: IntMap.IntMap Int+  }++replay :: [Edit] -> World'+replay = foldl step World'{enemies = IntSet.empty, dead = IntSet.empty, healths = IntMap.empty}+  where+    step known = \case+      SetEnemy ety -> known{enemies = IntSet.insert ety known.enemies}+      DropEnemy ety -> known{enemies = IntSet.delete ety known.enemies}+      SetDead ety -> known{dead = IntSet.insert ety known.dead}+      DropDead ety -> known{dead = IntSet.delete ety known.dead}+      SetHealth ety hp -> known{healths = IntMap.insert ety hp known.healths}+      DropHealth ety -> known{healths = IntMap.delete ety known.healths}++perform :: Edit -> System World ()+perform = \case+  SetEnemy ety -> set (Entity ety) Enemy+  DropEnemy ety -> destroy (Entity ety) $ Proxy @Enemy+  SetDead ety -> set (Entity ety) Dead+  DropDead ety -> destroy (Entity ety) $ Proxy @Dead+  SetHealth ety hp -> set (Entity ety) $ Health hp+  DropHealth ety -> destroy (Entity ety) $ Proxy @Health++data Answer = Answer [Int] Int++answer :: forall c. (Has World IO c, ExplMembers IO (Storage c), Indexes (Storage c)) => System World Answer+answer = Answer <$> listed @c <*> Query.count @c++agrees :: String -> IntSet.IntSet -> Answer -> Property+agrees name expected (Answer memberIds counted) =+  counterexample name $+    counterexample "members" (sort memberIds === IntSet.toAscList expected)+      .&&. counterexample "count" (counted === IntSet.size expected)++prop_roaringMatchesModel :: [Edit] -> [Int] -> Property+prop_roaringMatchesModel edits probes = monadicIO $ do+  (memberIds, values, probed, counted) <- run $ do+    world <- initWorld+    flip runSystem world $ do+      forM_ edits perform+      memberIds <- listed @Health+      values <- forM (IntMap.keys expected) $ \ety -> (,) ety <$> get (Entity ety)+      probed <- forM cachedProbes $ \ety -> (,) ety <$> exists (Entity ety) (Proxy @Health)+      counted <- Query.count @Health+      pure (memberIds, values, probed, counted)+  pure $+    counterexample "members" (sort memberIds === IntMap.keys expected)+      .&&. counterexample "values" (values === [(ety, Health hp) | (ety, hp) <- IntMap.toList expected])+      .&&. counterexample "exists" (probed === [(ety, IntMap.member ety expected) | ety <- cachedProbes])+      .&&. counterexample "count" (counted === IntMap.size expected)+  where+    expected = (replay edits).healths+    cachedProbes = filter (/= cacheVacancy) probes++prop_queriesMatchModel :: [Edit] -> Property+prop_queriesMatchModel edits = monadicIO $ do+  (single, pair, without, triple, mixed, tupled, healthSum) <- run $ do+    world <- initWorld+    flip runSystem world $ do+      forM_ edits perform+      single <- answer @(Every Enemy)+      pair <- answer @(Every (Enemy, Health))+      without <- answer @(Every (Enemy, Not Dead))+      triple <- answer @(Every (Enemy, Health, Dead))+      mixed <- answer @(Every (Enemy, Health, Not Dead))+      tupled <- Query.count @(Enemy, Health)+      healthSum <- cfold (\total (Every (Enemy, Health hp)) -> total + toInteger hp) 0+      pure (single, pair, without, triple, mixed, tupled, healthSum)+  pure+    . QuickCheck.checkCoverage+    . QuickCheck.cover 40 (not $ IntSet.null withHealth) "Enemy and Health overlap"+    . QuickCheck.cover 20 (not . IntSet.null $ withHealth `IntSet.difference` known.dead) "Enemy and Health overlap outside Dead"+    . QuickCheck.cover 10 (not . IntSet.null $ withHealth `IntSet.intersection` known.dead) "Enemy, Health and Dead overlap"+    $ conjoin+      [ agrees "Every Enemy" known.enemies single+      , agrees "Every (Enemy, Health)" withHealth pair+      , agrees "Every (Enemy, Not Dead)" (known.enemies `IntSet.difference` known.dead) without+      , agrees "Every (Enemy, Health, Dead)" (withHealth `IntSet.intersection` known.dead) triple+      , agrees "Every (Enemy, Health, Not Dead)" (withHealth `IntSet.difference` known.dead) mixed+      , counterexample "count (Enemy, Health)" $ tupled === IntSet.size withHealth+      , counterexample "cfold sum" $ healthSum === sum [toInteger hp | (ety, hp) <- IntMap.toList known.healths, IntSet.member ety known.enemies]+      ]+  where+    known = replay edits+    withHealth = known.enemies `IntSet.intersection` IntMap.keysSet known.healths++main :: IO ()+main = do+  results <-+    mapM+      (quickCheckWithResult stdArgs{QuickCheck.maxSuccess = 1000})+      [ property prop_flagsMatchModel+      , property prop_flagsClear+      , property prop_roaringMatchesModel+      , property prop_queriesMatchModel+      ]+  unless (all isSuccess results) exitFailure