diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,24 @@ +# Changelog for `heph-sparse-set` + +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 + +## 0.1.0.0 - 2025-06-08 + +### Added + +- Initial release of `heph-sparse-set`, a fast, mutable sparse set data structure. +- Provided `MutableSparseSet` implementations for `Unboxed`, `Storable`, and boxed types. +- Introduced amortized O(1) operations for insertions, deletions, and lookups. +- Implemented efficient iteration (`mapM_`, `ifoldM`) and intersection (`ifoldIntersectionM`). +- Included comprehensive test suite with unit tests, property-based tests, and `NoThunks` checks to ensure correctness and prevent space leaks. +- Designed with a flexible `PrimMonad` interface for use in `IO` and `ST` computations. + +### Changed + +- Explicitly marked as **NOT thread-safe**, prioritizing single-threaded performance. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ +Copyright 2025 Jeremy Nuttall + +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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,127 @@ +# heph-sparse-set + +A highly-performant, mutable sparse set implementation for Haskell. + +This library is part of the forthcoming Hephaestus rendering system, but is sufficiently general purpose for any application that needs its particular behavior. + +This library provides a mutable sparse set data structure designed for high-throughput systems where predictable, constant-time operations are critical. It is particularly well-suited for the performance demands of applications like game development (especially in ECS architectures), simulations, and other scenarios managing collections of integer-keyed data. + +The design guarantees O(1) amortized complexity for core operations by leveraging direct array indexing and cache-friendly memory layouts. + +## Features + +- **Algorithmic Guarantees**: Provides amortized O(1) complexity for all core operations: `insert`, `delete`, and `lookup`. +- **Cache-Locality & Efficiency**: `Unboxed` and `Storable` implementations are built to ensure contiguous memory layout and minimal pointer indirection. +- **Monad-Agnostic Interface**: Operates within any `PrimMonad` context, enabling its use in both `IO` and pure `ST` computations without performance degradation. +- **Efficient Iteration**: Offers iterators (`mapM_`, `ifoldM`) that operate directly on the underlying contiguous storage, avoiding the allocation of intermediate lists. +- **Tested for Correctness**: The implementation is validated by a comprehensive test suite. + +## Design & Implementation + +At its core, `heph-sparse-set` is implemented with three internal vectors to provide its performance characteristics: + +1. A **dense** vector that stores the component data itself in a tightly packed array. Iteration happens over this array. +2. An **indices** vector, also dense, that stores the entity ID for each element in the dense vector. +3. A **sparse** vector that maps entity IDs directly to their location in the dense arrays. A lookup is a simple O(1) check in this vector. + +When an element is removed, the last element from the dense arrays is swapped into the deleted element's slot (a "swap-and-pop"). This maintains the packed nature of the dense storage and ensures the O(1) time complexity for removals. + +## Performance Characteristics + +The full benchmark suite can be found in the `bench` directory and run with `cabal bench` or `stack bench`. + +The following results compare `heph-sparse-set` against `Data.IntMap.Strict` for **100,000** elements, using the default GHC garbage collector on a quiet system. The results are highly stable (R² > 0.99) and demonstrate the significant performance advantage of `heph-sparse-set` for its target workloads. + +| Operation | `heph-sparse-set` | `Data.IntMap.Strict` | Advantage | Speedup Factor | +| :----------------------- | :---------------- | :------------------- | :------------------- | :------------- | +| **Get (Existing)** | **138 μs** | 3,749 μs | `heph-sparse-set` | **~27x** | +| **Contains (Existing)** | **111 μs** | 3,788 μs | `heph-sparse-set` | **~34x** | +| **Update (Dense)** | **168 μs** | 11,290 μs | `heph-sparse-set` | **~67x** | +| **Insert (Dense, Asc)** | **1.86 ms** | 5.44 ms | `heph-sparse-set` | **~2.9x** | +| **Remove (Dense)** | **1.02 ms** | 1.81 ms | `heph-sparse-set` | **~1.8x** | +| **Intersection (50%)** | **157 μs** | 1,177 μs | `heph-sparse-set` | **~7.5x** | +| **Mixed Workload** | **868 μs** | 10,670 μs | `heph-sparse-set` | **~12x** | +| **Insert (Sparse, Asc)** | 77.23 ms | **7.67 ms** | `Data.IntMap.Strict` | **~10x** | + +### Analysis + +- **Lookups and Updates**: The core strength of `heph-sparse-set` is its true O(1) complexity for lookups, updates, and containment checks. The **~27x to ~67x speedup** is a direct result of simple array indexing versus the O(log n) tree traversal required by `IntMap`. + +- **Dense Workloads**: For densely packed entity IDs, `heph-sparse-set` is significantly faster across all operations. The **~2.9x speedup** for dense insertions highlights the efficiency of amortized O(1) appends to contiguous vectors over the allocations and rebalancing of a tree structure. + +- **Iteration and Cache Performance**: The library's advantage in iteration-heavy tasks like `Intersection` and the `Mixed Workload` showcases the benefit of its cache-friendly memory layout. Iterating over the internal dense arrays is significantly faster than the pointer chasing required to traverse the nodes of an `IntMap`. + +- **The Sparse Insertion Trade-off**: The table clearly shows the primary trade-off. `Data.IntMap.Strict` is the superior choice for workloads dominated by **sparse, ascending key insertions**, where it performs up to **10x faster**. This is because each such insert in `heph-sparse-set` can trigger a costly reallocation of the internal sparse array. Interestingly, insertions in _descending_ sparse order are much faster in `heph-sparse-set` (`~14.6 ms`) because the sparse array is allocated once to its maximum required size and then filled, avoiding repeated reallocations. + +## Usage + +Here's a basic usage example with Unboxed sets in `IO`. + +```haskell +import Data.SparseSet.Unboxed.Mutable qualified as SS + +-- An entity in our system is just an Int +type Entity = Int +type Position = (Int, Int) + +main :: IO () +main = do + -- Create a new sparse set + positions <- SS.new @Position + + -- Insert some components + SS.insert positions 10 (5, 5) -- Entity 10 has position (5, 5) + SS.insert positions 42 (1, 2) -- Entity 42 has position (1, 2) + SS.insert positions 3 (9, -4) + + -- Look up a component + maybePos <- SS.lookup positions 42 + putStrLn $ "Position of entity 42: " <> show maybePos -- Just (1,2) + + -- Overwrite an existing component + SS.insert positions 10 (6, 6) + + -- Delete a component + deletedVal <- SS.delete positions 3 + putStrLn $ "Deleted component for entity 3: " <> show deletedVal -- Just (9,-4) + + -- Check for existence + has42 <- SS.contains positions 42 -- True + putStrLn $ "Set contains 42: " <> show has42 + has3 <- SS.contains positions 3 -- False + putStrLn $ "Set contains 3: " <> show has3 + + -- Efficiently iterate over all (entity, component) pairs + putStrLn "Current members:" + SS.imapM_ (\(entity, pos) -> print (entity, pos)) positions + -- Expected output (order may vary): + -- (10,(6,6)) + -- (42,(1,2)) +``` + +## Considerations + +### Memory Consumption + +In general use, the memory consumption of this implementation will grow relative to the maximum key in the set. It is advisable to manage memory consumption deliberately: + +1. Use the `compact` method periodically to reduce memory consumption. This is an expensive operation, so a reasonable heuristic would need to be established for your specific system. +2. Use a generational entity ID, so that entity ID growth can be constrained to a reasonable degree. + +### Concurrency + +This library is intentionally not thread-safe. For concurrent use, thread safety must be provided externally. + +### Backwards Compatibility + +I took some pains to ensure that this library is reasonably backwards-compatible. However, I'm intentionally designing Hephaestus to use GHC2021, so while this library doesn't use GHC2021, it does depend on modern language extensions that constrain its compatibility. + +**Please note that you may experience performance degradation on GHC < 9.2** + +- **Minimum supported GHC**: 8.10.4 +- **Minimum supported Stackage snapshot**: lts-18.0 + +## Roadmap + +- Compacted immutable sparse sets with read-only semantics for storage +- Atomic operations or wrappers diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/bench/Bench.hs b/bench/Bench.hs new file mode 100644 --- /dev/null +++ b/bench/Bench.hs @@ -0,0 +1,400 @@ +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Redundant irrefutable pattern" #-} +module Main (main) where + +import BenchLib +import Control.DeepSeq +import Control.Monad (replicateM, void) +import Control.Monad.Primitive +import Control.Monad.State.Strict (evalState, state) +import Data.Foldable +import Data.IntMap.Strict qualified as M +import GHC.Generics (Generic) +import System.Random (StdGen, Uniform, mkStdGen, randomR) + +import Data.IORef (modifyIORef', newIORef) +import Data.SparseSet.Unboxed.Mutable (MutableSparseSet) +import Data.SparseSet.Unboxed.Mutable qualified as SS + +type TestComponent = Int +type TestEntity = Int + +-- Common sizes for benchmarks +benchmarkSizes :: [Int] +benchmarkSizes = [10_000, 100_000] + +randomSeed :: Int +randomSeed = 7113_1337 + +main :: IO () +main = defaultMain [sparseSetBenchmarks, intMapBenchmarks] + +-- Main benchmark suite entry point +sparseSetBenchmarks :: Benchmark +sparseSetBenchmarks = + bgroup + "Data.SparseSet.Unboxed.Mutable" + [ makeInsertBenchGroup "Insert_DenseIDs_Sequential_AscendingOrder" False insertSequential + , makeInsertBenchGroup "Insert_DenseIDs_Sequential_DescendingOrder" True insertSequential + , makeInsertBenchGroup "Insert_SparseIDs_Step100_AscendingOrder" False insertSparseStep100 + , makeInsertBenchGroup "Insert_SparseIDs_Step100_DescendingOrder" True insertSparseStep100 + , makeUpdateBenchGroup "Update_DenseIDs_Sequential" + , makeGetBenchGroup "Get_Existing_DenseIDs" True + , makeGetBenchGroup "Get_NonExisting_DenseIDs" False + , makeContainsBenchGroup "Contains_Existing_DenseIDs" True + , makeContainsBenchGroup "Contains_NonExisting_DenseIDs" False + , makeRemoveBenchGroup "Remove_DenseIDs_AscendingOrder" removeAscending + , makeRemoveBenchGroup "Remove_DenseIDs_DescendingOrder" removeDescending + , makeIterationBenchGroup "Iterate_DenseIDs" + , makeIntersectionBenchGroup "Iterate_Intersection" + , makeMixedBenchGroup "MixedWorkload_DenseIDs" + ] + where + insertSequential set i = SS.insert set i i + insertSparseStep100 set i = let entity = i * 100 in SS.insert set entity entity + removeAscending _ = SS.delete + removeDescending totalSize set i = SS.delete set (totalSize - 1 - i) + +-- Generic benchmark group for N inserts +makeInsertBenchGroup + :: String + -> Bool + -> (MutableSparseSet RealWorld TestComponent -> Int -> IO b) + -> Benchmark +makeInsertBenchGroup groupName desc insert = + bgroup + groupName + [ bench (show n) $ + perRunEnv + (SS.new @TestComponent) + \ ~set -> do + traverse_ (insert set) (if desc then [n - 1, n - 2 .. 0] else [0 .. n - 1]) + | n <- benchmarkSizes + ] + +-- Generic benchmark group for N updates on existing elements +makeUpdateBenchGroup :: String -> Benchmark +makeUpdateBenchGroup groupName = + bgroup + groupName + [ bench (show n ++ "_updates") $ + perRunEnv + ( do + set <- SS.new @TestComponent + for_ [0 .. n - 1] \i -> SS.insert set i i + pure set + ) + \ ~set -> do + for_ [0 .. n - 1] \i -> + SS.insert set i (i + 1) + | n <- benchmarkSizes + ] + +-- Generic benchmark group for N get operations +makeGetBenchGroup :: String -> Bool -> Benchmark +makeGetBenchGroup groupName getExisting = + bgroup + groupName + [ env + ( do + -- Setup is run once per benchmark case (e.g., for n=100) + set <- SS.new @TestComponent + forM_ [0 .. n - 1] $ \i -> SS.insert set i i + let idsToAccess = + if getExisting + then [0 .. n - 1] -- Existing IDs + else [n .. (2 * n) - 1] -- Non-existing IDs + pure (set, idsToAccess) + ) + \ ~(set, idsToAccess) -> + -- set and idsToAccess are from env + bench (show n) $ nfIO do + traverse_ (SS.lookup set) idsToAccess + | n <- benchmarkSizes + ] + +-- Generic benchmark group for N contains operations +makeContainsBenchGroup :: String -> Bool -> Benchmark +makeContainsBenchGroup groupName checkExisting = + bgroup + groupName + [ env + ( do + set <- SS.new @TestComponent + forM_ [0 .. n - 1] $ \i -> SS.insert set i i + let idsToAccess = + if checkExisting + then [0 .. n - 1] + else [n .. (2 * n) - 1] + pure (set, idsToAccess) + ) + $ \ ~(set, idsToAccess) -> + bench (show n) $ nfIO do + traverse_ (SS.contains set) idsToAccess + | n <- benchmarkSizes + ] + +-- Generic benchmark group for N removes +makeRemoveBenchGroup + :: String -> (Int -> MutableSparseSet RealWorld TestComponent -> Int -> IO b) -> Benchmark +makeRemoveBenchGroup groupName removeAction = + bgroup + groupName + [ bench (show n ++ "_removes") $ + perRunEnv + ( do + set <- SS.new @TestComponent + for_ [0 .. n - 1] $ \i -> SS.insert set i i + pure set + ) + \ ~set -> + traverse_ (removeAction n set) [0 .. n - 1] + | n <- benchmarkSizes + ] + +makeIterationBenchGroup :: String -> Benchmark +makeIterationBenchGroup groupName = + bgroup + groupName + [ env + ( do + -- Setup is run once per benchmark case + set <- SS.new @TestComponent + forM_ [0 .. n - 1] $ \i -> SS.insert set i i + ref <- newIORef 0 + pure (set, ref) + ) + \ ~(set, ref) -> + bench (show n) $ nfIO do + SS.mapM_ (\k -> modifyIORef' ref (+ k)) set + | n <- benchmarkSizes + ] + +-- Generic benchmark group for N intersection operations +makeIntersectionBenchGroup :: String -> Benchmark +makeIntersectionBenchGroup groupName = + bgroup + groupName + [ env + ( do + -- Create two sets with a 50% overlap. + setA <- SS.new @TestComponent + forM_ [0 .. n - 1] $ \i -> SS.insert setA i i + + setB <- SS.new @TestComponent + let offset = n `div` 2 + forM_ [offset .. n + offset - 1] $ \i -> SS.insert setB i i + + ref <- newIORef @Int 0 + + pure (setA, setB, ref) + ) + \ ~(setA, setB, ref) -> + bench (show n) $ nfIO do + SS.ifoldIntersectionM (\_ k _ _ -> modifyIORef' ref (+ k)) () setA setB + | n <- benchmarkSizes + ] + +-- Mixed Workload Benchmarks +data MixedOp = MIns TestEntity TestComponent | MRem TestEntity | MGet TestEntity | MCont TestEntity + deriving (Show, Generic) + +instance Uniform MixedOp + +instance NFData MixedOp + +generateMixedOps :: Int -> Int -> StdGen -> [MixedOp] +generateMixedOps numOps maxEntity = evalState (replicateM numOps genOp) + where + genOp = do + opType <- state $ randomR (1 :: Int, 4) + entity <- state $ randomR (0, maxEntity - 1) + component <- state $ randomR (0, 1000) + pure case opType of + 1 -> MIns entity component + 2 -> MRem entity + 3 -> MGet entity + 4 -> MCont entity + _ -> error "Bad operation" + +makeMixedBenchGroup :: String -> Benchmark +makeMixedBenchGroup groupName = + bgroup + groupName + [ env + (pure $ generateMixedOps n n (mkStdGen randomSeed)) + \ ~ops -> + -- maxEntity = n, fixed seed + bench (show n ++ "_ops") $ nfIO do + set <- SS.new + forM_ ops $ \case + MIns e c -> SS.insert set e c + MRem e -> void $ SS.delete set e + MGet e -> void $ SS.lookup set e + MCont e -> void $ SS.contains set e + | n <- benchmarkSizes + ] + +generateMapWithSequentialKeys :: Int -> M.IntMap TestComponent +generateMapWithSequentialKeys n = foldl' (\acc i -> M.insert i i acc) M.empty [0 .. n - 1] + +intMapBenchmarks :: Benchmark +intMapBenchmarks = + bgroup + "Data.IntMap.Strict" + [ makeMapInsertBenchGroup "Insert_DenseIDs_Sequential_Map_AscendingOrder" False (\idx _ -> (idx, idx)) + , makeMapInsertBenchGroup "Insert_DenseIDs_Sequential_Map_DesendingOrder" True (\idx _ -> (idx, idx)) + , makeMapInsertBenchGroup + "Insert_SparseIDs_Step100_Map_AscendingOrder" + False + (\idx _ -> (idx * 100, idx * 100)) + , makeMapInsertBenchGroup + "Insert_SparseIDs_Step100_Map_DescendingOrder" + True + (\idx _ -> (idx * 100, idx * 100)) + , makeMapUpdateBenchGroup "Update_DenseIDs_Sequential_Map" + , makeMapGetBenchGroup "Get_Existing_DenseIDs_Map" True + , makeMapGetBenchGroup "Get_NonExisting_DenseIDs_Map" False + , makeMapContainsBenchGroup "Contains_Existing_DenseIDs_Map" True -- Added for completeness + , makeMapContainsBenchGroup "Contains_NonExisting_DenseIDs_Map" False + , makeMapRemoveBenchGroup "Remove_DenseIDs_AscendingOrder_Map" (\_ _ entityIdx -> entityIdx) + , makeMapRemoveBenchGroup + "Remove_DenseIDs_DescendingOrder_Map" + (\_ mapSize entityIdx -> mapSize - 1 - entityIdx) + , makeMapIterationBenchGroup "Iterate_DenseIDs_Map" + , makeMapIntersectionBenchGroup "Iterate_Intersection_Map" + , makeMapMixedBenchGroup "MixedWorkload_DenseIDs_Map" + ] + +makeMapInsertBenchGroup + :: String -> Bool -> (Int -> Int -> (TestEntity, TestComponent)) -> Benchmark +makeMapInsertBenchGroup groupName desc valueGenerator = + bgroup + groupName + [ bench (show n) $ + nf + ( \size -> + foldl' + (\m i -> let (k, v) = valueGenerator i size in M.insert k v m) + M.empty + (if desc then [n - 1, n - 2 .. 0] else [0 .. n - 1]) + ) + n + | n <- benchmarkSizes + ] + +makeMapUpdateBenchGroup :: String -> Benchmark +makeMapUpdateBenchGroup groupName = + bgroup + groupName + [ env (pure (generateMapWithSequentialKeys n)) $ \ ~initialMap -> + bench (show n ++ "_updates") $ + -- For Map, an "update" is just an insert on an existing key + nf (\m -> foldl' (\currentMap i -> M.insert i (i + 1) currentMap) m [0 .. n - 1]) initialMap + | n <- benchmarkSizes + ] + +makeMapGetBenchGroup :: String -> Bool -> Benchmark +makeMapGetBenchGroup groupName getExisting = + bgroup + groupName + [ env + ( do + let initialMap = generateMapWithSequentialKeys n + let idsToAccess = + if getExisting + then [0 .. n - 1] -- Existing IDs + else [n .. (2 * n) - 1] -- Non-existing IDs + pure (initialMap, idsToAccess) + ) + $ \ ~(m, idsToAccess) -> + bench (show n) $ nf (map (`M.lookup` m)) idsToAccess + | n <- benchmarkSizes + ] + +makeMapContainsBenchGroup :: String -> Bool -> Benchmark +makeMapContainsBenchGroup groupName checkExisting = + bgroup + groupName + [ env + ( do + let initialMap = generateMapWithSequentialKeys n + let idsToAccess = + if checkExisting + then [0 .. n - 1] + else [n .. (2 * n) - 1] + pure (initialMap, idsToAccess) + ) + $ \ ~(m, idsToAccess) -> + bench (show n) $ nf (map (`M.member` m)) idsToAccess + | n <- benchmarkSizes + ] + +makeMapIterationBenchGroup :: String -> Benchmark +makeMapIterationBenchGroup groupName = + bgroup + groupName + [ env + ( do + let initialMap = generateMapWithSequentialKeys n + ref <- newIORef 0 + pure (initialMap, ref) + ) + $ \ ~(initialMap, ref) -> + bench (show n) $ nfIO do + traverse_ (\k -> modifyIORef' ref (+ k)) initialMap + | n <- benchmarkSizes + ] + +makeMapIntersectionBenchGroup :: String -> Benchmark +makeMapIntersectionBenchGroup groupName = + bgroup + groupName + [ env + ( do + -- Create two maps with the same 50% overlap. + let mapA = generateMapWithSequentialKeys n + offset = n `div` 2 + mapB = foldl' (\acc i -> M.insert i i acc) M.empty [offset .. n + offset - 1] + ref <- newIORef @Int 0 + pure (mapA, mapB, ref) + ) + \ ~(mapA, mapB, ref) -> + bench (show n) $ nfIO do + let intersectionMap = M.intersectionWithKey (\eid _ _ -> eid) mapA mapB + traverse_ (\k -> modifyIORef' ref (+ k)) intersectionMap + | n <- benchmarkSizes + ] + +makeMapRemoveBenchGroup + :: String -> (M.IntMap TestComponent -> Int -> Int -> TestEntity) -> Benchmark +makeMapRemoveBenchGroup groupName entityToRemoveGenerator = + bgroup + groupName + [ env (pure (generateMapWithSequentialKeys n)) $ \ ~initialMap -> + bench (show n ++ "_removes") $ + nf + (\m -> foldl' (\currentMap i -> M.delete (entityToRemoveGenerator m n i) currentMap) m [0 .. n - 1]) + initialMap + | n <- benchmarkSizes + ] + +makeMapMixedBenchGroup :: String -> Benchmark +makeMapMixedBenchGroup groupName = + bgroup + groupName + [ env (pure $ generateMixedOps n n (mkStdGen randomSeed)) $ \ops -> + bench (show n ++ "_ops") $ nf (runMapOps M.empty) ops + | n <- benchmarkSizes + ] + where + runMapOps :: M.IntMap TestComponent -> [MixedOp] -> M.IntMap TestComponent + runMapOps = foldl' applyMapOp + + applyMapOp :: M.IntMap TestComponent -> MixedOp -> M.IntMap TestComponent + applyMapOp currentMap op = case op of + MIns e c -> M.insert e c currentMap + MRem e -> M.delete e currentMap + MGet e -> let !_ = M.lookup e currentMap in currentMap -- Force lookup + MCont e -> let !_ = M.member e currentMap in currentMap -- Force member check diff --git a/bench/BenchLib.hs b/bench/BenchLib.hs new file mode 100644 --- /dev/null +++ b/bench/BenchLib.hs @@ -0,0 +1,33 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | Allows plug-and-play for tasty-bench and criterion +module BenchLib ( + Benchmark, + Benchmarkable, + bgroup, + defaultMain, + env, + perBatchEnv, + perRunEnv, + bench, + nf, + nfIO, + whnf, +) where + +import Control.DeepSeq +import Criterion +import Criterion.Main + +import Data.Primitive.MutVar +import Data.SparseSet.Generic.Mutable qualified as G +import Data.SparseSet.Unboxed.Mutable qualified as U + +-- | +-- __NOTE__: The definition is the same as that for MVar and IORef in `deepseq`, so the same +-- caveat applies: Only strict in reference, not in value. +instance NFData (MutVar s a) where + rnf = rwhnf + +instance (NFData (v s a)) => NFData (G.MutableSparseSet v s a) +instance NFData (U.MutableSparseSet s a) diff --git a/heph-sparse-set.cabal b/heph-sparse-set.cabal new file mode 100644 --- /dev/null +++ b/heph-sparse-set.cabal @@ -0,0 +1,149 @@ +cabal-version: 2.2 + +-- This file has been generated from package.yaml by hpack version 0.38.0. +-- +-- see: https://github.com/sol/hpack + +name: heph-sparse-set +version: 0.1.0.0 +synopsis: Really fast mutable sparse sets +description: Please see the README on GitHub at +category: Data Structures +homepage: https://github.com/jtnuttall/heph/tree/main/heph-sparse-set#readme +bug-reports: https://github.com/jtnuttall/heph/issues +author: Jeremy Nuttall +maintainer: jeremy@jeremy-nuttall.com +copyright: 2025 Jeremy Nuttall +license: BSD-3-Clause +license-file: LICENSE +build-type: Simple +tested-with: + GHC == 9.8.4 || == 9.6.5 || == 8.10.7 +extra-doc-files: + README.md + LICENSE + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/jtnuttall/heph + +library + exposed-modules: + Data.SparseSet.Generic.Mutable + Data.SparseSet.Generic.Mutable.Internal.GrowVec + Data.SparseSet.Generic.Mutable.Internal.MutableSparseArray + Data.SparseSet.Mutable + Data.SparseSet.Storable.Mutable + Data.SparseSet.Unboxed.Mutable + other-modules: + Paths_heph_sparse_set + autogen-modules: + Paths_heph_sparse_set + hs-source-dirs: + src + default-extensions: + BangPatterns + DeriveGeneric + GeneralizedNewtypeDeriving + FlexibleContexts + ImportQualifiedPost + NumericUnderscores + RankNTypes + StandaloneDeriving + TupleSections + TypeApplications + BlockArguments + DerivingStrategies + LambdaCase + RecordWildCards + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints + build-depends: + base >=4.7 && <5 + , deepseq >=1.4 && <1.6 + , primitive >=0.7 && <0.10 + , vector >=0.12.3.0 && <0.14 + default-language: Haskell2010 + +test-suite heph-sparse-set-test + type: exitcode-stdio-1.0 + main-is: Driver.hs + other-modules: + Data.SparseSet.Generic.Internal.GrowVecSpec + Data.SparseSet.Generic.Internal.MutableSparseArraySpec + Data.SparseSet.Unboxed.MutableSpec + Paths_heph_sparse_set + autogen-modules: + Paths_heph_sparse_set + hs-source-dirs: + test + default-extensions: + BangPatterns + DeriveGeneric + GeneralizedNewtypeDeriving + FlexibleContexts + ImportQualifiedPost + NumericUnderscores + RankNTypes + StandaloneDeriving + TupleSections + TypeApplications + BlockArguments + DerivingStrategies + LambdaCase + RecordWildCards + ghc-options: -Wall -Wcompat -threaded -rtsopts -with-rtsopts=-N + build-tool-depends: + tasty-discover:tasty-discover + build-depends: + base >=4.7 && <5 + , containers >=0.6.2 && <0.8 + , deepseq >=1.4 && <1.6 + , hedgehog >=1.0.4 && <1.6 + , heph-sparse-set + , nothunks >=0.1.3.0 && <0.4 + , primitive >=0.7 && <0.10 + , tasty >=1.4.1 && <1.6 + , tasty-discover >=4.2.1 && <6 + , tasty-hedgehog >=1.1 && <1.5 + , tasty-hunit ==0.10.* + , vector >=0.12.3.0 && <0.14 + default-language: Haskell2010 + +benchmark heph-sparse-set-bench + type: exitcode-stdio-1.0 + main-is: Bench.hs + other-modules: + BenchLib + Paths_heph_sparse_set + autogen-modules: + Paths_heph_sparse_set + hs-source-dirs: + bench + default-extensions: + BangPatterns + DeriveGeneric + GeneralizedNewtypeDeriving + FlexibleContexts + ImportQualifiedPost + NumericUnderscores + RankNTypes + StandaloneDeriving + TupleSections + TypeApplications + BlockArguments + DerivingStrategies + LambdaCase + RecordWildCards + ghc-options: -Wall -Wcompat -threaded -rtsopts -O2 + build-depends: + base >=4.7 && <5 + , containers + , criterion >=1.5.9 && <1.7 + , deepseq + , heph-sparse-set + , mtl >=1.2 && <2.4 + , primitive >=0.7 && <0.10 + , random >=0.3.3 && <1.3 + , vector >=0.12.3.0 && <0.14 + default-language: Haskell2010 diff --git a/src/Data/SparseSet/Generic/Mutable.hs b/src/Data/SparseSet/Generic/Mutable.hs new file mode 100644 --- /dev/null +++ b/src/Data/SparseSet/Generic/Mutable.hs @@ -0,0 +1,342 @@ +-- | +-- Description : Fast, mutable sparse sets. +-- Copyright : (c) Jeremy Nuttall, 2025 +-- License : BSD-3-Clause +-- Maintainer : jeremy@jeremy-nuttall.com +-- Stability : experimental +-- Portability : GHC +-- +-- Generic mutable sparse sets, usable in any state transformer monad. +-- +-- __This implementation is NOT thread-safe.__ Thread safety must be maintained by a whole-set +-- locking mechanism. +module Data.SparseSet.Generic.Mutable ( + MutableSparseSet, + + -- * Creation + withCapacity, + new, + + -- * Read + length, + contains, + members, + lookup, + + -- * Update + insert, + delete, + clear, + compact, + + -- * Iteration + foldM, + ifoldM, + mapM_, + imapM_, + ifoldIntersectionM, +) +where + +import Control.Monad hiding (foldM, foldM_, mapM_) +import Control.Monad.Primitive +import Data.Primitive +import Data.Typeable (Typeable) +import Data.Vector.Generic qualified as VG +import Data.Vector.Generic.Mutable qualified as MVG +import Data.Vector.Primitive.Mutable qualified as MVP +import GHC.Generics (Generic) +import Prelude hiding (length, lookup, mapM_) + +import Data.SparseSet.Generic.Mutable.Internal.GrowVec (GrowVec) +import Data.SparseSet.Generic.Mutable.Internal.GrowVec qualified as GrowVec +import Data.SparseSet.Generic.Mutable.Internal.MutableSparseArray (MutableSparseArray) +import Data.SparseSet.Generic.Mutable.Internal.MutableSparseArray qualified as MSA +import Data.Vector.Internal.Check (HasCallStack) + +data MutableSparseSet v s a = MutableSparseSet + { ssDense :: {-# UNPACK #-} !(MutVar s (GrowVec v s a)) + , ssIndices :: {-# UNPACK #-} !(MutVar s (GrowVec MVP.MVector s Int)) + , ssSparse :: {-# UNPACK #-} !(MutVar s (MutableSparseArray s)) + } + deriving (Generic, Typeable) + +-- | Create a sparse set with a given dense and sparse capacity +-- +-- It's a good idea to use this function if you have an estimate of your data requirements, +-- as it can prevent costly re-allocations as the set grows. +-- +-- @since 0.1.0.0 +withCapacity + :: forall a v m + . (PrimMonad m, MVG.MVector v a) + => Int + -- ^ Capacity for the dense set + -> Int + -- ^ Capacity for the sparse set + -> m (MutableSparseSet v (PrimState m) a) +withCapacity dc sc = + MutableSparseSet + <$> (newMutVar =<< GrowVec.withCapacity dc) + <*> (newMutVar =<< GrowVec.withCapacity dc) + <*> (newMutVar =<< MSA.withCapacity sc) +{-# INLINE withCapacity #-} + +-- | Create an empty sparse set with default capacities. +-- +-- @since 0.1.0.0 +new :: forall a v m. (PrimMonad m, MVG.MVector v a) => m (MutableSparseSet v (PrimState m) a) +new = + MutableSparseSet + <$> (newMutVar =<< GrowVec.new) + <*> (newMutVar =<< GrowVec.new) + <*> (newMutVar =<< MSA.new) +{-# INLINE new #-} + +-- | O(1) Number of elements in the set (dense) +-- +-- @since 0.1.0.0 +length :: forall a v m. (PrimMonad m) => MutableSparseSet v (PrimState m) a -> m Int +length MutableSparseSet{..} = GrowVec.length <$> readMutVar ssDense +{-# INLINE length #-} + +-- | O(1) Check whether an element is in the set +-- +-- @since 0.1.0.0 +contains :: forall a v m. (PrimMonad m) => MutableSparseSet v (PrimState m) a -> Int -> m Bool +contains MutableSparseSet{..} i = readMutVar ssSparse >>= (`MSA.contains` i) +{-# INLINE contains #-} + +-- | O(n) The members of the set in an unspecified order. +-- +-- @since 0.1.0.0 +members + :: forall w a v m. (VG.Vector v Int, PrimMonad m) => MutableSparseSet w (PrimState m) a -> m (v Int) +members MutableSparseSet{..} = fmap VG.convert . GrowVec.freeze =<< readMutVar ssIndices +{-# INLINE members #-} + +-- | O(1) Look up an element in the set +-- +-- @since 0.1.0.0 +lookup + :: forall a v m + . (PrimMonad m, MVG.MVector v a) + => MutableSparseSet v (PrimState m) a + -> Int + -> m (Maybe a) +lookup MutableSparseSet{..} i = do + mSi <- (`MSA.lookup` i) =<< readMutVar ssSparse + case mSi of + Just si -> Just <$> (readMutVar ssDense >>= (`GrowVec.unsafeRead` si)) + Nothing -> pure Nothing +{-# INLINE lookup #-} + +-- | O(1) amortized. Insert a value for a given key. +-- +-- If the key is already in the set, its value is overwritten. +-- +-- __INVARIANT__: Keys cannot be negative. An unchecked exception is +-- thrown if a negative key is added to the set. +-- +-- @since 0.1.0.0 +insert + :: forall a v m + . (HasCallStack, PrimMonad m, MVG.MVector v a) + => MutableSparseSet v (PrimState m) a + -> Int + -> a + -> m () +insert MutableSparseSet{..} i v + | i < 0 = error $ "Key cannot be negative, got: " <> show i + | otherwise = + readMutVar ssSparse >>= (`MSA.lookup` i) >>= \case + Just di -> do + dense <- readMutVar ssDense + GrowVec.unsafeWrite dense di v + Nothing -> do + dense <- readMutVar ssDense + writeMutVar ssDense =<< GrowVec.snoc dense v + sparse <- readMutVar ssSparse >>= \arr -> MSA.unsafeInsert arr i (GrowVec.length dense) + writeMutVar ssSparse sparse + writeMutVar ssIndices =<< (`GrowVec.snoc` i) =<< readMutVar ssIndices +{-# INLINE insert #-} + +-- | O(1) Delete an element from the set +-- +-- @since 0.1.0.0 +delete + :: forall a v m + . (PrimMonad m, MVG.MVector v a) + => MutableSparseSet v (PrimState m) a + -> Int + -> m (Maybe a) +delete MutableSparseSet{..} i = do + sparse <- readMutVar ssSparse + MSA.delete sparse i >>= \case + Just di -> do + dense <- readMutVar ssDense + indices <- readMutVar ssIndices + (value, dense') <- GrowVec.unsafeSwapRemove dense di + writeMutVar ssDense dense' + (_, indices') <- GrowVec.unsafeSwapRemove indices di + writeMutVar ssIndices indices' + unless (di == GrowVec.length dense - 1) do + swapped <- GrowVec.unsafeRead indices' di + writeMutVar ssSparse =<< MSA.unsafeInsert sparse swapped di + pure $ Just value + Nothing -> pure Nothing +{-# INLINE delete #-} + +-- | O(n) Clear all elements from the set. +-- +-- @since 0.1.0.0 +clear :: forall a v m. (PrimMonad m) => MutableSparseSet v (PrimState m) a -> m () +clear MutableSparseSet{..} = do + indices <- readMutVar ssIndices + sparse <- readMutVar ssSparse + GrowVec.mapM_ (MSA.unsafeDelete sparse) indices + + atomicModifyMutVar' ssDense ((,()) . GrowVec.cleared) + atomicModifyMutVar' ssIndices ((,()) . GrowVec.cleared) +{-# INLINE clear #-} + +-- | O(n) Shrink the capacity of the set to fit exactly the current number of elements. +-- +-- @since 0.1.0.0 +compact + :: forall a v m. (PrimMonad m, MVG.MVector v a) => MutableSparseSet v (PrimState m) a -> m () +compact MutableSparseSet{..} = do + writeMutVar ssDense =<< GrowVec.compact =<< readMutVar ssDense + indices <- readMutVar ssIndices + indices' <- GrowVec.compact indices + writeMutVar ssIndices indices' + GrowVec.maximum indices >>= \case + Nothing -> pure () + Just maxIndex -> do + sparse <- readMutVar ssSparse + writeMutVar ssSparse =<< MSA.unsafeCompactTo sparse (maxIndex + 1) +{-# INLINE compact #-} + +-- | O(n) Iterate over the values of the set with an accumulator. +-- +-- @since 0.1.0.0 +foldM + :: (PrimMonad m, MVG.MVector v a) + => (b -> a -> m b) + -> b + -> MutableSparseSet v (PrimState m) a + -> m b +foldM f initAcc MutableSparseSet{..} = do + denseGV <- readMutVar ssDense + let !len = GrowVec.length denseGV + go !idx !acc + | idx >= len = pure acc + | otherwise = do + component <- GrowVec.unsafeRead denseGV idx + newAcc <- f acc component + go (idx + 1) newAcc + + go 0 initAcc +{-# INLINE foldM #-} + +-- | O(n) Iterate over the keys and values of the set with an accumulator. +-- +-- @since 0.1.0.0 +ifoldM + :: (PrimMonad m, MVG.MVector v a) + => (b -> (Int, a) -> m b) + -> b + -> MutableSparseSet v (PrimState m) a + -> m b +ifoldM f initAcc MutableSparseSet{..} = do + denseGV <- readMutVar ssDense + indicesGV <- readMutVar ssIndices + let !len = GrowVec.length denseGV + go !idx !acc + | idx >= len = pure acc + | otherwise = do + entity <- GrowVec.unsafeRead indicesGV idx + component <- GrowVec.unsafeRead denseGV idx + newAcc <- f acc (entity, component) + go (idx + 1) newAcc + + go 0 initAcc +{-# INLINE ifoldM #-} + +-- | O(n) Iterate over the values of the set. +-- +-- @since 0.1.0.0 +mapM_ + :: (PrimMonad m, MVG.MVector v a) + => (a -> m ()) + -> MutableSparseSet v (PrimState m) a + -> m () +mapM_ f MutableSparseSet{..} = do + denseGV <- readMutVar ssDense + let !len = GrowVec.length denseGV + go !idx + | idx >= len = pure () + | otherwise = do + component <- GrowVec.unsafeRead denseGV idx + f component + go (idx + 1) + go 0 +{-# INLINE mapM_ #-} + +-- | O(n) Iterate over the keys and values of the set. +-- +-- @since 0.1.0.0 +imapM_ + :: (PrimMonad m, MVG.MVector v a) + => ((Int, a) -> m ()) + -> MutableSparseSet v (PrimState m) a + -> m () +imapM_ f MutableSparseSet{..} = do + denseGV <- readMutVar ssDense + indicesGV <- readMutVar ssIndices + let !len = GrowVec.length denseGV + go !idx + | idx >= len = pure () + | otherwise = do + entity <- GrowVec.unsafeRead indicesGV idx + component <- GrowVec.unsafeRead denseGV idx + f (entity, component) + go (idx + 1) + go 0 +{-# INLINE imapM_ #-} + +-- | O(min(n, m)) Iterate over the intersection of two sets with an accumulator. +-- +-- The order of the arguments does not matter - the smaller of the two sets is +-- selected as the iteratee. +-- +-- @since 0.1.0.0 +ifoldIntersectionM + :: (PrimMonad m, MVG.MVector v a, MVG.MVector v b) + => (c -> Int -> a -> b -> m c) + -- ^ Accumulator + -> c + -- ^ Initial value + -> MutableSparseSet v (PrimState m) a + -- ^ Set A + -> MutableSparseSet v (PrimState m) b + -- ^ Set B + -> m c +ifoldIntersectionM f c a b = do + la <- length a + lb <- length b + + if la <= lb + then ifoldM (goLookupB b) c a + else ifoldM (goLookupA a) c b + where + goLookupB otherSetB acc (entity, componentA) = + lookup otherSetB entity >>= \case + Nothing -> pure acc + Just componentB -> f acc entity componentA componentB + + goLookupA otherSetA acc (entity, componentB) = + lookup otherSetA entity >>= \case + Nothing -> pure acc + Just componentA -> f acc entity componentA componentB +{-# INLINE ifoldIntersectionM #-} diff --git a/src/Data/SparseSet/Generic/Mutable/Internal/GrowVec.hs b/src/Data/SparseSet/Generic/Mutable/Internal/GrowVec.hs new file mode 100644 --- /dev/null +++ b/src/Data/SparseSet/Generic/Mutable/Internal/GrowVec.hs @@ -0,0 +1,181 @@ +-- | +-- Description : A generic growable mutable vector with O(1) amortized append. +-- Copyright : (c) Jeremy Nuttall, 2025 +-- License : BSD-3-Clause +-- Maintainer : jeremy@jeremy-nuttall.com +-- Stability : experimental +-- Portability : GHC +-- +-- __WARNING:__ The functions in this module are generally unchecked and unsafe. Be careful to understand +-- and maintain invariants if using them. Misuse may result in undefined behavior. +-- +-- Internal modules can change without warning between minor versions. +module Data.SparseSet.Generic.Mutable.Internal.GrowVec ( + GrowVec, + withCapacity, + new, + length, + capacity, + snoc, + readMaybe, + unsafeRead, + maximum, + unsafeWrite, + unsafeSwapRemove, + mapM_, + cleared, + compact, + freeze, + unsafeFreeze, +) +where + +import Control.DeepSeq (NFData) +import Control.Monad.Primitive +import Data.Typeable (Typeable) +import Data.Vector.Generic qualified as VG +import Data.Vector.Generic.Mutable qualified as VGM +import GHC.Generics (Generic) +import Prelude hiding (length, mapM_, maximum) + +data GrowVec v s a = GrowVec {-# UNPACK #-} !Int (v s a) + deriving (Show, Generic, Typeable) + +instance (NFData (v s a)) => NFData (GrowVec v s a) + +-- | Create a new, empty vector with the given capacity +-- +-- @since 0.1.0.0 +withCapacity :: forall a v m. (PrimMonad m, VGM.MVector v a) => Int -> m (GrowVec v (PrimState m) a) +withCapacity c = GrowVec 0 <$> VGM.new (withMinCapacity c) +{-# INLINE withCapacity #-} + +-- | Create a new, empty vector with a default capcity +-- +-- @since 0.1.0.0 +new :: forall a v m. (PrimMonad m, VGM.MVector v a) => m (GrowVec v (PrimState m) a) +new = GrowVec 0 <$> VGM.new 16 +{-# INLINE new #-} + +-- | O(1) The logical length of the vector. +length :: forall a v s. GrowVec v s a -> Int +length (GrowVec l _) = l +{-# INLINE length #-} + +-- | O(1) The capacity of the vector. +capacity :: (VGM.MVector v a) => GrowVec v s a -> Int +capacity (GrowVec _ v) = VGM.length v +{-# INLINE capacity #-} + +-- | Calculate the additional number of elements given the current length. +-- +-- __INVARIANT__: length must be >= 2 +-- +-- @since 0.1.0.0 +growthFactor :: Int -> Int +growthFactor l = (l `quot` 2) * 3 +{-# INLINE growthFactor #-} + +-- | O(1) amortized. Append to the vector, reallocating and copying if necessary. +-- +-- Since this can't be done in-place, you must use the resulting vector in further computations. +-- +-- @since 0.1.0.0 +snoc + :: (VGM.MVector v a, PrimMonad m) => GrowVec v (PrimState m) a -> a -> m (GrowVec v (PrimState m) a) +snoc gv a = do + gv' <- grow gv + unsafeWrite gv' (length gv) a + pure gv' + where + grow (GrowVec l v) + | capacity gv <= l = GrowVec (l + 1) <$> VGM.grow v (growthFactor l) + | otherwise = pure $ GrowVec (l + 1) v +{-# INLINE snoc #-} + +readMaybe + :: forall a m v. (PrimMonad m, VGM.MVector v a) => GrowVec v (PrimState m) a -> Int -> m (Maybe a) +readMaybe (GrowVec l v) i + | l < 0 || i >= l = pure Nothing + | otherwise = Just <$> VGM.unsafeRead v i +{-# INLINE readMaybe #-} + +-- | O(1) Read from a position in the vector. This position must be less than the length of the vector. This is not checked. +-- +-- @since 0.1.0.0 +unsafeRead + :: forall a m v. (PrimMonad m, VGM.MVector v a) => GrowVec v (PrimState m) a -> Int -> m a +unsafeRead (GrowVec _ v) = VGM.unsafeRead v +{-# INLINE unsafeRead #-} + +-- | O(n) The maximum value in the vector. Useful for compaction. +-- +-- @since 0.1.0.0 +maximum + :: (PrimMonad m, VGM.MVector v a, Ord a, Bounded a) => GrowVec v (PrimState m) a -> m (Maybe a) +maximum (GrowVec l v) + | l <= 0 = pure Nothing + | otherwise = Just <$> VGM.foldl' max minBound (VGM.unsafeSlice 0 l v) +{-# INLINE maximum #-} + +-- | O(1) Write to a position in the vector. This position must be less than the length of the vector. This is not checked. +-- +-- @since 0.1.0.0 +unsafeWrite + :: forall a m v. (PrimMonad m, VGM.MVector v a) => GrowVec v (PrimState m) a -> Int -> a -> m () +unsafeWrite (GrowVec _ v) = VGM.unsafeWrite v +{-# INLINE unsafeWrite #-} + +-- | O(1) Swap-and-pop an element in the vector +-- +-- @since 0.1.0.0 +unsafeSwapRemove + :: forall a m v + . (PrimMonad m, VGM.MVector v a) + => GrowVec v (PrimState m) a + -> Int + -> m (a, GrowVec v (PrimState m) a) +unsafeSwapRemove (GrowVec l v) i = do + old <- VGM.read v i + VGM.swap v i (l - 1) + pure (old, GrowVec (l - 1) v) +{-# INLINE unsafeSwapRemove #-} + +mapM_ :: (PrimMonad m, VGM.MVector v a) => (a -> m b) -> GrowVec v (PrimState m) a -> m () +mapM_ f (GrowVec l v) = VGM.mapM_ f (VGM.unsafeSlice 0 l v) +{-# INLINE mapM_ #-} + +-- | O(1) Create a new, empty vector by setting logical length to 0. This does not change the +-- underlying vector in any way. +-- +-- @since 0.1.0.0 +cleared :: forall a s v. GrowVec v s a -> GrowVec v s a +cleared (GrowVec _ v) = GrowVec 0 v +{-# INLINE cleared #-} + +-- | O(n) Shrink the vector so that its capacity matches its current length +-- +-- @since 0.1.0.0 +compact + :: (VGM.MVector v a, PrimMonad m) => GrowVec v (PrimState m) a -> m (GrowVec v (PrimState m) a) +compact gv@(GrowVec l v) + | capacity gv == l = pure gv + | otherwise = do + let l' = withMinCapacity l + v' <- VGM.clone (VGM.unsafeSlice 0 l' v) + pure (GrowVec l v') + +freeze :: (PrimMonad m, VG.Vector v a) => GrowVec (VG.Mutable v) (PrimState m) a -> m (v a) +freeze (GrowVec l v) = VG.freeze (VGM.unsafeSlice 0 l v) +{-# INLINE freeze #-} + +unsafeFreeze :: (PrimMonad m, VG.Vector v a) => GrowVec (VG.Mutable v) (PrimState m) a -> m (v a) +unsafeFreeze (GrowVec l v) = VG.unsafeFreeze (VGM.unsafeSlice 0 l v) +{-# INLINE unsafeFreeze #-} + +-------------------------------------------------------------------------------- +-- Utilities +-------------------------------------------------------------------------------- +withMinCapacity :: Int -> Int +withMinCapacity c = max c 4 +{-# INLINE withMinCapacity #-} diff --git a/src/Data/SparseSet/Generic/Mutable/Internal/MutableSparseArray.hs b/src/Data/SparseSet/Generic/Mutable/Internal/MutableSparseArray.hs new file mode 100644 --- /dev/null +++ b/src/Data/SparseSet/Generic/Mutable/Internal/MutableSparseArray.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE PatternSynonyms #-} + +-- | +-- Description : Mutable sparse arrays, suitable for sparse set implementation. +-- Copyright : (c) Jeremy Nuttall, 2025 +-- License : BSD-3-Clause +-- Maintainer : jeremy@jeremy-nuttall.com +-- Stability : experimental +-- Portability : GHC +-- +-- __WARNING:__ The functions in this module are generally unchecked and unsafe. Be careful to understand +-- and maintain invariants if using them. Misuse may result in undefined behavior. +-- +-- Internal modules can change without warning between minor versions. +module Data.SparseSet.Generic.Mutable.Internal.MutableSparseArray ( + MutableSparseArray, + withCapacity, + new, + contains, + lookup, + unsafeInsert, + delete, + unsafeDelete, + clear, + unsafeCompactTo, + freeze, + unsafeFreeze, +) +where + +import Control.DeepSeq (NFData) +import Control.Monad (when) +import Control.Monad.Primitive +import Data.Maybe (isJust) +import Data.Typeable (Typeable) +import Data.Vector.Generic.Mutable qualified as VGM +import Data.Vector.Primitive qualified as VP +import Data.Vector.Primitive.Mutable qualified as VPM +import GHC.Generics (Generic) +import Prelude hiding (lookup, maximum) + +pattern ABSURD :: Int +pattern ABSURD = -1 + +-- | Mutable sparse integer array parameterized by its state token. +-- +-- @since 0.1.0.0 +newtype MutableSparseArray s = MutableSparseArray + {getSparseArray :: VPM.MVector s Int} + deriving newtype (NFData) + deriving stock (Generic, Typeable) + +-- | Create a new, empty array from a given capacity. +-- +-- @since 0.1.0.0 +withCapacity :: (PrimMonad m) => Int -> m (MutableSparseArray (PrimState m)) +withCapacity rc = stToPrim do + let c = max rc 4 + arr <- VPM.new c + when (c > 0) $ fillArray 0 c arr + pure $ MutableSparseArray arr +{-# INLINE withCapacity #-} + +-- | Create a new, empty array. +-- +-- @since 0.1.0.0 +new :: (PrimMonad m) => m (MutableSparseArray (PrimState m)) +new = withCapacity 32 +{-# INLINE new #-} + +contains :: (PrimMonad m) => MutableSparseArray (PrimState m) -> Int -> m Bool +contains arr i = isJust <$> lookup arr i +{-# INLINE contains #-} + +lookup :: (PrimMonad m) => MutableSparseArray (PrimState m) -> Int -> m (Maybe Int) +#if MIN_VERSION_vector(0,13,0) +lookup (MutableSparseArray arr) i = (>>= msaReprToMaybe) <$> VPM.readMaybe arr i +#else +lookup (MutableSparseArray arr) i + | i < 0 || i >= VPM.length arr = pure Nothing + | otherwise = msaReprToMaybe <$> VPM.unsafeRead arr i +#endif +{-# INLINE lookup #-} + +unsafeInsert + :: (PrimMonad m) + => MutableSparseArray (PrimState m) + -> Int + -> Int + -> m (MutableSparseArray (PrimState m)) +unsafeInsert (MutableSparseArray arr) i v + | i < 0 = error $ "Negative index " <> show i + | otherwise = do + let len = VPM.length arr + growBy = max (i + 1) ((len `quot` 2) * 3) + mArr <- + if i >= len + then do + r <- VPM.unsafeGrow arr growBy + fillArray len growBy r + pure r + else pure arr + + VPM.unsafeWrite mArr i v + pure $ MutableSparseArray mArr +{-# INLINE unsafeInsert #-} + +delete :: (PrimMonad m) => MutableSparseArray (PrimState m) -> Int -> m (Maybe Int) +delete (MutableSparseArray arr) i + | i < 0 || i >= VPM.length arr = pure Nothing + | otherwise = msaReprToMaybe <$> VPM.unsafeExchange arr i ABSURD +{-# INLINE delete #-} + +-- | Currently checks that the index is not negative, but this may change in the future +-- +-- @since 0.1.0.0 +unsafeDelete :: (PrimMonad m) => MutableSparseArray (PrimState m) -> Int -> m (Maybe Int) +unsafeDelete (MutableSparseArray arr) i + | i < 0 = error $ "Negative index " <> show i + | otherwise = msaReprToMaybe <$> VPM.unsafeExchange arr i ABSURD +{-# INLINE unsafeDelete #-} + +clear :: (PrimMonad m) => MutableSparseArray (PrimState m) -> m () +clear (MutableSparseArray arr) = VPM.set arr ABSURD +{-# INLINE clear #-} + +unsafeCompactTo + :: (PrimMonad m) => MutableSparseArray (PrimState m) -> Int -> m (MutableSparseArray (PrimState m)) +unsafeCompactTo (MutableSparseArray arr) len + | len < 0 = error "Cannot compact to negative capacity" + | len >= VPM.length arr = pure $ MutableSparseArray arr + | otherwise = MutableSparseArray <$> VPM.clone (VPM.slice 0 len arr) +{-# INLINE unsafeCompactTo #-} + +freeze :: (PrimMonad m) => MutableSparseArray (PrimState m) -> m (VP.Vector Int) +freeze (MutableSparseArray arr) = VP.freeze arr +{-# INLINE freeze #-} + +unsafeFreeze :: (PrimMonad m) => MutableSparseArray (PrimState m) -> m (VP.Vector Int) +unsafeFreeze (MutableSparseArray arr) = VP.unsafeFreeze arr +{-# INLINE unsafeFreeze #-} + +-------------------------------------------------------------------------------- +-- Utilities +-------------------------------------------------------------------------------- +msaReprToMaybe :: Int -> Maybe Int +msaReprToMaybe v + | v <= ABSURD = Nothing + | otherwise = Just v +{-# INLINE msaReprToMaybe #-} + +fillArray :: (PrimMonad m, VGM.MVector v Int) => Int -> Int -> v (PrimState m) Int -> m () +fillArray len growBy arr = stToPrim $ VGM.basicSet (VGM.basicUnsafeSlice len growBy arr) ABSURD +{-# INLINE fillArray #-} diff --git a/src/Data/SparseSet/Mutable.hs b/src/Data/SparseSet/Mutable.hs new file mode 100644 --- /dev/null +++ b/src/Data/SparseSet/Mutable.hs @@ -0,0 +1,216 @@ +{-# LANGUAGE CPP #-} + +-- | +-- Description : Fast, mutable sparse sets. +-- Copyright : (c) Jeremy Nuttall, 2025 +-- License : BSD-3-Clause +-- Maintainer : jeremy@jeremy-nuttall.com +-- Stability : experimental +-- Portability : GHC +-- +-- Boxed, strict mutable sparse sets. Prefer Storable or Unboxed sparse sets where possible as they are +-- significantly more performant. +-- +-- All inserted values are forced to WHNF. Performance is likely to be better with vector >= 0.13.2.0 +-- +-- __This implementation is NOT thread-safe.__ Thread safety must be maintained by a whole-set +-- locking mechanism. +module Data.SparseSet.Mutable ( + MutableSparseSet, + IOMutableSparseSet, + STMutableSparseSet, + + -- * Creation + withCapacity, + new, + + -- * Read + length, + contains, + members, + lookup, + + -- * Update + insert, + delete, + clear, + compact, + + -- * Iteration + foldM, + ifoldM, + mapM_, + imapM_, + ifoldIntersectionM, +) +where + +import Control.Monad.Primitive +import Data.Typeable (Typeable) +import GHC.Generics (Generic) +import Prelude hiding (length, lookup, mapM_) + +#if MIN_VERSION_vector(0,13,2) +import Data.Vector.Strict qualified as V +import Data.Vector.Strict.Mutable qualified as MV +#else +import Data.Vector qualified as V +import Data.Vector.Mutable qualified as MV +#endif + +import Data.SparseSet.Generic.Mutable qualified as G + +newtype MutableSparseSet s a = MSS (G.MutableSparseSet MV.MVector s a) + deriving stock (Generic, Typeable) + +type IOMutableSparseSet = MutableSparseSet RealWorld +type STMutableSparseSet s = MutableSparseSet s + +-- | Create a sparse set with a given dense and sparse capacity +-- +-- It's a good idea to use this function if you have an estimate of your data requirements, +-- as it can prevent costly re-allocations as the set grows. +-- +-- @since 0.1.0.0 +withCapacity + :: (PrimMonad m) + => Int + -- ^ Capacity for the dense set + -> Int + -- ^ Capacity for the sparse set + -> m (MutableSparseSet (PrimState m) a) +withCapacity dc sc = MSS <$> G.withCapacity dc sc + +-- | Create an empty sparse set with default capacities +-- +-- @since 0.1.0.0 +new :: forall a m. (PrimMonad m) => m (MutableSparseSet (PrimState m) a) +new = MSS <$> G.new +{-# INLINE new #-} + +-- | O(1) Number of elements in the set (dense) +-- +-- @since 0.1.0.0 +length :: forall a m. (PrimMonad m) => MutableSparseSet (PrimState m) a -> m Int +length (MSS g) = G.length g +{-# INLINE length #-} + +-- | O(1) Check whether an element is in the set +-- +-- @since 0.1.0.0 +contains :: (PrimMonad m) => MutableSparseSet (PrimState m) a -> Int -> m Bool +contains (MSS g) = G.contains g +{-# INLINE contains #-} + +-- | O(n) The members of the set in an unspecified order. +-- +-- @since 0.1.0.0 +members :: (PrimMonad m) => MutableSparseSet (PrimState m) a -> m (V.Vector Int) +members (MSS g) = G.members g +{-# INLINE members #-} + +-- | O(1) Look up an element in the set +-- +-- @since 0.1.0.0 +lookup :: (PrimMonad m) => MutableSparseSet (PrimState m) a -> Int -> m (Maybe a) +lookup (MSS g) = G.lookup g +{-# INLINE lookup #-} + +-- | O(1) amortized. Insert a value for a given key. +-- +-- If the key is already in the set, its value is overwritten. +-- +-- __INVARIANT__: Keys cannot be negative. An unchecked exception is +-- thrown if a negative key is added to the set. +-- +-- @since 0.1.0.0 +insert :: (PrimMonad m) => MutableSparseSet (PrimState m) a -> Int -> a -> m () +#if MIN_VERSION_vector(0,13,2) +insert (MSS g) = G.insert g +#else +insert (MSS g) i !v = G.insert g i v +#endif +{-# INLINE insert #-} + +-- | O(1) Delete an element from the set +-- +-- @since 0.1.0.0 +delete :: (PrimMonad m) => MutableSparseSet (PrimState m) a -> Int -> m (Maybe a) +delete (MSS g) = G.delete g +{-# INLINE delete #-} + +-- | O(n) Clear all elements from the set +-- +-- @since 0.1.0.0 +clear :: (PrimMonad m) => MutableSparseSet (PrimState m) a -> m () +clear (MSS g) = G.clear g +{-# INLINE clear #-} + +-- | O(n) Shrink the capacity of the set to fit exactly the current number of elements. +-- +-- @since 0.1.0.0 +compact :: (PrimMonad m) => MutableSparseSet (PrimState m) a -> m () +compact (MSS g) = G.compact g +{-# INLINE compact #-} + +-- | O(n) Fold over the values of the set. +-- +-- @since 0.1.0.0 +foldM + :: (PrimMonad m) + => (b -> a -> m b) + -> b + -> MutableSparseSet (PrimState m) a + -> m b +foldM f initAcc (MSS g) = G.foldM f initAcc g +{-# INLINE foldM #-} + +-- | O(n) Fold over the keys and values of the set. +-- +-- @since 0.1.0.0 +ifoldM + :: (PrimMonad m) + => (b -> (Int, a) -> m b) + -> b + -> MutableSparseSet (PrimState m) a + -> m b +ifoldM f initAcc (MSS g) = G.ifoldM f initAcc g +{-# INLINE ifoldM #-} + +-- | O(n) Iterate over the values of the set. +-- +-- @since 0.1.0.0 +mapM_ + :: (PrimMonad m) + => (a -> m ()) -- Action to perform + -> MutableSparseSet (PrimState m) a + -> m () +mapM_ f (MSS g) = G.mapM_ f g +{-# INLINE mapM_ #-} + +-- | O(n) Iterate over the keys and values of the set. +-- +-- @since 0.1.0.0 +imapM_ + :: (PrimMonad m) + => ((Int, a) -> m ()) -- Action to perform + -> MutableSparseSet (PrimState m) a + -> m () +imapM_ f (MSS g) = G.imapM_ f g +{-# INLINE imapM_ #-} + +-- | O(min(n, m)) Iterate over the intersection of two sets with an accumulator. +-- +-- The order of the arguments does not matter - the smaller of the two sets is +-- selected as the iteratee. +-- +-- @since 0.1.0.0 +ifoldIntersectionM + :: (PrimMonad m) + => (c -> Int -> a -> b -> m c) + -> c + -> MutableSparseSet (PrimState m) a + -> MutableSparseSet (PrimState m) b + -> m c +ifoldIntersectionM acc c (MSS a) (MSS b) = G.ifoldIntersectionM acc c a b +{-# INLINE ifoldIntersectionM #-} diff --git a/src/Data/SparseSet/Storable/Mutable.hs b/src/Data/SparseSet/Storable/Mutable.hs new file mode 100644 --- /dev/null +++ b/src/Data/SparseSet/Storable/Mutable.hs @@ -0,0 +1,198 @@ +-- | +-- Description : Fast, mutable sparse sets. +-- Copyright : (c) Jeremy Nuttall, 2025 +-- License : BSD-3-Clause +-- Maintainer : jeremy@jeremy-nuttall.com +-- Stability : experimental +-- Portability : GHC +-- +-- __This implementation is NOT thread-safe.__ Thread safety must be maintained by a whole-set +-- locking mechanism. +module Data.SparseSet.Storable.Mutable ( + MutableSparseSet, + IOMutableSparseSet, + STMutableSparseSet, + + -- * Creation + withCapacity, + new, + + -- * Read + length, + contains, + members, + lookup, + + -- * Update + insert, + delete, + clear, + compact, + + -- * Iteration + foldM, + ifoldM, + mapM_, + imapM_, + ifoldIntersectionM, +) +where + +import Control.Monad.Primitive +import Data.Typeable (Typeable) +import Data.Vector.Storable qualified as VS +import GHC.Generics (Generic) +import Prelude hiding (length, lookup, mapM_) + +import Data.SparseSet.Generic.Mutable qualified as G + +newtype MutableSparseSet s a = MSS (G.MutableSparseSet VS.MVector s a) + deriving stock (Generic, Typeable) + +type IOMutableSparseSet = MutableSparseSet RealWorld +type STMutableSparseSet s = MutableSparseSet s + +-- | Create a sparse set with a given dense and sparse capacity +-- +-- It's a good idea to use this function if you have an estimate of your data requirements, +-- as it can prevent costly re-allocations as the set grows. +-- +-- @since 0.1.0.0 +withCapacity + :: (PrimMonad m, VS.Storable a) + => Int + -- ^ Capacity for the dense set + -> Int + -- ^ Capacity for the sparse set + -> m (MutableSparseSet (PrimState m) a) +withCapacity dc sc = MSS <$> G.withCapacity dc sc + +-- | Create an empty sparse set with default capacities +-- +-- @since 0.1.0.0 +new :: forall a m. (PrimMonad m, VS.Storable a) => m (MutableSparseSet (PrimState m) a) +new = MSS <$> G.new +{-# INLINE new #-} + +-- | O(1) Number of elements in the set (dense) +-- +-- @since 0.1.0.0 +length :: forall a m. (PrimMonad m) => MutableSparseSet (PrimState m) a -> m Int +length (MSS g) = G.length g +{-# INLINE length #-} + +-- | O(1) Check whether an element is in the set +-- +-- @since 0.1.0.0 +contains :: (PrimMonad m) => MutableSparseSet (PrimState m) a -> Int -> m Bool +contains (MSS g) = G.contains g +{-# INLINE contains #-} + +-- | O(n) The members of the set in an unspecified order. +-- +-- @since 0.1.0.0 +members :: (PrimMonad m) => MutableSparseSet (PrimState m) a -> m (VS.Vector Int) +members (MSS g) = G.members g +{-# INLINE members #-} + +-- | O(1) Look up an element in the set +-- +-- @since 0.1.0.0 +lookup :: (PrimMonad m, VS.Storable a) => MutableSparseSet (PrimState m) a -> Int -> m (Maybe a) +lookup (MSS g) = G.lookup g +{-# INLINE lookup #-} + +-- | O(1) amortized. Insert a value for a given key. +-- +-- If the key is already in the set, its value is overwritten. +-- +-- __INVARIANT__: Keys cannot be negative. An unchecked exception is +-- thrown if a negative key is added to the set. +-- +-- @since 0.1.0.0 +insert :: (PrimMonad m, VS.Storable a) => MutableSparseSet (PrimState m) a -> Int -> a -> m () +insert (MSS g) = G.insert g +{-# INLINE insert #-} + +-- | O(1) Delete an element from the set +-- +-- @since 0.1.0.0 +delete :: (PrimMonad m, VS.Storable a) => MutableSparseSet (PrimState m) a -> Int -> m (Maybe a) +delete (MSS g) = G.delete g +{-# INLINE delete #-} + +-- | O(1) Clear all elements from the set +-- +-- @since 0.1.0.0 +clear :: (PrimMonad m) => MutableSparseSet (PrimState m) a -> m () +clear (MSS g) = G.clear g +{-# INLINE clear #-} + +-- | O(n) Shrink the capacity of the set to fit exactly the current number of elements. +-- +-- @since 0.1.0.0 +compact :: (PrimMonad m, VS.Storable a) => MutableSparseSet (PrimState m) a -> m () +compact (MSS g) = G.compact g +{-# INLINE compact #-} + +-- | O(n) Fold over the values of the set. +-- +-- @since 0.1.0.0 +foldM + :: (PrimMonad m, VS.Storable a) + => (b -> a -> m b) + -> b + -> MutableSparseSet (PrimState m) a + -> m b +foldM f initAcc (MSS g) = G.foldM f initAcc g +{-# INLINE foldM #-} + +-- | O(n) Fold over the keys and values of the set. +-- +-- @since 0.1.0.0 +ifoldM + :: (PrimMonad m, VS.Storable a) + => (b -> (Int, a) -> m b) + -> b + -> MutableSparseSet (PrimState m) a + -> m b +ifoldM f initAcc (MSS g) = G.ifoldM f initAcc g +{-# INLINE ifoldM #-} + +-- | O(n) Iterate over the values of the set. +-- +-- @since 0.1.0.0 +mapM_ + :: (PrimMonad m, VS.Storable a) + => (a -> m ()) -- Action to perform + -> MutableSparseSet (PrimState m) a + -> m () +mapM_ f (MSS g) = G.mapM_ f g +{-# INLINE mapM_ #-} + +-- | O(n) Iterate over the keys and values of the set. +-- +-- @since 0.1.0.0 +imapM_ + :: (PrimMonad m, VS.Storable a) + => ((Int, a) -> m ()) -- Action to perform + -> MutableSparseSet (PrimState m) a + -> m () +imapM_ f (MSS g) = G.imapM_ f g +{-# INLINE imapM_ #-} + +-- | O(min(n, m)) Iterate over the intersection of two sets with an accumulator. +-- +-- The order of the arguments does not matter - the smaller of the two sets is +-- selected as the iteratee. +-- +-- @since 0.1.0.0 +ifoldIntersectionM + :: (PrimMonad m, VS.Storable a, VS.Storable b) + => (c -> Int -> a -> b -> m c) + -> c + -> MutableSparseSet (PrimState m) a + -> MutableSparseSet (PrimState m) b + -> m c +ifoldIntersectionM acc c (MSS a) (MSS b) = G.ifoldIntersectionM acc c a b +{-# INLINE ifoldIntersectionM #-} diff --git a/src/Data/SparseSet/Unboxed/Mutable.hs b/src/Data/SparseSet/Unboxed/Mutable.hs new file mode 100644 --- /dev/null +++ b/src/Data/SparseSet/Unboxed/Mutable.hs @@ -0,0 +1,198 @@ +-- | +-- Description : Fast, mutable sparse sets. +-- Copyright : (c) Jeremy Nuttall, 2025 +-- License : BSD-3-Clause +-- Maintainer : jeremy@jeremy-nuttall.com +-- Stability : experimental +-- Portability : GHC +-- +-- __This implementation is NOT thread-safe.__ Thread safety must be maintained by a whole-set +-- locking mechanism. +module Data.SparseSet.Unboxed.Mutable ( + MutableSparseSet, + IOMutableSparseSet, + STMutableSparseSet, + + -- * Creation + withCapacity, + new, + + -- * Read + length, + contains, + members, + lookup, + + -- * Update + insert, + delete, + clear, + compact, + + -- * Iteration + foldM, + ifoldM, + mapM_, + imapM_, + ifoldIntersectionM, +) +where + +import Control.Monad.Primitive +import Data.Typeable (Typeable) +import Data.Vector.Unboxed qualified as VU +import GHC.Generics (Generic) +import Prelude hiding (length, lookup, mapM_) + +import Data.SparseSet.Generic.Mutable qualified as G + +newtype MutableSparseSet s a = MSS (G.MutableSparseSet VU.MVector s a) + deriving stock (Generic, Typeable) + +type IOMutableSparseSet = MutableSparseSet RealWorld +type STMutableSparseSet s = MutableSparseSet s + +-- | Create a sparse set with a given dense and sparse capacity +-- +-- It's a good idea to use this function if you have an estimate of your data requirements, +-- as it can prevent costly re-allocations as the set grows. +-- +-- @since 0.1.0.0 +withCapacity + :: (PrimMonad m, VU.Unbox a) + => Int + -- ^ Capacity for the dense set + -> Int + -- ^ Capacity for the sparse set + -> m (MutableSparseSet (PrimState m) a) +withCapacity dc sc = MSS <$> G.withCapacity dc sc + +-- | Create an empty sparse set with default capacities +-- +-- @since 0.1.0.0 +new :: forall a m. (PrimMonad m, VU.Unbox a) => m (MutableSparseSet (PrimState m) a) +new = MSS <$> G.new +{-# INLINE new #-} + +-- | O(1) Number of elements in the set (dense) +-- +-- @since 0.1.0.0 +length :: forall a m. (PrimMonad m) => MutableSparseSet (PrimState m) a -> m Int +length (MSS g) = G.length g +{-# INLINE length #-} + +-- | O(1) Check whether an element is in the set +-- +-- @since 0.1.0.0 +contains :: (PrimMonad m) => MutableSparseSet (PrimState m) a -> Int -> m Bool +contains (MSS g) = G.contains g +{-# INLINE contains #-} + +-- | O(n) The members of the set in an unspecified order. +-- +-- @since 0.1.0.0 +members :: (PrimMonad m) => MutableSparseSet (PrimState m) a -> m (VU.Vector Int) +members (MSS g) = G.members g +{-# INLINE members #-} + +-- | O(1) Look up an element in the set +-- +-- @since 0.1.0.0 +lookup :: (PrimMonad m, VU.Unbox a) => MutableSparseSet (PrimState m) a -> Int -> m (Maybe a) +lookup (MSS g) = G.lookup g +{-# INLINE lookup #-} + +-- | O(1) amortized. Insert a value for a given key. +-- +-- If the key is already in the set, its value is overwritten. +-- +-- __INVARIANT__: Keys cannot be negative. An unchecked exception is +-- thrown if a negative key is added to the set. +-- +-- @since 0.1.0.0 +insert :: (PrimMonad m, VU.Unbox a) => MutableSparseSet (PrimState m) a -> Int -> a -> m () +insert (MSS g) = G.insert g +{-# INLINE insert #-} + +-- | O(1) Delete an element from the set +-- +-- @since 0.1.0.0 +delete :: (PrimMonad m, VU.Unbox a) => MutableSparseSet (PrimState m) a -> Int -> m (Maybe a) +delete (MSS g) = G.delete g +{-# INLINE delete #-} + +-- | O(1) Clear all elements from the set +-- +-- @since 0.1.0.0 +clear :: (PrimMonad m) => MutableSparseSet (PrimState m) a -> m () +clear (MSS g) = G.clear g +{-# INLINE clear #-} + +-- | O(n) Shrink the capacity of the set to fit exactly the current number of elements. +-- +-- @since 0.1.0.0 +compact :: (PrimMonad m, VU.Unbox a) => MutableSparseSet (PrimState m) a -> m () +compact (MSS g) = G.compact g +{-# INLINE compact #-} + +-- | O(n) Fold over the values of the set. +-- +-- @since 0.1.0.0 +foldM + :: (PrimMonad m, VU.Unbox a) + => (b -> a -> m b) + -> b + -> MutableSparseSet (PrimState m) a + -> m b +foldM f initAcc (MSS g) = G.foldM f initAcc g +{-# INLINE foldM #-} + +-- | O(n) Fold over the keys and values of the set. +-- +-- @since 0.1.0.0 +ifoldM + :: (PrimMonad m, VU.Unbox a) + => (b -> (Int, a) -> m b) + -> b + -> MutableSparseSet (PrimState m) a + -> m b +ifoldM f initAcc (MSS g) = G.ifoldM f initAcc g +{-# INLINE ifoldM #-} + +-- | O(n) Iterate over the values of the set. +-- +-- @since 0.1.0.0 +mapM_ + :: (PrimMonad m, VU.Unbox a) + => (a -> m ()) -- Action to perform + -> MutableSparseSet (PrimState m) a + -> m () +mapM_ f (MSS g) = G.mapM_ f g +{-# INLINE mapM_ #-} + +-- | O(n) Iterate over the keys and values of the set. +-- +-- @since 0.1.0.0 +imapM_ + :: (PrimMonad m, VU.Unbox a) + => ((Int, a) -> m ()) -- Action to perform + -> MutableSparseSet (PrimState m) a + -> m () +imapM_ f (MSS g) = G.imapM_ f g +{-# INLINE imapM_ #-} + +-- | O(min(n, m)) Iterate over the intersection of two sets with an accumulator. +-- +-- The order of the arguments does not matter - the smaller of the two sets is +-- selected as the iteratee. +-- +-- @since 0.1.0.0 +ifoldIntersectionM + :: (PrimMonad m, VU.Unbox a, VU.Unbox b) + => (c -> Int -> a -> b -> m c) + -> c + -> MutableSparseSet (PrimState m) a + -> MutableSparseSet (PrimState m) b + -> m c +ifoldIntersectionM acc c (MSS a) (MSS b) = G.ifoldIntersectionM acc c a b +{-# INLINE ifoldIntersectionM #-} diff --git a/test/Data/SparseSet/Generic/Internal/GrowVecSpec.hs b/test/Data/SparseSet/Generic/Internal/GrowVecSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/SparseSet/Generic/Internal/GrowVecSpec.hs @@ -0,0 +1,173 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +module Data.SparseSet.Generic.Internal.GrowVecSpec where + +import Control.Monad (foldM, forM) +import Data.Vector.Unboxed.Mutable qualified as VM +import Hedgehog +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range +import Test.Tasty.HUnit + +import Data.SparseSet.Generic.Mutable.Internal.GrowVec qualified as GV + +type TestComponent = Int + +unit_withCapacity_is_empty :: Assertion +unit_withCapacity_is_empty = do + vec <- GV.withCapacity @TestComponent @VM.MVector 128 + GV.length vec @?= 0 + +unit_withCapacity_valid_capacity :: Assertion +unit_withCapacity_valid_capacity = do + vec <- GV.withCapacity @TestComponent @VM.MVector 0 + vec' <- GV.withCapacity @TestComponent @VM.MVector 1 + assertBool "capacity must be greater than 2" (GV.capacity vec >= 2 && GV.capacity vec' >= 2) + +-- HUnit Tests for specific scenarios +unit_new_is_empty :: Assertion +unit_new_is_empty = do + vec <- GV.new @TestComponent @VM.MVector + GV.length vec @?= 0 + +unit_snoc_increases_length :: Assertion +unit_snoc_increases_length = do + vec <- GV.new @TestComponent @VM.MVector + vec' <- GV.snoc vec 100 + GV.length vec' @?= 1 + +unit_read_after_snoc :: Assertion +unit_read_after_snoc = do + vec <- GV.new @TestComponent @VM.MVector + vec' <- GV.snoc vec 100 + mVal <- GV.readMaybe vec' 0 + mVal @?= Just 100 + +unit_swapRemove_middle :: Assertion +unit_swapRemove_middle = do + vec <- GV.new @TestComponent @VM.MVector + vec1 <- GV.snoc vec 10 + vec2 <- GV.snoc vec1 20 + vec3 <- GV.snoc vec2 30 -- vec = [10, 20, 30] + (removed, vec4) <- GV.unsafeSwapRemove vec3 1 -- remove 20 + -- now vec should be [10, 30] + val0 <- GV.unsafeRead vec4 0 + val1 <- GV.unsafeRead vec4 1 + mVal2 <- GV.readMaybe vec4 2 + removed @?= 20 + GV.length vec4 @?= 2 + val0 @?= 10 + val1 @?= 30 + mVal2 @?= Nothing + +unit_compact_preserves_elements :: Assertion +unit_compact_preserves_elements = do + vec1 <- GV.withCapacity @TestComponent @VM.MVector 100 + vec2 <- GV.snoc vec1 10 + vec3 <- GV.snoc vec2 20 + vec4 <- GV.compact vec3 + GV.length vec4 @?= 2 + val0 <- GV.unsafeRead vec4 0 + val1 <- GV.unsafeRead vec4 1 + val0 @?= 10 + val1 @?= 20 + +unit_maximum_empty :: Assertion +unit_maximum_empty = do + vec <- GV.new @TestComponent @VM.MVector + mMax <- GV.maximum vec + mMax @?= Nothing + +unit_maximum_single :: Assertion +unit_maximum_single = do + vec <- GV.new @TestComponent @VM.MVector + vec' <- GV.snoc vec 42 + mMax <- GV.maximum vec' + mMax @?= Just 42 + +unit_maximum_multiple :: Assertion +unit_maximum_multiple = do + vec <- GV.new @TestComponent @VM.MVector + vec1 <- GV.snoc vec (-10) + vec2 <- GV.snoc vec1 30 + vec3 <- GV.snoc vec2 5 + mMax <- GV.maximum vec3 + mMax @?= Just 30 + +unit_clear :: Assertion +unit_clear = do + vec <- GV.new @TestComponent @VM.MVector + vec1 <- GV.snoc vec 10 + vec2 <- GV.snoc vec1 20 + let vec3 = GV.cleared vec2 + GV.length vec2 @?= 2 -- Original is unchanged + GV.length vec3 @?= 0 -- New is empty + +-- Hedgehog property-based tests +data GrowVecOp + = OpSnoc TestComponent + | OpWrite Int TestComponent + | OpSwapRemove Int + | OpClear + deriving (Show, Eq) + +genOp :: Int -> Gen GrowVecOp +genOp currentLen = + Gen.frequency $ + [ (10, OpSnoc <$> Gen.int (Range.linear 0 1000)) + ] + <> [ (5, OpWrite <$> Gen.int (Range.linear 0 (currentLen - 1)) <*> Gen.int (Range.linear 0 1000)) + | currentLen > 0 + ] + <> [ (3, OpSwapRemove <$> Gen.int (Range.linear 0 (currentLen - 1))) | currentLen > 0 + ] + <> [(1, pure OpClear) | currentLen > 0] + +genOps :: Gen [GrowVecOp] +genOps = do + size <- Gen.int (Range.linear 0 100) + go size [] + where + go :: Int -> [GrowVecOp] -> Gen [GrowVecOp] + go n acc | n <= 0 = pure (reverse acc) + go n acc = do + let currentModel = applyOpsToModel (reverse acc) [] + op <- genOp (length currentModel) + go (n - 1) (op : acc) + +-- Pure list model of the GrowVec operations +applyOpToModel :: GrowVecOp -> [TestComponent] -> [TestComponent] +applyOpToModel (OpSnoc c) xs = xs ++ [c] +applyOpToModel (OpWrite idx val) xs = take idx xs ++ [val] ++ drop (idx + 1) xs +applyOpToModel (OpSwapRemove idx) xs + | idx == lastIdx = take idx xs + | otherwise = take idx xs ++ [last xs] ++ drop (idx + 1) (take lastIdx xs) + where + lastIdx = length xs - 1 +applyOpToModel OpClear _ = [] + +applyOpsToModel :: [GrowVecOp] -> [TestComponent] -> [TestComponent] +applyOpsToModel ops model = foldl (flip applyOpToModel) model ops + +hprop_growvec_model :: Property +hprop_growvec_model = property $ do + ops <- forAll genOps + let finalModel = applyOpsToModel ops [] + vec <- GV.new @TestComponent @VM.MVector + vec' <- + foldM + ( \v op -> case op of + OpSnoc c -> GV.snoc v c + OpWrite idx val -> GV.unsafeWrite v idx val >> pure v + OpSwapRemove idx -> snd <$> GV.unsafeSwapRemove v idx + OpClear -> pure $ GV.cleared v + ) + vec + ops + + let len = GV.length vec' + contents <- forM [0 .. len - 1] (GV.unsafeRead vec') + + len === length finalModel + contents === finalModel diff --git a/test/Data/SparseSet/Generic/Internal/MutableSparseArraySpec.hs b/test/Data/SparseSet/Generic/Internal/MutableSparseArraySpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/SparseSet/Generic/Internal/MutableSparseArraySpec.hs @@ -0,0 +1,119 @@ +module Data.SparseSet.Generic.Internal.MutableSparseArraySpec where + +import Control.Monad (foldM) +import Data.List (nub) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Hedgehog +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range +import Test.Tasty.HUnit + +import Data.SparseSet.Generic.Mutable.Internal.MutableSparseArray qualified as MSA +import Data.Traversable + +-- HUnit Tests for specific scenarios +unit_new_is_empty :: Assertion +unit_new_is_empty = do + arr <- MSA.new + mVal <- MSA.lookup arr 0 + c <- MSA.contains arr 0 + mVal @?= Nothing + c @?= False + +unit_insert_and_lookup :: Assertion +unit_insert_and_lookup = do + arr <- MSA.new + arr' <- MSA.unsafeInsert arr 10 100 + mVal <- MSA.lookup arr' 10 + mVal @?= Just 100 + +unit_insert_grows_and_fills :: Assertion +unit_insert_grows_and_fills = do + arr <- MSA.new + arr' <- MSA.unsafeInsert arr 10 100 + -- The array should have grown, but indices other than 10 should be empty + mVal0 <- MSA.lookup arr' 0 + mVal5 <- MSA.lookup arr' 5 + mVal0 @?= Nothing + mVal5 @?= Nothing + +unit_delete_removes_entry :: Assertion +unit_delete_removes_entry = do + arr <- MSA.new + arr' <- MSA.unsafeInsert arr 10 100 + deleted <- MSA.delete arr' 10 + mVal <- MSA.lookup arr' 10 + deleted @?= Just 100 + mVal @?= Nothing + +unit_clear :: Assertion +unit_clear = do + arr <- MSA.new + arr1 <- MSA.unsafeInsert arr 5 50 + arr2 <- MSA.unsafeInsert arr1 10 100 + MSA.clear arr2 + mVal5 <- MSA.lookup arr2 5 + mVal10 <- MSA.lookup arr2 10 + mVal5 @?= Nothing + mVal10 @?= Nothing + +-- Hedgehog property-based tests +data ArrayOp + = OpInsert Int Int -- key, value + | OpDelete Int -- key + | OpClear + deriving (Show, Eq) + +genKey :: Gen Int +genKey = Gen.int (Range.linear 0 100) + +genValue :: Gen Int +genValue = Gen.int (Range.linear 0 1000) + +genOp :: Gen ArrayOp +genOp = + Gen.frequency + [ (10, OpInsert <$> genKey <*> genValue) + , (5, OpDelete <$> genKey) + , (1, pure OpClear) + ] + +genOps :: Gen [ArrayOp] +genOps = Gen.list (Range.linear 0 100) genOp + +-- Model-based testing +applyOpToModel :: ArrayOp -> Map Int Int -> Map Int Int +applyOpToModel (OpInsert k v) = Map.insert k v +applyOpToModel (OpDelete k) = Map.delete k +applyOpToModel OpClear = const Map.empty + +applyOpsToModel :: [ArrayOp] -> Map Int Int -> Map Int Int +applyOpsToModel ops model = foldl (flip applyOpToModel) model ops + +getAllKeys :: [ArrayOp] -> [Int] +getAllKeys = nub . foldr opKeys [] + where + opKeys (OpInsert k _) acc = k : acc + opKeys (OpDelete k) acc = k : acc + opKeys OpClear acc = acc + +hprop_msa_model :: Property +hprop_msa_model = property $ do + ops <- forAll genOps + let allKeys = 0 : getAllKeys ops + let finalModel = applyOpsToModel ops Map.empty + arr <- MSA.new + arr' <- + foldM + ( \a op -> case op of + OpInsert k v -> MSA.unsafeInsert a k v + OpDelete k -> MSA.delete a k >> pure a + OpClear -> MSA.clear a >> pure a + ) + arr + ops + sutFinalState <- for allKeys $ \k -> (k,) <$> MSA.lookup arr' k + + let modelFinalState = fmap (\k -> (k, Map.lookup k finalModel)) allKeys + sutFinalState === modelFinalState diff --git a/test/Data/SparseSet/Unboxed/MutableSpec.hs b/test/Data/SparseSet/Unboxed/MutableSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/SparseSet/Unboxed/MutableSpec.hs @@ -0,0 +1,528 @@ +{-# LANGUAGE DerivingVia #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Data.SparseSet.Unboxed.MutableSpec where + +import Control.Monad +import Control.Monad.Primitive +import Data.Foldable +import Data.IORef +import Data.List (sort) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (catMaybes, isJust) +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Traversable +import Data.Typeable (Typeable) +import Data.Vector.Unboxed qualified as U +import Hedgehog +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range +import NoThunks.Class +import Test.Tasty.HUnit + +import Data.SparseSet.Unboxed.Mutable (MutableSparseSet) +import Data.SparseSet.Unboxed.Mutable qualified as SS + +-- Component type for most tests +type TestComponent = Int + +-- Entity ID type +type TestEntity = Int + +deriving via + InspectHeap (MutableSparseSet s a) + instance + (Typeable a, Typeable s) + => NoThunks (MutableSparseSet s a) + +-------------------------------------------------------------------------------- +-- HUnit +-------------------------------------------------------------------------------- +assertNoThunks :: (NoThunks a) => String -> a -> IO () +assertNoThunks lbl a = case unsafeNoThunks a of + Just ti -> assertFailure $ "[" <> lbl <> "] Found unexpected thunks: " <> show ti + Nothing -> pure () +{-# INLINE assertNoThunks #-} + +unit_new_empty_set :: Assertion +unit_new_empty_set = do + set <- SS.new @TestComponent + len <- SS.length set + c0 <- SS.contains set 0 + g0 <- SS.lookup set 0 + len @?= 0 + c0 @?= False + g0 @?= Nothing + +unit_new_empty_set_no_thunks :: Assertion +unit_new_empty_set_no_thunks = do + set <- SS.new @TestComponent + assertNoThunks "empty set" set + g0 <- SS.lookup set 0 + assertNoThunks "empty set - nonexisting" g0 + +unit_single_insert :: Assertion +unit_single_insert = do + set <- SS.new @TestComponent + SS.insert set 0 100 + len <- SS.length set + c0 <- SS.contains set 0 + not_c1 <- SS.contains set 1 + g0 <- SS.lookup set 0 + len @?= 1 + c0 @?= True + not_c1 @?= False + g0 @?= Just 100 + +unit_single_insert_no_thunks :: Assertion +unit_single_insert_no_thunks = do + set <- SS.new @TestComponent + SS.insert set 0 100 + assertNoThunks "singleton set" set + g0 <- SS.lookup set 0 + assertNoThunks "singleton set result" g0 + +unit_insert_update :: Assertion +unit_insert_update = do + set <- SS.new @TestComponent + SS.insert set 0 100 + SS.insert set 0 200 + len <- SS.length set + g0 <- SS.lookup set 0 + len @?= 1 + g0 @?= Just 200 + +unit_insert_update_no_thunks :: Assertion +unit_insert_update_no_thunks = do + set <- SS.new @TestComponent + SS.insert set 0 100 + SS.insert set 0 200 + len <- SS.length set + g0 <- SS.lookup set 0 + len @?= 1 + g0 @?= Just 200 + +unit_delete_existing :: Assertion +unit_delete_existing = do + set <- SS.new @TestComponent + SS.insert set 0 100 + SS.insert set 1 101 + deletedVal <- SS.delete set 0 + len <- SS.length set + c0 <- SS.contains set 0 + g0 <- SS.lookup set 0 + c1 <- SS.contains set 1 + g1 <- SS.lookup set 1 + deletedVal @?= Just 100 + len @?= 1 + c0 @?= False + g0 @?= Nothing + c1 @?= True + g1 @?= Just 101 + +unit_delete_non_existing :: Assertion +unit_delete_non_existing = do + set <- SS.new @TestComponent + SS.insert set 0 100 + deletedVal <- SS.delete set 1 -- Try to delete non-existing + len <- SS.length set + c0 <- SS.contains set 0 + g0 <- SS.lookup set 0 + deletedVal @?= Nothing + len @?= 1 + c0 @?= True + g0 @?= Just 100 + +unit_delete_last_element_no_swap :: Assertion +unit_delete_last_element_no_swap = do + set <- SS.new @TestComponent + SS.insert set 0 100 + SS.insert set 1 101 + deletedVal <- SS.delete set 1 -- Delete the last inserted (likely last in dense) + len <- SS.length set + g1 <- SS.lookup set 1 + g0 <- SS.lookup set 0 + deletedVal @?= Just 101 + len @?= 1 + g1 @?= Nothing + g0 @?= Just 100 + +unit_delete_causes_swap :: Assertion +unit_delete_causes_swap = do + set <- SS.new @TestComponent + -- Order of insertion might matter for dense array layout if not careful, + -- but sparse set logic should be independent of insertion order for correctness. + -- Entities: 0, 10, 5. Values: 100, 110, 105 + -- Assume dense indices map somewhat to insertion: + -- sparse: 0->DI0, 10->DI1, 5->DI2 + -- dense: [val_for_0, val_for_10, val_for_5] + -- indices: [0, 10, 5] + SS.insert set 0 100 + SS.insert set 10 110 + SS.insert set 5 105 + -- At this point, length is 3. + -- Let's say internal dense layout is [100 (for 0), 110 (for 10), 105 (for 5)] + -- Indices: [0, 10, 5] + -- Sparse: 0->0, 10->1, 5->2 + + -- Delete entity 0 (at dense index 0). + -- Element for entity 5 (value 105) at dense_idx 2 should be swapped into dense_idx 0. + deletedVal <- SS.delete set 0 + len <- SS.length set + + g0 <- SS.lookup set 0 + g10 <- SS.lookup set 10 + g5 <- SS.lookup set 5 + + deletedVal @?= Just 100 + len @?= 2 + g0 @?= Nothing + g10 @?= Just 110 + g5 @?= Just 105 + +unit_delete_swap_no_thunks :: Assertion +unit_delete_swap_no_thunks = do + set <- SS.new @TestComponent + assertNoThunks "empty" set + SS.insert set 0 100 + assertNoThunks "1 elem" set + SS.insert set 10 110 + assertNoThunks "2 elem" set + SS.insert set 5 105 + assertNoThunks "3 elem" set + deletedVal <- SS.delete set 0 + assertNoThunks "delete" set + assertNoThunks "deleted value" deletedVal + + g0 <- SS.lookup set 0 + assertNoThunks "get 0" g0 + g10 <- SS.lookup set 10 + assertNoThunks "get 10" g10 + g5 <- SS.lookup set 5 + assertNoThunks "get 5" g5 + +unit_delete_then_insert :: Assertion +unit_delete_then_insert = do + set <- SS.new @TestComponent + SS.insert set 0 100 + SS.insert set 10 110 + SS.insert set 5 105 + deleted <- SS.delete set 0 + l0 <- SS.lookup set 0 + SS.insert set 0 200 + l1 <- SS.lookup set 0 + len <- SS.length set + + deleted @?= Just 100 + l0 @?= Nothing + l1 @?= Just 200 + len @?= 3 + +unit_insert_large_index :: Assertion +unit_insert_large_index = do + set <- SS.new @TestComponent + SS.insert set 0 100 + SS.insert set 5000 500 -- Test sparse array growth + len <- SS.length set + g0 <- SS.lookup set 0 + g5000 <- SS.lookup set 5000 + c5000 <- SS.contains set 5000 + len @?= 2 + g0 @?= Just 100 + g5000 @?= Just 500 + c5000 @?= True + +unit_clear :: Assertion +unit_clear = do + set <- SS.new @TestComponent + SS.insert set 0 100 + SS.insert set 500 32 + SS.insert set 31 (-5) + SS.clear set + SS.mapM_ (\_ -> assertFailure "Set must be empty") set + +unit_ifoldM__empty :: Assertion +unit_ifoldM__empty = do + set <- SS.new @TestComponent + result <- SS.ifoldM (\acc (e, c) -> pure $ (e, c) : acc) [] set + result @?= [] + +unit_mapM__sum :: Assertion +unit_mapM__sum = do + set <- SS.new @TestComponent + SS.insert set 10 1 + SS.insert set 20 2 + SS.insert set 30 3 + sumRef <- newIORef 0 + SS.mapM_ (\c -> modifyIORef' sumRef (+ c)) set + finalSum <- readIORef sumRef + finalSum @?= 6 + +-- This new test case verifies the ifoldIntersectionM function +-- using only the public API for Unboxed sparse sets. +unit_ifoldIntersectionM :: Assertion +unit_ifoldIntersectionM = do + -- Setup: + -- Set A: Unboxed Ints + setA <- SS.new @Int + SS.insert setA 10 100 + SS.insert setA 20 200 + SS.insert setA 30 300 + + -- Set B: Unboxed Bools + setB <- SS.new @Bool + SS.insert setB 20 True + SS.insert setB 30 False + SS.insert setB 40 True + + -- Set C: An empty set + setCEmpty <- SS.new @Int + + -- The folding function collects the results into a list. + -- Its type signature matches the arguments from setA and setB. + let fIntBool acc e ca cb = pure $ (e, ca, cb) : acc + + -- Test 1: Intersection of A (Ints) and B (Bools) + result1 <- SS.ifoldIntersectionM fIntBool [] setA setB + -- The result list is built in reverse order, so we sort for a stable comparison. + sort result1 @?= [(20, 200, True), (30, 300, False)] + + -- Test 2: Intersection of B (Bools) and A (Ints) + -- For this, the folding function's components must be in the opposite order. + let fBoolInt acc e cb ca = pure $ (e, ca, cb) : acc + result2 <- SS.ifoldIntersectionM fBoolInt [] setB setA + -- The final tuple structure is the same, so the result should be identical. + sort result2 @?= [(20, 200, True), (30, 300, False)] + + -- Test 3: Intersection with an empty set + resultEmpty <- SS.ifoldIntersectionM fIntBool [] setA setCEmpty + resultEmpty @?= [] + +-------------------------------------------------------------------------------- +-- Hedgehog Property-Based Tests +-------------------------------------------------------------------------------- + +-- Generators +genEntityId :: Gen TestEntity +genEntityId = Gen.int (Range.linear 0 200) -- Range can be adjusted for different test profiles + +genSmallEntityId :: Gen TestEntity +genSmallEntityId = Gen.int (Range.linear 0 10) + +genComponent :: Gen TestComponent +genComponent = Gen.int (Range.linear (-1000) 1000) + +-- Operations for stateful model testing +data SparseSetOp + = OpInsert TestEntity TestComponent + | OpDelete TestEntity + deriving (Show, Eq) + +genSparseSetOp :: Gen SparseSetOp +genSparseSetOp = + Gen.frequency + [ (7, OpInsert <$> genEntityId <*> genComponent) -- More inserts initially + , (3, OpDelete <$> genEntityId) + ] + +genSparseSetOpSmallEntities :: Gen SparseSetOp +genSparseSetOpSmallEntities = + Gen.frequency + [ (7, OpInsert <$> genSmallEntityId <*> genComponent) + , (3, OpDelete <$> genSmallEntityId) + ] + +-- Apply a list of operations to a pure model +applyOpsToModel :: [SparseSetOp] -> Map TestEntity TestComponent -> Map TestEntity TestComponent +applyOpsToModel ops model = foldl applyOpToModel model ops + where + applyOpToModel m (OpInsert e c) = Map.insert e c m + applyOpToModel m (OpDelete e) = Map.delete e m + +-- Apply a list of operations to the MutableSparseSet +applyOpsToSet + :: (Foldable t, PrimMonad m) => MutableSparseSet (PrimState m) TestComponent -> t SparseSetOp -> m () +applyOpsToSet set ops = for_ ops \case + OpInsert e c -> SS.insert set e c + OpDelete e -> void $ SS.delete set e -- Ignore deleted value for this helper + +extractOpEntities :: SparseSetOp -> [TestEntity] +extractOpEntities = \case + OpInsert e _ -> [e] + OpDelete e -> [e] + +-- Extract all current (entity, component) pairs and length from the set +extractFullStateFromSet + :: (PrimMonad m, U.Unbox a) => MutableSparseSet (PrimState m) a -> Set Int -> m (Int, Map Int a) +extractFullStateFromSet set allKnownEntities = do + len <- SS.length set + mapEntries <- + fmap + (Map.fromList . catMaybes) + ( for (toList allKnownEntities) \e -> do + mVal <- SS.lookup set e + pure $ (e,) <$> mVal + ) + pure (len, mapEntries) + +extractFullStateFromSetViaIterator + :: (PrimMonad m, U.Unbox a) => MutableSparseSet (PrimState m) a -> m (Int, Map Int a) +extractFullStateFromSetViaIterator set = do + len <- SS.length set + entries <- SS.ifoldM (\acc (e, c) -> pure $ Map.insert e c acc) Map.empty set + pure (len, entries) + +hprop_sequential_operations :: Property +hprop_sequential_operations = property do + -- Generate a sequence of operations + ops <- forAll $ Gen.list (Range.linear 0 100) genSparseSetOp + + -- Determine all entities ever mentioned to check them later + let allMentionedEntities = Set.fromList $ concatMap extractOpEntities ops + finalModel = applyOpsToModel ops Map.empty + + do + set <- SS.new @TestComponent + applyOpsToSet set ops + (setLength, setMap) <- extractFullStateFromSet set allMentionedEntities + setLength === Map.size finalModel + setMap === finalModel + + do + set <- SS.new @TestComponent + applyOpsToSet set ops + for_ (Set.toList allMentionedEntities) $ \e -> do + sutContains <- SS.contains set e + let modelContains = Map.member e finalModel + sutContains === modelContains + +hprop_clear_removes_all :: Property +hprop_clear_removes_all = property $ do + ops <- forAll $ Gen.list (Range.linear 1 100) genSparseSetOp + let allMentionedEntities = Set.fromList $ concatMap extractOpEntities ops + + set <- SS.new @TestComponent + applyOpsToSet set ops + SS.clear set + finalLen <- SS.length set + found <- or <$> traverse (fmap isJust . SS.lookup set) (toList allMentionedEntities) + finalLen === 0 + found === False + +hprop_compact_preserves_content :: Property +hprop_compact_preserves_content = property $ do + ops <- forAll $ Gen.list (Range.linear 0 100) genSparseSetOp + + set <- SS.new @TestComponent + applyOpsToSet set ops + + let model = applyOpsToModel ops Map.empty + (lenBefore, stateBefore) <- extractFullStateFromSetViaIterator set + SS.compact set + (lenAfter, stateAfter) <- extractFullStateFromSetViaIterator set + + stateBefore === model + lenBefore === lenAfter + stateBefore === stateAfter + +hprop_insert_then_get :: Property +hprop_insert_then_get = property do + entity <- forAll genEntityId + component <- forAll genComponent + set <- SS.new @TestComponent + SS.insert set entity component + l <- SS.length set + v <- SS.lookup set entity + c <- SS.contains set entity + l === 1 + v === Just component + c === True + +hprop_insert_update_then_get :: Property +hprop_insert_update_then_get = property do + entity <- forAll genEntityId + component1 <- forAll genComponent + component2 <- forAll genComponent + set <- SS.new @TestComponent + SS.insert set entity component1 + SS.insert set entity component2 -- Update + l <- SS.length set + v <- SS.lookup set entity + l === 1 + v === Just component2 + +hprop_insert_delete_then_get :: Property +hprop_insert_delete_then_get = property do + entity <- forAll genEntityId + component <- forAll genComponent + set <- SS.new @TestComponent + SS.insert set entity component + rv <- SS.delete set entity + l <- SS.length set + v <- SS.lookup set entity + c <- SS.contains set entity + rv === Just component + l === 0 + v === Nothing + c === False + +hprop_delete_non_existent :: Property +hprop_delete_non_existent = property do + entity <- forAll genEntityId + set <- SS.new @TestComponent + rv <- SS.delete set entity + l <- SS.length set + rv === Nothing + l === 0 + +hprop_double_delete :: Property +hprop_double_delete = property do + entity <- forAll genEntityId + component <- forAll genComponent + set <- SS.new @TestComponent + SS.insert set entity component + r1 <- SS.delete set entity + r2 <- SS.delete set entity -- Delete again + l <- SS.length set + v <- SS.lookup set entity + r1 === Just component + r2 === Nothing + l === 0 + v === Nothing + +-- This property specifically stresses the swap logic by creating a denser set. +hprop_dense_delete_integrity :: Property +hprop_dense_delete_integrity = property do + ops <- forAll $ Gen.list (Range.linear 5 30) genSparseSetOpSmallEntities + + let allMentionedEntities = Set.fromList $ concatMap extractOpEntities ops + finalModel = applyOpsToModel ops Map.empty + + set <- SS.new @TestComponent + applyOpsToSet set ops + (setLength, setMap) <- extractFullStateFromSet set allMentionedEntities + + setLength === Map.size finalModel + setMap === finalModel + +hprop_ifoldIntersectionM_model :: Property +hprop_ifoldIntersectionM_model = property do + opsA <- forAll $ Gen.list (Range.linear 0 100) genSparseSetOp + opsB <- forAll $ Gen.list (Range.linear 0 100) genSparseSetOp + + setA <- SS.new @TestComponent + applyOpsToSet setA opsA + let modelA = applyOpsToModel opsA Map.empty + + setB <- SS.new @TestComponent + applyOpsToSet setB opsB + let modelB = applyOpsToModel opsB Map.empty + + let collectEntities acc entity _ _ = pure (entity : acc) + sutIntersectedEntities <- SS.ifoldIntersectionM collectEntities [] setA setB + + let modelIntersectedEntities = Set.intersection (Map.keysSet modelA) (Map.keysSet modelB) + + Set.fromList sutIntersectedEntities === modelIntersectedEntities diff --git a/test/Driver.hs b/test/Driver.hs new file mode 100644 --- /dev/null +++ b/test/Driver.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display #-}