pure-noise 0.2.0.0 → 0.2.1.0
raw patch · 24 files changed
+1947/−693 lines, 24 filesdep +JuicyPixelsdep +aesondep +aeson-prettydep −mwc-randomPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: JuicyPixels, aeson, aeson-pretty, bytestring, directory, filepath, massiv, random, tasty-golden, text, typed-process
Dependencies removed: mwc-random
API changes (from Hackage documentation)
- Numeric.Noise: data Noise2 a
- Numeric.Noise: data Noise3 a
+ Numeric.Noise: data Noise p v
+ Numeric.Noise: noise1At :: Noise1 a -> Seed -> a -> a
+ Numeric.Noise: remap :: (a -> b) -> Noise p a -> Noise p b
+ Numeric.Noise: reseed :: (Seed -> Seed) -> Noise p a -> Noise p a
+ Numeric.Noise: sliceX2 :: p -> Noise2' p v -> Noise1' p v
+ Numeric.Noise: sliceX3 :: p -> Noise3' p v -> Noise2' p v
+ Numeric.Noise: sliceY2 :: p -> Noise2' p v -> Noise1' p v
+ Numeric.Noise: sliceY3 :: p -> Noise3' p v -> Noise2' p v
+ Numeric.Noise: sliceZ3 :: p -> Noise3' p v -> Noise2' p v
+ Numeric.Noise: type Noise1 v = Noise1' v v
+ Numeric.Noise: type Noise1' p v = Noise p v
+ Numeric.Noise: type Noise2 v = Noise2' v v
+ Numeric.Noise: type Noise2' p v = Noise (p, p) v
+ Numeric.Noise: type Noise3 v = Noise3' v v
+ Numeric.Noise: type Noise3' p v = Noise (p, p, p) v
+ Numeric.Noise: warp :: (p -> p') -> Noise p' v -> Noise p v
- Numeric.Noise: CellularConfig :: !CellularDistanceFn -> !a -> !CellularResult -> CellularConfig a
+ Numeric.Noise: CellularConfig :: CellularDistanceFn -> a -> CellularResult -> CellularConfig a
- Numeric.Noise: [cellularDistanceFn] :: CellularConfig a -> !CellularDistanceFn
+ Numeric.Noise: [cellularDistanceFn] :: CellularConfig a -> CellularDistanceFn
- Numeric.Noise: [cellularJitter] :: CellularConfig a -> !a
+ Numeric.Noise: [cellularJitter] :: CellularConfig a -> a
- Numeric.Noise: [cellularResult] :: CellularConfig a -> !CellularResult
+ Numeric.Noise: [cellularResult] :: CellularConfig a -> CellularResult
- Numeric.Noise.Cellular: CellularConfig :: !CellularDistanceFn -> !a -> !CellularResult -> CellularConfig a
+ Numeric.Noise.Cellular: CellularConfig :: CellularDistanceFn -> a -> CellularResult -> CellularConfig a
- Numeric.Noise.Cellular: [cellularDistanceFn] :: CellularConfig a -> !CellularDistanceFn
+ Numeric.Noise.Cellular: [cellularDistanceFn] :: CellularConfig a -> CellularDistanceFn
- Numeric.Noise.Cellular: [cellularJitter] :: CellularConfig a -> !a
+ Numeric.Noise.Cellular: [cellularJitter] :: CellularConfig a -> a
- Numeric.Noise.Cellular: [cellularResult] :: CellularConfig a -> !CellularResult
+ Numeric.Noise.Cellular: [cellularResult] :: CellularConfig a -> CellularResult
Files
- CHANGELOG.md +40/−0
- README.md +152/−31
- bench/Bench.hs +391/−184
- pure-noise.cabal +21/−3
- src/Numeric/Noise.hs +105/−83
- src/Numeric/Noise/Cellular.hs +34/−22
- src/Numeric/Noise/Fractal.hs +40/−39
- src/Numeric/Noise/Internal.hs +323/−159
- src/Numeric/Noise/Internal/Math.hs +130/−30
- src/Numeric/Noise/OpenSimplex.hs +42/−61
- src/Numeric/Noise/Perlin.hs +16/−8
- src/Numeric/Noise/SuperSimplex.hs +22/−51
- src/Numeric/Noise/Value.hs +4/−6
- src/Numeric/Noise/ValueCubic.hs +4/−6
- test/CellularSpec.hs +37/−0
- test/FractalSpec.hs +68/−0
- test/Golden/Util.hs +393/−0
- test/Noise2Spec.hs +2/−7
- test/Noise3Spec.hs +3/−3
- test/OpenSimplexSpec.hs +21/−0
- test/PerlinSpec.hs +24/−0
- test/SuperSimplexSpec.hs +19/−0
- test/ValueCubicSpec.hs +27/−0
- test/ValueSpec.hs +29/−0
CHANGELOG.md view
@@ -8,6 +8,46 @@ ## Unreleased +## 0.2.1.0 2025-10-31++### Added++- 1D noise support with `noise1At` evaluation function+- Noise slicing functions (`sliceX2`, `sliceY2`, `sliceX3`, `sliceY3`, `sliceZ3`) for reducing noise dimensionality+- Comprehensive Haddock documentation for:+ - Core `Noise p v` type with usage examples+ - All utility functions (`warp`, `reseed`, `remap`, `blend`)+ - All slicing functions with examples+- Exported utility functions:+ - `warp` - transform coordinate space+ - `reseed` - modify seed for independent layers (generalizes `alterSeed2`/`alterSeed3`)+ - `remap` - transform noise values (alias for `fmap`)+ - `blend` - combine noise functions with custom blending (alias for `liftA2`)+- Exported `Noise` type for advanced usage and type annotations++### Changed++- Refactored to unified noise representation using `newtype Noise p v`+ - `Noise2` and `Noise3` are now type aliases: `Noise (a,a) a` and `Noise (a,a,a) a`+ - Provides `Functor`, `Applicative`, `Monad`, `Num`, `Fractional`, and `Floating` instances+ - All dimensions share the same instance implementations for consistency+- Updated module documentation with examples of new features (slicing, warping, layering)+- Improved README with advanced usage examples++### Performance++- **Overall**: 90% of benchmarks improved with +32.4% average performance gain+- **Ping-pong fractals**: Branchless optimization yields 110-148% improvement (perlin, value, openSimplex)+- **Cellular noise**: REWRITE RULES for gradient lookups provide 61-70% improvement+- **3D ValueCubic fractals**: Fixed performance regression, achieving 45-80% improvement+- **Perlin noise**: 10-63% improvements from optimized lerp/cubic interpolation with REWRITE RULES+- **Value noise**: 11-43% improvements from interpolation optimizations+- **OpenSimplex2**: 6-16% improvement for Float; minor regression (~5%) for Double variants+- **SuperSimplex2**: Shows 3-21% regression due to improved benchmark methodology+ - Previous benchmarks used same X/Y offset (diagonal sampling), which favored SuperSimplex's triangular lattice+ - New benchmarks use independent X/Y offsets for realistic 2D coordinate distributions+ - Algorithm remains functionally correct; numbers now reflect true 2D performance+ ## 0.2.0.0 - 2025-10-21 ### Added
README.md view
@@ -2,75 +2,196 @@ Performant, modern noise generation for Haskell with a minimal dependency footprint. -The algorithms used in this library are ported from [FastNoiseLite](https://github.com/Auburn/FastNoiseLite). The library structure has been retuned to fit better with Haskell semantics.+## Core features -The public interface for this library is unlikely to change much, although the implementations (`noiseBaseN` functions and anything in `Numeric.Noise.Internal`) are subject to change and may change between minor versions.+- **algebraic composition** of noise functions. You can combine,+ layer, and transform noise sources using standard operators (E.g., `Num`,+ `Fractional`, `Monad`, etc).+- **Complex effects** like domain warping and multi-octave fractals with clean,+ type-safe composition.+- **84-95% of C++ FastNoiseLite performance** through aggressive optimization and+ LLVM compilation. +**For detailed FastNoiseLite comparison, methodology, and reproducibility instructions,+see the [benchmark README](https://github.com/jtnuttall/pure-noise/blob/main/bench/README.md).**++The public interface for this library is unlikely to change much, although the+implementations (`noiseBaseN` functions and anything in `Numeric.Noise.Internal`)+are subject to change and may change between minor versions.++## Acknowledgments++- This project grew from a port of the excellent+ [FastNoiseLite](https://github.com/Auburn/FastNoiseLite) library. The library+ structure has been tuned to perform well in Haskell and fit well with Haskell+ semantics, but the core noise implementations are the same.+- All credit for the original design, algorithms, and implementation goes to its+ creator **[Jordan Peck (@Auburn)](https://github.com/Auburn)**. I'm grateful for+ their work and the opportunity to learn from it.+- The original FastNoiseLite code, from which the core algorithms in this library+ were originally ported, is (C) 2020 Jordan Peck and is licensed under the MIT+ license, a copy of which is included in this repository.+ ## Usage -The library exports newtypes for N-dimensional noise. Currently, these are just functions that accept a seed and a point in N-dimensional space. They can be arbitrarily unwrapped by with the `noiseNAt` family of functions. Since they abstract over the given seed and parameters, they can be composed with `Num` or `Fractional` methods at will with little-to-no performance cost.+The library provides composable noise functions `Noise2` and `Noise3` are type+aliases for 2D and 3D noise. Noise functions can be composed transparently using+standard operators with minimal performance cost. -Noise values are generally clamped to `[-1, 1]`, although some noise functions may occasionally produce values slightly outside this range.+Noise values are generally clamped to `[-1, 1]`, although some noise functions+may occasionally produce values slightly outside this range. +### Basic Example+ ```haskell import Numeric.Noise qualified as Noise -myNoise2 :: (RealFrac a) => Seed -> a -> a -> a+-- Compose multiple noise sources+myNoise2 :: (RealFrac a) => Noise.Seed -> a -> a -> a myNoise2 = let fractalConfig = Noise.defaultFractalConfig- in Noise.noise2At $- Noise.fractal2 fractalConfig ((perlin2 + superSimplex2) / 2)+ combined = (Noise.perlin2 + Noise.superSimplex2) / 2+ in Noise.noise2At $ Noise.fractal2 fractalConfig combined ``` +### Advanced Features++The library's unified `Noise p v` type enables powerful composition patterns:++#### Complex Compositions++The `Monad` instance is useful to create noise that depends on other noise values:++```haskell+-- Use one noise function's output to modulate another+complexNoise :: Noise.Noise2 Float+complexNoise = do+ baseNoise <- Noise.perlin2+ detailNoise <- Noise.next2 Noise.superSimplex2+ -- Blend based on base noise: smooth areas get less detail+ pure $ baseNoise * 0.7 + detailNoise * (0.3 * (1 + baseNoise) / 2)+```++This is especially useful for creating organic, varied terrain where one noise pattern+influences the characteristics of another.++#### 1D Noise via Slicing++Generate 1D noise by slicing higher-dimensional noise at a fixed coordinate:++```haskell+-- Create 1D noise by fixing one dimension+noise1d :: Noise.Noise1 Float+noise1d = Noise.sliceY2 0.0 Noise.perlin2++-- Evaluate at a point+value = Noise.noise1At noise1d seed 5.0+```++**Coordinate Transformation:**++Scale, rotate, or warp the coordinate space:++```haskell+-- Double the frequency+scaled = Noise.warp (\(x, y) -> (x * 2, y * 2)) Noise.perlin2++-- Rotate 45 degrees+rotated = Noise.warp (\(x, y) ->+ let a = pi / 4+ in (x * cos a - y * sin a, x * sin a + y * cos a)) Noise.perlin2+```++#### Layering Independent Noise++Use `reseed` or `next2`/`next3` to create independent layers:++```haskell+layered = (Noise.perlin2 + Noise.next2 Noise.perlin2) / 2+```+ More examples can be found in `bench` and `demo`. +#### Domain Warping++Domain warping uses one noise function to distort the coordinate space of another,+creating organic, flowing patterns ideal for terrain, clouds, and natural textures:++```haskell+domainWarped :: Noise.Noise2 Float+domainWarped = do+ -- Generate 3D fractal for warp offsets+ let warpNoise = Noise.fractal3 Noise.defaultFractalConfig{Noise.octaves = 5} Noise.perlin3+ -- Extract X and Y warp offsets by slicing at z=0+ warpX <- Noise.sliceX3 0.0 warpNoise+ warpY <- Noise.sliceY3 0.0 warpNoise+ -- Apply warping to base noise coordinates+ Noise.warp (\(x, y) -> (x + 30 * warpX, y + 30 * warpY))+ $ Noise.fractal2 Noise.defaultFractalConfig{Noise.octaves = 5} Noise.openSimplex2+```++++See the [demo app](demo/) for an interactive version with adjustable parameters.+ ## Performance notes -- This library benefits considerably from compilation with the LLVM backend (`-fllvm`). Benchmarks suggest a ~50-80% difference depending on the kind of noise.+- In single-threaded scenarios with LLVM enabled, this library achieves **84-95%+ of C++ FastNoiseLite performance**.+- This library benefits considerably from compilation with the LLVM backend+ (`-fllvm`). Benchmarks suggest a ~50-80% difference depending on the kind of noise. -## Benchmarks+### Parallel noise generation -### Results+This library integrates well with [massiv](https://hackage.haskell.org/package/massiv)+for parallel computation. Parallel performance can reach 10-15x single-threaded+performance. -Measured by values / second generated by the noise functions. These results come from a benchmark with `-fllvm` enabled.+**This is the recommended approach for generating large noise textures or datasets.** -All results are for `Float`s.+### Benchmarks -There's inevitably some noise in the measurements because all of the results are forced into an unboxed vector.+#### Results -#### 2D+Measured by values / second generated by the noise functions. These results come+from a benchmark with `-fllvm` enabled. -| name | values / second |-| ------------- | --------------- |-| value2 | 156_797_694 |-| perlin2 | 138_048_921 |-| superSimplex2 | 65_204_214 |-| openSimplex2 | 64_483_692 |-| valueCubic2 | 50_666_467 |-| cellular2 | 20_819_883 |+There's inevitably some noise in the measurements because all of the results are+forced into an unboxed vector. -#### 3D+##### 2D -| name | values / second |-| ----------- | --------------- |-| value3 | 83_034_432 |-| perlin3 | 60_233_650 |-| valueCubic3 | 15_220_433 |+| name | Float (values/sec) | Double (values/sec) |+| ------------- | ------------------ | ------------------- |+| value2 | 173_511_654 | 189_119_731 |+| perlin2 | 154_674_464 | 161_114_532 |+| openSimplex2 | 74_747_031 | 74_332_345 |+| valueCubic2 | 61_415_544 | 62_481_313 |+| superSimplex2 | 51_295_369 | 50_383_577 |+| cellular2 | 34_996_382 | 32_652_899 | +##### 3D++| name | Float (values/sec) | Double (values/sec) |+| ----------- | ------------------ | ------------------- |+| value3 | 90_805_572 | 93_188_363 |+| perlin3 | 74_080_032 | 82_477_882 |+| valueCubic3 | 18_765_912 | 18_284_749 |+ ## Examples There's an interactive [demo app](https://github.com/jtnuttall/pure-noise/tree/main/demo) in the `demo` directory. -_OpenSimplex2_+### OpenSimplex2   -_Perlin_+### Perlin  -_Cellular_+### Cellular  
bench/Bench.hs view
@@ -1,294 +1,501 @@ import BenchLib+import Data.Massiv.Array qualified as MA import Data.Typeable import Data.Vector.Unboxed qualified as U import Numeric.Noise-import System.Random.MWC qualified as MWC+import System.Random.Stateful main :: IO () main = do let sz = 1_000_000- seed = 1337 octaves = 8+ massivW = 1_000+ massivH = 1_000 defaultMain [ bgroup "2D"- ( baseline2 seed sz- <> benchPerlin2 seed octaves sz- <> benchOpenSimplex2 seed octaves sz- <> benchOpenSimplexSmooth2 seed octaves sz- <> benchValue2 seed octaves sz- <> benchValueCubic2 seed octaves sz- <> benchCombo2 seed octaves sz- <> benchCellular2 seed octaves sz+ ( baseline2 sz+ <> benchPerlin2 octaves sz+ <> benchOpenSimplex2 octaves sz+ <> benchOpenSimplexSmooth2 octaves sz+ <> benchValue2 octaves sz+ <> benchValueCubic2 octaves sz+ <> benchCombo2 octaves sz+ <> benchCellular2 octaves sz ) , bgroup "3D"- ( baseline3 seed sz- <> benchPerlin3 seed octaves sz- <> benchValue3 seed octaves sz- <> benchValueCubic3 seed octaves sz+ ( baseline3 sz+ <> benchPerlin3 octaves sz+ <> benchValue3 octaves sz+ <> benchValueCubic3 octaves sz )+ , bgroup+ "2D massiv"+ ( benchMassivBase2 massivW massivH+ <> benchMassivFractal2 octaves massivW massivH+ )+ , bgroup "FNL compare 2D" benchFnlCompare2D+ , bgroup "FNL compare 3D" benchFnlCompare3D ] -label :: (Typeable a) => String -> Int -> Seed -> Proxy a -> String-label lbl sz seed px =+label :: (Typeable a) => String -> Int -> Proxy a -> String+label lbl sz px = let lbl' = case lbl of "" -> "" v -> v <> ": "- in lbl' <> showsTypeRep (typeRep px) "" <> "[seed=" <> show seed <> "] x" <> show sz+ in lbl' <> showsTypeRep (typeRep px) "" <> " x" <> show sz -createEnv2 :: forall a. (U.Unbox a, MWC.UniformRange a, RealFrac a) => Int -> IO (U.Vector (a, a))+-- most of these functions zero at whole numbers and can short-circuit,+-- so a random offset should give a better signal of real world performance+generate2DCoords+ :: ( UniformRange a+ , RealFrac a+ , StatefulGen g IO+ )+ => g+ -> Int+ -> Int+ -> IO (a, a)+generate2DCoords g i j = do+ offsetX <- uniformRM (0.00001, 0.99999) g+ offsetY <- uniformRM (0.00001, 0.99999) g+ let r = fromIntegral i+ c = fromIntegral j++ pure (r + offsetX, c + offsetY)+{-# INLINE generate2DCoords #-}++createEnv2 :: forall a. (U.Unbox a, UniformRange a, RealFrac a) => Int -> IO (Seed, U.Vector (a, a)) createEnv2 sz = do- g <- MWC.createSystemRandom- U.generateM sz $ \i -> do- -- most of these functions zero at whole numbers and can short-circuit,- -- so a random offset should give a better signal of real world performance- offset <- MWC.uniformRM (0.00001, 0.99999) g- pure $- let r = fromIntegral $ i `div` (sz `div` 2)- c = fromIntegral $ i `mod` (sz `div` 2)- in (r + offset, c + offset)+ g <- newAtomicGenM =<< newStdGen+ seed <- uniformRM (minBound, maxBound) g+ v <- U.generateM sz $ \i ->+ generate2DCoords+ g+ (i `div` (sz `div` 2))+ (i `mod` (sz `div` 2))+ pure (seed, v) {-# INLINE createEnv2 #-} benchMany2 :: forall a- . (Typeable a, MWC.UniformRange a, U.Unbox a, RealFrac a)+ . (Typeable a, UniformRange a, U.Unbox a, RealFrac a) => String -> Int- -> Seed -> Noise2 a -> Benchmark-benchMany2 lbl sz seed f =- env (createEnv2 sz) $ \ ~v ->- bench (label lbl sz seed (Proxy @(U.Vector a))) $+benchMany2 lbl sz f =+ env (createEnv2 sz) $ \ ~(seed, v) ->+ bench (label lbl sz (Proxy @(U.Vector a))) $ nf (U.map (uncurry (noise2At f seed))) v {-# INLINE benchMany2 #-} -baseline2 :: Seed -> Int -> [Benchmark]-baseline2 seed sz =+baseline2 :: Int -> [Benchmark]+baseline2 sz = [ bgroup "baseline2"- [ benchMany2 @Float "" sz seed (const2 1)- , benchMany2 @Double "" sz seed (const2 2)+ [ benchMany2 @Float "" sz (const2 1)+ , benchMany2 @Double "" sz (const2 2) ] ]-{-# INLINE baseline2 #-} -benchPerlin2 :: Seed -> Int -> Int -> [Benchmark]-benchPerlin2 seed octaves sz =+benchPerlin2 :: Int -> Int -> [Benchmark]+benchPerlin2 octaves sz = [ bgroup "perlin2"- [ benchMany2 @Float "" sz seed perlin2- , benchMany2 @Double "" sz seed perlin2- , benchMany2 @Float "fractal" sz seed (fractal2 defaultFractalConfig{octaves} perlin2)- , benchMany2 @Double "fractal" sz seed (fractal2 defaultFractalConfig{octaves} perlin2)- , benchMany2 @Float "ridged" sz seed (ridged2 defaultFractalConfig{octaves} perlin2)- , benchMany2 @Double "ridged" sz seed (ridged2 defaultFractalConfig{octaves} perlin2)- , benchMany2 @Float "billow" sz seed (billow2 defaultFractalConfig{octaves} perlin2)- , benchMany2 @Double "billow" sz seed (billow2 defaultFractalConfig{octaves} perlin2)- , benchMany2 @Float "pingPong" sz seed (pingPong2 defaultFractalConfig{octaves} defaultPingPongStrength perlin2)- , benchMany2 @Double "pingPong" sz seed (pingPong2 defaultFractalConfig{octaves} defaultPingPongStrength perlin2)+ [ benchMany2 @Float "" sz perlin2+ , benchMany2 @Double "" sz perlin2+ , benchMany2 @Float "fractal" sz (fractal2 defaultFractalConfig{octaves} perlin2)+ , benchMany2 @Double "fractal" sz (fractal2 defaultFractalConfig{octaves} perlin2)+ , benchMany2 @Float "ridged" sz (ridged2 defaultFractalConfig{octaves} perlin2)+ , benchMany2 @Double "ridged" sz (ridged2 defaultFractalConfig{octaves} perlin2)+ , benchMany2 @Float "billow" sz (billow2 defaultFractalConfig{octaves} perlin2)+ , benchMany2 @Double "billow" sz (billow2 defaultFractalConfig{octaves} perlin2)+ , benchMany2 @Float "pingPong" sz (pingPong2 defaultFractalConfig{octaves} defaultPingPongStrength perlin2)+ , benchMany2 @Double "pingPong" sz (pingPong2 defaultFractalConfig{octaves} defaultPingPongStrength perlin2) ] ]-{-# INLINE benchPerlin2 #-} -benchOpenSimplex2 :: Seed -> Int -> Int -> [Benchmark]-benchOpenSimplex2 seed octaves sz =+benchOpenSimplex2 :: Int -> Int -> [Benchmark]+benchOpenSimplex2 octaves sz = [ bgroup "openSimplex2"- [ benchMany2 @Float "" sz seed openSimplex2- , benchMany2 @Double "" sz seed openSimplex2- , benchMany2 @Float "fractal" sz seed (fractal2 defaultFractalConfig{octaves} openSimplex2)- , benchMany2 @Double "fractal" sz seed (fractal2 defaultFractalConfig{octaves} openSimplex2)- , benchMany2 @Float "ridged" sz seed (ridged2 defaultFractalConfig{octaves} openSimplex2)- , benchMany2 @Double "ridged" sz seed (ridged2 defaultFractalConfig{octaves} openSimplex2)- , benchMany2 @Float "billow" sz seed (billow2 defaultFractalConfig{octaves} openSimplex2)- , benchMany2 @Double "billow" sz seed (billow2 defaultFractalConfig{octaves} openSimplex2)- , benchMany2 @Float "pingPong" sz seed (pingPong2 defaultFractalConfig{octaves} defaultPingPongStrength openSimplex2)- , benchMany2 @Double "pingPong" sz seed (pingPong2 defaultFractalConfig{octaves} defaultPingPongStrength openSimplex2)+ [ benchMany2 @Float "" sz openSimplex2+ , benchMany2 @Double "" sz openSimplex2+ , benchMany2 @Float "fractal" sz (fractal2 defaultFractalConfig{octaves} openSimplex2)+ , benchMany2 @Double "fractal" sz (fractal2 defaultFractalConfig{octaves} openSimplex2)+ , benchMany2 @Float "ridged" sz (ridged2 defaultFractalConfig{octaves} openSimplex2)+ , benchMany2 @Double "ridged" sz (ridged2 defaultFractalConfig{octaves} openSimplex2)+ , benchMany2 @Float "billow" sz (billow2 defaultFractalConfig{octaves} openSimplex2)+ , benchMany2 @Double "billow" sz (billow2 defaultFractalConfig{octaves} openSimplex2)+ , benchMany2 @Float "pingPong" sz (pingPong2 defaultFractalConfig{octaves} defaultPingPongStrength openSimplex2)+ , benchMany2 @Double "pingPong" sz (pingPong2 defaultFractalConfig{octaves} defaultPingPongStrength openSimplex2) ] ]-{-# INLINE benchOpenSimplex2 #-} -benchOpenSimplexSmooth2 :: Seed -> Int -> Int -> [Benchmark]-benchOpenSimplexSmooth2 seed octaves sz =+benchOpenSimplexSmooth2 :: Int -> Int -> [Benchmark]+benchOpenSimplexSmooth2 octaves sz = [ bgroup "superSimplex2"- [ benchMany2 @Float "" sz seed superSimplex2- , benchMany2 @Double "" sz seed superSimplex2- , benchMany2 @Float "fractal" sz seed (fractal2 defaultFractalConfig{octaves} superSimplex2)- , benchMany2 @Double "fractal" sz seed (fractal2 defaultFractalConfig{octaves} superSimplex2)- , benchMany2 @Float "ridged" sz seed (ridged2 defaultFractalConfig{octaves} superSimplex2)- , benchMany2 @Double "ridged" sz seed (ridged2 defaultFractalConfig{octaves} superSimplex2)- , benchMany2 @Float "billow" sz seed (billow2 defaultFractalConfig{octaves} superSimplex2)- , benchMany2 @Double "billow" sz seed (billow2 defaultFractalConfig{octaves} superSimplex2)- , benchMany2 @Float "pingPong" sz seed (pingPong2 defaultFractalConfig{octaves} defaultPingPongStrength superSimplex2)- , benchMany2 @Double "pingPong" sz seed (pingPong2 defaultFractalConfig{octaves} defaultPingPongStrength superSimplex2)+ [ benchMany2 @Float "" sz superSimplex2+ , benchMany2 @Double "" sz superSimplex2+ , benchMany2 @Float "fractal" sz (fractal2 defaultFractalConfig{octaves} superSimplex2)+ , benchMany2 @Double "fractal" sz (fractal2 defaultFractalConfig{octaves} superSimplex2)+ , benchMany2 @Float "ridged" sz (ridged2 defaultFractalConfig{octaves} superSimplex2)+ , benchMany2 @Double "ridged" sz (ridged2 defaultFractalConfig{octaves} superSimplex2)+ , benchMany2 @Float "billow" sz (billow2 defaultFractalConfig{octaves} superSimplex2)+ , benchMany2 @Double "billow" sz (billow2 defaultFractalConfig{octaves} superSimplex2)+ , benchMany2 @Float "pingPong" sz (pingPong2 defaultFractalConfig{octaves} defaultPingPongStrength superSimplex2)+ , benchMany2 @Double "pingPong" sz (pingPong2 defaultFractalConfig{octaves} defaultPingPongStrength superSimplex2) ] ]-{-# INLINE benchOpenSimplexSmooth2 #-} -benchValue2 :: Seed -> Int -> Int -> [Benchmark]-benchValue2 seed octaves sz =+benchValue2 :: Int -> Int -> [Benchmark]+benchValue2 octaves sz = [ bgroup "value2"- [ benchMany2 @Float "" sz seed value2- , benchMany2 @Double "" sz seed value2- , benchMany2 @Float "fractal" sz seed (fractal2 defaultFractalConfig{octaves} value2)- , benchMany2 @Double "fractal" sz seed (fractal2 defaultFractalConfig{octaves} value2)- , benchMany2 @Float "ridged" sz seed (ridged2 defaultFractalConfig{octaves} value2)- , benchMany2 @Double "ridged" sz seed (ridged2 defaultFractalConfig{octaves} value2)- , benchMany2 @Float "billow" sz seed (billow2 defaultFractalConfig{octaves} value2)- , benchMany2 @Double "billow" sz seed (billow2 defaultFractalConfig{octaves} value2)- , benchMany2 @Float "pingPong" sz seed (pingPong2 defaultFractalConfig{octaves} defaultPingPongStrength value2)- , benchMany2 @Double "pingPong" sz seed (pingPong2 defaultFractalConfig{octaves} defaultPingPongStrength value2)+ [ benchMany2 @Float "" sz value2+ , benchMany2 @Double "" sz value2+ , benchMany2 @Float "fractal" sz (fractal2 defaultFractalConfig{octaves} value2)+ , benchMany2 @Double "fractal" sz (fractal2 defaultFractalConfig{octaves} value2)+ , benchMany2 @Float "ridged" sz (ridged2 defaultFractalConfig{octaves} value2)+ , benchMany2 @Double "ridged" sz (ridged2 defaultFractalConfig{octaves} value2)+ , benchMany2 @Float "billow" sz (billow2 defaultFractalConfig{octaves} value2)+ , benchMany2 @Double "billow" sz (billow2 defaultFractalConfig{octaves} value2)+ , benchMany2 @Float "pingPong" sz (pingPong2 defaultFractalConfig{octaves} defaultPingPongStrength value2)+ , benchMany2 @Double "pingPong" sz (pingPong2 defaultFractalConfig{octaves} defaultPingPongStrength value2) ] ]-{-# INLINE benchValue2 #-} -benchValueCubic2 :: Seed -> Int -> Int -> [Benchmark]-benchValueCubic2 seed octaves sz =+benchValueCubic2 :: Int -> Int -> [Benchmark]+benchValueCubic2 octaves sz = [ bgroup "valueCubic2"- [ benchMany2 @Float "" sz seed valueCubic2- , benchMany2 @Double "" sz seed valueCubic2- , benchMany2 @Float "fractal" sz seed (fractal2 defaultFractalConfig{octaves} valueCubic2)- , benchMany2 @Double "fractal" sz seed (fractal2 defaultFractalConfig{octaves} valueCubic2)- , benchMany2 @Float "ridged" sz seed (ridged2 defaultFractalConfig{octaves} valueCubic2)- , benchMany2 @Double "ridged" sz seed (ridged2 defaultFractalConfig{octaves} valueCubic2)- , benchMany2 @Float "billow" sz seed (billow2 defaultFractalConfig{octaves} valueCubic2)- , benchMany2 @Double "billow" sz seed (billow2 defaultFractalConfig{octaves} valueCubic2)- , benchMany2 @Float "pingPong" sz seed (pingPong2 defaultFractalConfig{octaves} defaultPingPongStrength valueCubic2)- , benchMany2 @Double "pingPong" sz seed (pingPong2 defaultFractalConfig{octaves} defaultPingPongStrength valueCubic2)+ [ benchMany2 @Float "" sz valueCubic2+ , benchMany2 @Double "" sz valueCubic2+ , benchMany2 @Float "fractal" sz (fractal2 defaultFractalConfig{octaves} valueCubic2)+ , benchMany2 @Double "fractal" sz (fractal2 defaultFractalConfig{octaves} valueCubic2)+ , benchMany2 @Float "ridged" sz (ridged2 defaultFractalConfig{octaves} valueCubic2)+ , benchMany2 @Double "ridged" sz (ridged2 defaultFractalConfig{octaves} valueCubic2)+ , benchMany2 @Float "billow" sz (billow2 defaultFractalConfig{octaves} valueCubic2)+ , benchMany2 @Double "billow" sz (billow2 defaultFractalConfig{octaves} valueCubic2)+ , benchMany2 @Float "pingPong" sz (pingPong2 defaultFractalConfig{octaves} defaultPingPongStrength valueCubic2)+ , benchMany2 @Double "pingPong" sz (pingPong2 defaultFractalConfig{octaves} defaultPingPongStrength valueCubic2) ] ]-{-# INLINE benchValueCubic2 #-} -benchCombo2 :: Seed -> Int -> Int -> [Benchmark]-benchCombo2 seed octaves sz =+benchCombo2 :: Int -> Int -> [Benchmark]+benchCombo2 octaves sz = [ bgroup "numeric combination"- [ benchMany2 @Float "perlin * opensimplex/2" sz seed $+ [ benchMany2 @Float "perlin * opensimplex/2" sz $ openSimplex2 / 2 * perlin2- , benchMany2 @Float "(4 * perlin) / 4" sz seed $+ , benchMany2 @Float "(4 * perlin) / 4" sz $ 4 * perlin2 / 4- , benchMany2 @Float "(perlin + perlin + perlin + perlin) / 4" sz seed $+ , benchMany2 @Float "(perlin + perlin + perlin + perlin) / 4" sz $ (perlin2 + perlin2 + perlin2 + perlin2) / 4- , benchMany2 @Float "fractal (perlin * opensimplex/2)" sz seed $+ , benchMany2 @Float "fractal (perlin * opensimplex/2)" sz $ fractal2 defaultFractalConfig{octaves} (openSimplex2 / 2 * perlin2)- , benchMany2 @Float "fractal perlin * fractal opensimplex" sz seed $+ , benchMany2 @Float "fractal perlin * fractal opensimplex" sz $ fractal2 defaultFractalConfig{octaves} perlin2 * fractal2 defaultFractalConfig{octaves} openSimplex2 ] ]-{-# INLINE benchCombo2 #-} -benchCellular2 :: Seed -> Int -> Int -> [Benchmark]-benchCellular2 seed _ sz =+benchCellular2 :: Int -> Int -> [Benchmark]+benchCellular2 _ sz = [ bgroup "cellular2"- ( benches @Float Proxy- <> benches @Double Proxy- )+ [ benchMany2 @Float+ "DistEuclidean CellValue"+ sz+ (cellular2 defaultCellularConfig{cellularDistanceFn = DistEuclidean, cellularResult = CellValue})+ , benchMany2 @Float+ "DistEuclidean Distance2Add"+ sz+ (cellular2 defaultCellularConfig{cellularDistanceFn = DistEuclidean, cellularResult = Distance2Add})+ , benchMany2 @Float+ "DistManhattan CellValue"+ sz+ (cellular2 defaultCellularConfig{cellularDistanceFn = DistManhattan, cellularResult = CellValue})+ , benchMany2 @Float+ "DistManhattan Distance2Add"+ sz+ (cellular2 defaultCellularConfig{cellularDistanceFn = DistManhattan, cellularResult = Distance2Add})+ , benchMany2 @Double+ "DistEuclidean CellValue"+ sz+ (cellular2 defaultCellularConfig{cellularDistanceFn = DistEuclidean, cellularResult = CellValue})+ , benchMany2 @Double+ "DistEuclidean Distance2Add"+ sz+ (cellular2 defaultCellularConfig{cellularDistanceFn = DistEuclidean, cellularResult = Distance2Add})+ , benchMany2 @Double+ "DistManhattan CellValue"+ sz+ (cellular2 defaultCellularConfig{cellularDistanceFn = DistManhattan, cellularResult = CellValue})+ , benchMany2 @Double+ "DistManhattan Distance2Add"+ sz+ (cellular2 defaultCellularConfig{cellularDistanceFn = DistManhattan, cellularResult = Distance2Add})+ ] ]- where- benches- :: forall a. (Typeable a, MWC.UniformRange a, U.Unbox a, RealFrac a, Floating a) => Proxy a -> [Benchmark]- benches _ =- [ benchMany2 @a (show d <> " " <> show r) sz seed (cellular2 config)- | d <- [DistEuclidean]- , r <- [CellValue, Distance2Add]- , let config = defaultCellularConfig{cellularDistanceFn = d, cellularResult = r}- ]- {-# INLINE benches #-}-{-# INLINE benchCellular2 #-} -createEnv3 :: forall a m. (Monad m, U.Unbox a, Num a) => Int -> m (U.Vector (a, a, a))+-- | Create environment for FNL-style 2D benchmarks with integer-aligned coordinates+-- Mimics FastNoiseLite's benchmark methodology exactly:+-- for(y = 0; y < gridSize; y++)+-- for(x = 0; x < gridSize; x++)+-- noise(float(x), float(y))+createEnvFnl2 :: Int -> IO (Seed, U.Vector (Float, Float))+createEnvFnl2 gridSize = do+ g <- newAtomicGenM =<< newStdGen+ seed <- uniformRM (minBound, maxBound) g+ let v = U.generate (gridSize * gridSize) $ \i ->+ let x = fromIntegral (i `mod` gridSize) :: Float+ y = fromIntegral (i `div` gridSize) :: Float+ in (x, y)+ pure (seed, v)+{-# INLINE createEnvFnl2 #-}++-- | Benchmark for FNL comparison (integer coordinates, Float only)+-- Uses foldl' to avoid vector materialization overhead, matching FNL's DoNotOptimize approach+-- Sums results to prevent DCE while keeping overhead minimal+benchFnlCompare2+ :: String+ -> Int+ -> Noise2 Float+ -> Benchmark+benchFnlCompare2 lbl gridSize f =+ env (createEnvFnl2 gridSize) $ \ ~(seed, v) ->+ bench (lbl <> ": Float (FNL grid) x" <> show (gridSize * gridSize)) $+ nf (\vec -> U.foldl' (\acc (x, y) -> acc + (noise2At f seed) x y) 0 vec) v+{-# INLINE benchFnlCompare2 #-}++-- | FNL-style 2D benchmarks: 512x512 grid with integer coordinates+benchFnlCompare2D :: [Benchmark]+benchFnlCompare2D =+ let gridSize = 512+ in [ bgroup+ "FNL compare"+ [ benchFnlCompare2 "value2" gridSize value2+ , benchFnlCompare2 "perlin2" gridSize perlin2+ , benchFnlCompare2 "openSimplex2" gridSize openSimplex2+ , benchFnlCompare2 "superSimplex2" gridSize superSimplex2+ , benchFnlCompare2 "valueCubic2" gridSize valueCubic2+ , benchFnlCompare2+ "cellular2 (Distance)"+ gridSize+ (cellular2 defaultCellularConfig{cellularDistanceFn = DistEuclidean, cellularResult = Distance})+ ]+ ]++createEnv3 :: (U.Unbox a, UniformRange a, RealFrac a) => Int -> IO (Seed, U.Vector (a, a, a)) createEnv3 sz = do- !ixs <- U.generateM sz $ \i ->- pure $- let d = sz `div` 3- !x = fromIntegral $ i `div` d `mod` d- !y = fromIntegral $ i `div` (d * d)- !z = fromIntegral $ i `div` d- in (x, y, z)- pure ixs+ g <- newAtomicGenM =<< newStdGen+ seed <- uniformRM (minBound, maxBound) g+ offsetX <- uniformRM (0.00001, 0.99999) g+ offsetY <- uniformRM (0.00001, 0.99999) g+ offsetZ <- uniformRM (0.00001, 0.99999) g+ !ixs <- U.generateM sz $ \i -> do+ let d = sz `div` 3+ !x = fromIntegral $ i `div` d `mod` d+ !y = fromIntegral $ i `div` (d * d)+ !z = fromIntegral $ i `div` d+ pure (x + offsetX, y + offsetY, z + offsetZ)+ pure (seed, ixs) {-# INLINE createEnv3 #-} benchMany3 :: forall a- . (Typeable a, RealFrac a, U.Unbox a)+ . (Typeable a, UniformRange a, RealFrac a, U.Unbox a) => String -> Int- -> Seed -> Noise3 a -> Benchmark-benchMany3 lbl sz seed f =- env (createEnv3 sz) $ \ ~v ->- bench (label lbl sz seed (Proxy @(U.Vector a))) $+benchMany3 lbl sz f =+ env (createEnv3 sz) $ \ ~(seed, v) ->+ bench (label lbl sz (Proxy @(U.Vector a))) $ nf (U.map (\(x, y, z) -> noise3At f seed x y z)) v {-# INLINE benchMany3 #-} -baseline3 :: Seed -> Int -> [Benchmark]-baseline3 seed sz =+baseline3 :: Int -> [Benchmark]+baseline3 sz = [ bgroup "baseline3"- [ benchMany3 @Float "" sz seed (const3 1)- , benchMany3 @Double "" sz seed (const3 2)+ [ benchMany3 @Float "" sz (const3 1)+ , benchMany3 @Double "" sz (const3 2) ] ]-{-# INLINE baseline3 #-} -benchPerlin3 :: Seed -> Int -> Int -> [Benchmark]-benchPerlin3 seed octaves sz =+benchPerlin3 :: Int -> Int -> [Benchmark]+benchPerlin3 octaves sz = [ bgroup "perlin3"- [ benchMany3 @Float "" sz seed perlin3- , benchMany3 @Double "" sz seed perlin3- , benchMany3 @Float "fractal" sz seed (fractal3 defaultFractalConfig{octaves} perlin3)- , benchMany3 @Double "fractal" sz seed (fractal3 defaultFractalConfig{octaves} perlin3)- , benchMany3 @Float "ridged" sz seed (ridged3 defaultFractalConfig{octaves} perlin3)- , benchMany3 @Double "ridged" sz seed (ridged3 defaultFractalConfig{octaves} perlin3)- , benchMany3 @Float "billow" sz seed (billow3 defaultFractalConfig{octaves} perlin3)- , benchMany3 @Double "billow" sz seed (billow3 defaultFractalConfig{octaves} perlin3)- , benchMany3 @Float "pingPong" sz seed (pingPong3 defaultFractalConfig{octaves} defaultPingPongStrength perlin3)- , benchMany3 @Double "pingPong" sz seed (pingPong3 defaultFractalConfig{octaves} defaultPingPongStrength perlin3)+ [ benchMany3 @Float "" sz perlin3+ , benchMany3 @Double "" sz perlin3+ , benchMany3 @Float "fractal" sz (fractal3 defaultFractalConfig{octaves} perlin3)+ , benchMany3 @Double "fractal" sz (fractal3 defaultFractalConfig{octaves} perlin3)+ , benchMany3 @Float "ridged" sz (ridged3 defaultFractalConfig{octaves} perlin3)+ , benchMany3 @Double "ridged" sz (ridged3 defaultFractalConfig{octaves} perlin3)+ , benchMany3 @Float "billow" sz (billow3 defaultFractalConfig{octaves} perlin3)+ , benchMany3 @Double "billow" sz (billow3 defaultFractalConfig{octaves} perlin3)+ , benchMany3 @Float "pingPong" sz (pingPong3 defaultFractalConfig{octaves} defaultPingPongStrength perlin3)+ , benchMany3 @Double "pingPong" sz (pingPong3 defaultFractalConfig{octaves} defaultPingPongStrength perlin3) ] ]-{-# INLINE benchPerlin3 #-} -benchValue3 :: Seed -> Int -> Int -> [Benchmark]-benchValue3 seed octaves sz =+benchValue3 :: Int -> Int -> [Benchmark]+benchValue3 octaves sz = [ bgroup "value3"- [ benchMany3 @Float "" sz seed value3- , benchMany3 @Double "" sz seed value3- , benchMany3 @Float "fractal" sz seed (fractal3 defaultFractalConfig{octaves} value3)- , benchMany3 @Double "fractal" sz seed (fractal3 defaultFractalConfig{octaves} value3)- , benchMany3 @Float "ridged" sz seed (ridged3 defaultFractalConfig{octaves} value3)- , benchMany3 @Double "ridged" sz seed (ridged3 defaultFractalConfig{octaves} value3)- , benchMany3 @Float "billow" sz seed (billow3 defaultFractalConfig{octaves} value3)- , benchMany3 @Double "billow" sz seed (billow3 defaultFractalConfig{octaves} value3)- , benchMany3 @Float "pingPong" sz seed (pingPong3 defaultFractalConfig{octaves} defaultPingPongStrength value3)- , benchMany3 @Double "pingPong" sz seed (pingPong3 defaultFractalConfig{octaves} defaultPingPongStrength value3)+ [ benchMany3 @Float "" sz value3+ , benchMany3 @Double "" sz value3+ , benchMany3 @Float "fractal" sz (fractal3 defaultFractalConfig{octaves} value3)+ , benchMany3 @Double "fractal" sz (fractal3 defaultFractalConfig{octaves} value3)+ , benchMany3 @Float "ridged" sz (ridged3 defaultFractalConfig{octaves} value3)+ , benchMany3 @Double "ridged" sz (ridged3 defaultFractalConfig{octaves} value3)+ , benchMany3 @Float "billow" sz (billow3 defaultFractalConfig{octaves} value3)+ , benchMany3 @Double "billow" sz (billow3 defaultFractalConfig{octaves} value3)+ , benchMany3 @Float "pingPong" sz (pingPong3 defaultFractalConfig{octaves} defaultPingPongStrength value3)+ , benchMany3 @Double "pingPong" sz (pingPong3 defaultFractalConfig{octaves} defaultPingPongStrength value3) ] ]-{-# INLINE benchValue3 #-} -benchValueCubic3 :: Seed -> Int -> Int -> [Benchmark]-benchValueCubic3 seed octaves sz =+benchValueCubic3 :: Int -> Int -> [Benchmark]+benchValueCubic3 octaves sz = [ bgroup "valueCubic3"- [ benchMany3 @Float "" sz seed valueCubic3- , benchMany3 @Double "" sz seed valueCubic3- , benchMany3 @Float "fractal" sz seed (fractal3 defaultFractalConfig{octaves} valueCubic3)- , benchMany3 @Double "fractal" sz seed (fractal3 defaultFractalConfig{octaves} valueCubic3)- , benchMany3 @Float "ridged" sz seed (ridged3 defaultFractalConfig{octaves} valueCubic3)- , benchMany3 @Double "ridged" sz seed (ridged3 defaultFractalConfig{octaves} valueCubic3)- , benchMany3 @Float "billow" sz seed (billow3 defaultFractalConfig{octaves} valueCubic3)- , benchMany3 @Double "billow" sz seed (billow3 defaultFractalConfig{octaves} valueCubic3)- , benchMany3 @Float "pingPong" sz seed (pingPong3 defaultFractalConfig{octaves} defaultPingPongStrength valueCubic3)- , benchMany3 @Double "pingPong" sz seed (pingPong3 defaultFractalConfig{octaves} defaultPingPongStrength valueCubic3)+ [ benchMany3 @Float "" sz valueCubic3+ , benchMany3 @Double "" sz valueCubic3+ , benchMany3 @Float "fractal" sz (fractal3 defaultFractalConfig{octaves} valueCubic3)+ , benchMany3 @Double "fractal" sz (fractal3 defaultFractalConfig{octaves} valueCubic3)+ , benchMany3 @Float "ridged" sz (ridged3 defaultFractalConfig{octaves} valueCubic3)+ , benchMany3 @Double "ridged" sz (ridged3 defaultFractalConfig{octaves} valueCubic3)+ , benchMany3 @Float "billow" sz (billow3 defaultFractalConfig{octaves} valueCubic3)+ , benchMany3 @Double "billow" sz (billow3 defaultFractalConfig{octaves} valueCubic3)+ , benchMany3 @Float "pingPong" sz (pingPong3 defaultFractalConfig{octaves} defaultPingPongStrength valueCubic3)+ , benchMany3 @Double "pingPong" sz (pingPong3 defaultFractalConfig{octaves} defaultPingPongStrength valueCubic3) ] ]-{-# INLINE benchValueCubic3 #-}++-- | Create environment for FNL-style 3D benchmarks with integer-aligned coordinates+-- Mimics FastNoiseLite's benchmark methodology exactly:+-- for(z = 0; z < gridSize; z++)+-- for(y = 0; y < gridSize; y++)+-- for(x = 0; x < gridSize; x++)+-- noise(float(x), float(y), float(z))+createEnvFnl3 :: Int -> IO (Seed, U.Vector (Float, Float, Float))+createEnvFnl3 gridSize = do+ g <- newAtomicGenM =<< newStdGen+ seed <- uniformRM (minBound, maxBound) g+ let gridSq = gridSize * gridSize+ v = U.generate (gridSize * gridSize * gridSize) $ \i ->+ let x = fromIntegral (i `mod` gridSize) :: Float+ y = fromIntegral ((i `div` gridSize) `mod` gridSize) :: Float+ z = fromIntegral (i `div` gridSq) :: Float+ in (x, y, z)+ pure (seed, v)+{-# INLINE createEnvFnl3 #-}++-- | Benchmark for FNL 3D comparison (integer coordinates, Float only)+-- Uses foldl' to avoid vector materialization overhead, matching FNL's DoNotOptimize approach+-- Sums results to prevent DCE while keeping overhead minimal+benchFnlCompare3+ :: String+ -> Int+ -> Noise3 Float+ -> Benchmark+benchFnlCompare3 lbl gridSize f =+ env (createEnvFnl3 gridSize) $ \ ~(seed, v) ->+ bench (lbl <> ": Float (FNL grid) x" <> show (gridSize * gridSize * gridSize)) $+ nf (\vec -> U.foldl' (\acc (x, y, z) -> acc + noise3At f seed x y z) 0 vec) v+{-# INLINE benchFnlCompare3 #-}++-- | FNL-style 3D benchmarks: 64x64x64 grid with integer coordinates+benchFnlCompare3D :: [Benchmark]+benchFnlCompare3D =+ let gridSize = 64+ in [ bgroup+ "FNL compare"+ [ benchFnlCompare3 "value3" gridSize value3+ , benchFnlCompare3 "perlin3" gridSize perlin3+ , benchFnlCompare3 "valueCubic3" gridSize valueCubic3+ ]+ ]++benchMassiv2+ :: forall a+ . (Typeable a, U.Unbox a, RealFrac a, UniformRange a)+ => String+ -> Int+ -> Int+ -> Noise2 a+ -> Benchmark+benchMassiv2 lbl !w !h noiseF =+ env+ ( do+ g <- newAtomicGenM =<< newStdGen+ seed <- uniformRM (minBound, maxBound) g+ -- This intentionally breaks the optimizer's ability to DCE. If we try to calculate+ -- inline it seems that GHC is smart enough to figure out that the whole-number+ -- integral points involve relatively simple code paths.+ (arr :: MA.Array MA.U MA.Ix2 (a, a)) <-+ MA.generateArray @MA.U MA.Par (MA.Sz2 h w) $ \(i MA.:. j) ->+ generate2DCoords g i j++ pure (seed, arr)+ )+ $ \ ~(seed, arr) ->+ bench (label lbl (w * h) (Proxy @a)) $+ nf+ ( MA.computeP @MA.U+ . MA.map+ ( \(!x, !y) ->+ noise2At noiseF seed x y+ )+ )+ arr+{-# INLINE benchMassiv2 #-}++benchMassivBase2 :: Int -> Int -> [Benchmark]+benchMassivBase2 !w !h =+ [ bgroup+ "massiv base2"+ [ benchMassiv2 @Float "perlin2" w h perlin2+ , benchMassiv2 @Double "perlin2" w h perlin2+ , benchMassiv2 @Float "openSimplex2" w h openSimplex2+ , benchMassiv2 @Double "openSimplex2" w h openSimplex2+ , benchMassiv2 @Float "superSimplex2" w h superSimplex2+ , benchMassiv2 @Double "superSimplex2" w h superSimplex2+ , benchMassiv2 @Float "value2" w h value2+ , benchMassiv2 @Double "value2" w h value2+ , benchMassiv2 @Float "valueCubic2" w h valueCubic2+ , benchMassiv2 @Double "valueCubic2" w h valueCubic2+ , benchMassiv2 @Float+ "cellular2"+ w+ h+ (cellular2 defaultCellularConfig{cellularDistanceFn = DistEuclidean, cellularResult = CellValue})+ , benchMassiv2 @Double+ "cellular2"+ w+ h+ (cellular2 defaultCellularConfig{cellularDistanceFn = DistEuclidean, cellularResult = CellValue})+ ]+ ]++benchMassivFractal2 :: Int -> Int -> Int -> [Benchmark]+benchMassivFractal2 octaves w h =+ [ bgroup+ "massiv fractal2"+ [ benchMassiv2 @Float "perlin2 fractal" w h (fractal2 defaultFractalConfig{octaves} perlin2)+ , benchMassiv2 @Double "perlin2 fractal" w h (fractal2 defaultFractalConfig{octaves} perlin2)+ , benchMassiv2 @Float "value2 fractal" w h (fractal2 defaultFractalConfig{octaves} value2)+ , benchMassiv2 @Double "value2 fractal" w h (fractal2 defaultFractalConfig{octaves} value2)+ , benchMassiv2 @Float "openSimplex2 fractal" w h (fractal2 defaultFractalConfig{octaves} openSimplex2)+ , benchMassiv2 @Double "openSimplex2 fractal" w h (fractal2 defaultFractalConfig{octaves} openSimplex2)+ , benchMassiv2 @Float "superSimplex2 fractal" w h (fractal2 defaultFractalConfig{octaves} superSimplex2)+ , benchMassiv2 @Double "superSimplex2 fractal" w h (fractal2 defaultFractalConfig{octaves} superSimplex2)+ ]+ ]
pure-noise.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: pure-noise-version: 0.2.0.0+version: 0.2.1.0 synopsis: High-performance composable noise generation (Perlin, Simplex, Cellular) description: A high-performance noise generation library ported from FastNoiseLite. Provides N-dimensional noise functions (Perlin, OpenSimplex, SuperSimplex,@@ -58,9 +58,16 @@ type: exitcode-stdio-1.0 main-is: Driver.hs other-modules:+ CellularSpec+ FractalSpec+ Golden.Util Noise2Spec Noise3Spec+ OpenSimplexSpec PerlinSpec+ SuperSimplexSpec+ ValueCubicSpec+ ValueSpec Paths_pure_noise autogen-modules: Paths_pure_noise@@ -68,13 +75,23 @@ test ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -Wno-missing-export-lists -threaded -rtsopts -with-rtsopts=-N build-depends:- base >=4.16 && <5+ JuicyPixels ==3.3.*+ , aeson >=2.0 && <2.3+ , aeson-pretty+ , base >=4.16 && <5+ , bytestring+ , directory+ , filepath+ , massiv >=1.0 && <2.0 , primitive >=0.8 && <0.10 , pure-noise , tasty , tasty-discover+ , tasty-golden , tasty-hunit , tasty-quickcheck+ , text+ , typed-process default-language: GHC2021 benchmark pure-noise-bench@@ -91,9 +108,10 @@ build-depends: base >=4.16 && <5 , deepseq- , mwc-random+ , massiv >=1.0 && <2.0 , primitive >=0.8 && <0.10 , pure-noise+ , random , tasty , tasty-bench , vector <=0.14
src/Numeric/Noise.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE Strict #-} -- |@@ -6,9 +7,10 @@ -- -- Performant noise generation with composable noise functions. ----- Noise functions are wrapped in 'Noise2' and 'Noise3' newtypes that abstract over--- the seed and coordinate parameters. These can be composed using 'Num' or 'Fractional'--- methods with minimal performance overhead.+-- Noise functions are built on a unified 'Noise' type that abstracts over+-- the seed and coordinate parameters. 'Noise2' and 'Noise3' are convenient+-- type aliases for 2D and 3D noise. These can be composed using algebraically+-- with minimal performance overhead. -- -- Noise values are generally clamped to @[-1, 1]@, though some functions may -- occasionally produce values slightly outside this range.@@ -40,43 +42,108 @@ -- fbm :: (RealFrac a) => Noise.Noise2 a -- fbm = Noise.fractal2 Noise.defaultFractalConfig Noise.perlin2 -- @+--+-- == Advanced Features+--+-- Generate 1D noise by slicing higher-dimensional noise:+--+-- @+-- noise1d :: Noise.Noise1 Float+-- noise1d = Noise.sliceY2 0.5 Noise.perlin2+--+-- evaluate :: Float -> Float+-- evaluate = Noise.noise1At noise1d 0+-- @+--+-- Transform coordinates with 'warp':+--+-- @+-- scaledAndLayered :: Noise.Noise2 Float+-- scaledAndLayered =+-- Noise.warp (\\(x, y) -> (x * 2, y * 2)) Noise.perlin2+-- + fmap (logBase 2) Noise.perlin2+-- @+--+-- Layer independent noise with 'reseed' or 'next2':+--+-- @+-- layered :: Noise.Noise2 Float+-- layered = Noise.perlin2 + Noise.next2 Noise.perlin2 \/ 2+-- @ module Numeric.Noise (- -- * Core Types+ -- * Noise -- - -- | 'Noise2' and 'Noise3' are newtypes wrapping noise functions. They can be- -- unwrapped with 'noise2At' and 'noise3At' respectively.+ -- | 'Noise1', 'Noise2', and 'Noise3' are type aliases for 1D, 2D, and 3D noise+ -- functions built on the unified 'Noise' type. They can be evaluated with+ -- 'noise1At', 'noise2At', and 'noise3At' respectively. --- -- 'Seed' is a 'Word64' value used for deterministic noise generation.- module NoiseTypes,+ -- 'Seed' is a 'Data.Word.Word64' value used for deterministic noise generation.+ Noise,+ Noise1,+ Noise1',+ Noise2,+ Noise2',+ Noise3,+ Noise3',+ Seed, - -- * Noise evaluation+ -- * Accessors+ noise1At, noise2At, noise3At, - -- ** 2D Noise- const2,- cellular2,+ -- * Noise functions++ -- ** Perlin+ perlin2,+ perlin3,++ -- ** OpenSimplex openSimplex2,++ -- ** OpenSimplex2S superSimplex2,- perlin2,++ -- ** Cellular+ cellular2,++ -- *** Configuration+ CellularConfig (..),+ defaultCellularConfig,+ CellularDistanceFn (..),+ CellularResult (..),++ -- ** Value value2, valueCubic2,-- -- ** 3D Noise- const3,- perlin3, value3, valueCubic3, - -- * Noise manipulation+ -- ** Constant fields+ const2,+ const3, - -- ** Math utility functions- module NoiseUtility,+ -- * Noise alteration - -- ** Fractal noise composition+ -- ** Altering values+ remap,+ -- ** Altering parameters+ warp,+ reseed,+ next2,+ next3, + -- ** Slicing (projecting)+ sliceX2,+ sliceX3,+ sliceY2,+ sliceY3,+ sliceZ3,++ -- * Fractals+ -- -- | Fractal noise combines multiple octaves at different frequencies and@@ -85,17 +152,11 @@ -- For custom fractal implementations using modifier functions, see -- "Numeric.Noise.Fractal". - -- *** Configuration- FractalConfig (..),- defaultFractalConfig,- PingPongStrength (..),- defaultPingPongStrength,-- -- *** Fractal Brownian Motion (FBM)+ -- ** Fractal Brownian Motion (FBM) fractal2, fractal3, - -- *** Fractal variants+ -- ** Fractal variants billow2, billow3, ridged2,@@ -103,61 +164,37 @@ pingPong2, pingPong3, - -- ** Cellular noise configuration-- ---- -- | Cellular (Worley) noise creates patterns based on distances to- -- randomly distributed cell points.-- -- *** Configuration- CellularConfig (..),- defaultCellularConfig,- CellularDistanceFn (..),- CellularResult (..),-) where+ -- ** Configuration+ FractalConfig (..),+ defaultFractalConfig,+ PingPongStrength (..),+ defaultPingPongStrength, -import Numeric.Noise.Cellular (CellularConfig, CellularDistanceFn (..), CellularResult (..), defaultCellularConfig)-import Numeric.Noise.Cellular qualified as Cellular-import Numeric.Noise.Fractal-import Numeric.Noise.Internal-import Numeric.Noise.Internal as NoiseTypes (- Noise2,- Noise3,- Seed,- )-import Numeric.Noise.Internal as NoiseUtility (+ -- * Math utilities clamp, clamp2, clamp3, cubicInterp, hermiteInterp, lerp,- next2,- next3, quinticInterp,- )+) where++import Numeric.Noise.Cellular (CellularConfig, CellularDistanceFn (..), CellularResult (..), defaultCellularConfig)+import Numeric.Noise.Cellular qualified as Cellular+import Numeric.Noise.Fractal+import Numeric.Noise.Internal import Numeric.Noise.OpenSimplex qualified as OpenSimplex import Numeric.Noise.Perlin qualified as Perlin import Numeric.Noise.SuperSimplex qualified as SuperSimplex import Numeric.Noise.Value qualified as Value import Numeric.Noise.ValueCubic qualified as ValueCubic --- | Evaluate a 2D noise function at the given coordinates with the given seed.-noise2At- :: Noise2 a- -> Seed- -- ^ deterministic seed- -> a- -- ^ x coordinate- -> a- -- ^ y coordinate- -> a-noise2At = unNoise2-{-# INLINE noise2At #-}- -- | 2D Cellular (Worley) noise. Configure with 'CellularConfig' to control -- distance functions and return values.+--+-- Cellular noise creates patterns based on distances to randomly distributed+-- cell points. cellular2 :: (RealFrac a, Floating a) => CellularConfig a -> Noise2 a cellular2 = Cellular.noise2 {-# INLINE cellular2 #-}@@ -178,21 +215,6 @@ perlin2 :: (RealFrac a) => Noise2 a perlin2 = Perlin.noise2 {-# INLINE perlin2 #-}---- | Evaluate a 3D noise function at the given coordinates with the given seed.-noise3At- :: Noise3 a- -> Seed- -- ^ deterministic seed- -> a- -- ^ x coordinate- -> a- -- ^ y coordinate- -> a- -- ^ z coordinate- -> a-noise3At = unNoise3-{-# INLINE noise3At #-} -- | 3D Perlin noise. Classic gradient noise algorithm. perlin3 :: (RealFrac a) => Noise3 a
src/Numeric/Noise/Cellular.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StrictData #-} -- | -- Maintainer: Jeremy Nuttall <jeremy@jeremy-nuttall.com>@@ -17,7 +18,7 @@ ) where import Data.Bits-import Data.Foldable -- redundant since GHC 9.10.1, here for compat+import Data.Foldable (foldl') -- redundant since GHC 9.10.1, here for compat import Data.Primitive.PrimArray import GHC.Generics (Generic) import Numeric.Noise.Internal@@ -28,13 +29,13 @@ -- Cellular noise is based on distances to randomly distributed cell points, -- creating a distinctive cellular or organic pattern. data CellularConfig a = CellularConfig- { cellularDistanceFn :: !CellularDistanceFn+ { cellularDistanceFn :: CellularDistanceFn -- ^ Distance metric to use when computing distance to cell points.- , cellularJitter :: !a+ , cellularJitter :: a -- ^ Amount of randomness in cell point positions.- -- 0 creates a regular grid, 1 creates fully random positions.- -- Values outside [0, 1] are valid but may produce unusual results.- , cellularResult :: !CellularResult+ -- \( 0 \) creates a regular grid, \( 1 \) creates fully random positions.+ -- Values outside \( [0, 1] \) may produce unusual results.+ , cellularResult :: CellularResult -- ^ What value to return from the noise function. } deriving (Generic, Show)@@ -47,23 +48,20 @@ , cellularJitter = 1 , cellularResult = CellValue }+{-# INLINEABLE defaultCellularConfig #-} -- | Distance function for cellular noise calculations. -- -- Different distance metrics produce different visual characteristics -- in the cellular pattern. data CellularDistanceFn- = -- | Standard Euclidean distance (sqrt(dx² + dy²)).- -- Creates circular cells with smooth edges.+ = -- | \( \sqrt{dx^2 + dy^2} \) - Creates circular cells with smooth edges. DistEuclidean- | -- | Squared Euclidean distance (dx² + dy²), no square root.- -- Faster than 'DistEuclidean' with similar appearance.+ | -- | \( dx^2 + dy^2 \) - Faster than 'DistEuclidean' with similar appearance. DistEuclideanSq- | -- | Manhattan/taxicab distance (|dx| + |dy|).- -- Creates diamond-shaped cells with sharp edges.+ | -- | \( |dx| + |dy| \) - Creates diamond-shaped cells with sharp edges. DistManhattan | -- | Hybrid of Euclidean and Manhattan distances.- -- Combines characteristics of both metrics. DistHybrid deriving (Generic, Read, Show, Eq, Ord, Enum, Bounded) @@ -110,14 +108,14 @@ {-# INLINE normDist #-} noise2 :: (RealFrac a, Floating a) => CellularConfig a -> Noise2 a-noise2 CellularConfig{..} = Noise2 $ \ !seed !x !y ->+noise2 CellularConfig{..} = mkNoise2 $ \ !seed !x !y -> let !jitter = cellularJitter * 0.43701595 !rx = round x !ry = round y dist = distance cellularDistanceFn norm = normDist cellularDistanceFn- coeff = 1 / (fromIntegral (maxBound @Hash) + 1)+ coeff = 1 / (maxHash + 1) {-# INLINE pointDist #-} pointDist !xi !yi =@@ -125,9 +123,9 @@ !py = fromIntegral yi - y !h = hash2 seed (primeX * xi) (primeY * yi) !i = h .&. 0x1FE- !rvx = randVecs2d `indexPrimArray` fromIntegral i- !rvy = randVecs2d `indexPrimArray` (fromIntegral i .|. 1)- !d = dist (px + realToFrac rvx * jitter) (py + realToFrac rvy * jitter)+ !rvx = lookupRandVec2d i+ !rvy = lookupRandVec2d (i .|. 1)+ !d = dist (px + rvx * jitter) (py + rvy * jitter) in (h, d) {-# INLINE points #-}@@ -176,15 +174,29 @@ Distance2Div -> let (!_, !d0, !d1) = selectSmallestTwo in norm d0 / norm d1 - 1- where+{-# INLINE [2] noise2 #-} -{-# INLINE noise2 #-}+lookupRandVec2d :: (RealFrac a) => Hash -> a+lookupRandVec2d = realToFrac . indexPrimArray randVecs2dd . fromIntegral+{-# NOINLINE [1] lookupRandVec2d #-} +{-# RULES+"lookupRandVec2d/Float" forall h.+ lookupRandVec2d h =+ indexPrimArray randVecs2df (fromIntegral h)+"lookupRandVec2d/Double" forall h.+ lookupRandVec2d h =+ indexPrimArray randVecs2dd (fromIntegral h)+ #-}++randVecs2df :: PrimArray Float+randVecs2df = mapPrimArray realToFrac randVecs2dd+ -- >>> sizeofPrimArray randVecs2d == 512 -- True {- ORMOLU_DISABLE -}-randVecs2d :: PrimArray Float-randVecs2d =+randVecs2dd :: PrimArray Double+randVecs2dd = [-0.2700222198,-0.9628540911,0.3863092627,-0.9223693152,0.04444859006,-0.999011673,-0.5992523158,-0.8005602176 ,-0.7819280288,0.6233687174,0.9464672271,0.3227999196,-0.6514146797,-0.7587218957,0.9378472289,0.347048376 ,-0.8497875957,-0.5271252623,-0.879042592,0.4767432447,-0.892300288,-0.4514423508,-0.379844434,-0.9250503802
src/Numeric/Noise/Fractal.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE Strict #-}+{-# LANGUAGE StrictData #-} -- | -- Maintainer: Jeremy Nuttall <jeremy@jeremy-nuttall.com>@@ -44,19 +44,19 @@ data FractalConfig a = FractalConfig { octaves :: Int -- ^ Number of noise layers to combine. More octaves create more detail- -- but are more expensive to compute. Must be >= 1.+ -- but are more expensive to compute. Must be \( >= 1 \). , lacunarity :: a -- ^ Frequency multiplier between octaves. Each octave's frequency is -- the previous octave's frequency multiplied by lacunarity. , gain :: a -- ^ Amplitude multiplier between octaves. Each octave's amplitude is -- the previous octave's amplitude multiplied by gain.- -- Values < 1 create smoother noise, values > 1 create rougher noise.+ -- Values \( < 1 \) create smoother noise, values \( > 1 \) create rougher noise. , weightedStrength :: a -- ^ Controls how much each octave's amplitude is influenced by the -- previous octave's value. At 0, octaves have independent amplitudes. -- At 1, lower-valued areas in previous octaves reduce the amplitude- -- of subsequent octaves. Range: [0, 1].+ -- of subsequent octaves. Range: \( [0, 1] \). } deriving (Generic, Read, Show, Eq) @@ -69,6 +69,7 @@ , gain = 0.5 , weightedStrength = 0 }+{-# INLINEABLE defaultFractalConfig #-} -- | Apply Fractal Brownian Motion (FBM) to a 2D noise function. --@@ -81,8 +82,8 @@ -- fbm = fractal2 defaultFractalConfig perlin2 -- @ fractal2 :: (RealFrac a) => FractalConfig a -> Noise2 a -> Noise2 a-fractal2 config = Noise2 . fractal2With fractalNoiseMod (fractalAmpMod config) config . unNoise2-{-# INLINE fractal2 #-}+fractal2 config = mkNoise2 . fractal2With fractalNoiseMod (fractalAmpMod config) config . noise2At+{-# INLINE [2] fractal2 #-} -- | Apply billow fractal to a 2D noise function. --@@ -95,8 +96,8 @@ -- clouds = billow2 defaultFractalConfig perlin2 -- @ billow2 :: (RealFrac a) => FractalConfig a -> Noise2 a -> Noise2 a-billow2 config = Noise2 . fractal2With billowNoiseMod (billowAmpMod config) config . unNoise2-{-# INLINE billow2 #-}+billow2 config = mkNoise2 . fractal2With billowNoiseMod (billowAmpMod config) config . noise2At+{-# INLINE [2] billow2 #-} -- | Apply ridged fractal to a 2D noise function. --@@ -109,8 +110,8 @@ -- mountains = ridged2 defaultFractalConfig perlin2 -- @ ridged2 :: (RealFrac a) => FractalConfig a -> Noise2 a -> Noise2 a-ridged2 config = Noise2 . fractal2With ridgedNoiseMod (ridgedAmpMod config) config . unNoise2-{-# INLINE ridged2 #-}+ridged2 config = mkNoise2 . fractal2With ridgedNoiseMod (ridgedAmpMod config) config . noise2At+{-# INLINE [2] ridged2 #-} -- | Apply ping-pong fractal to a 2D noise function. --@@ -124,8 +125,8 @@ -- @ pingPong2 :: (RealFrac a) => FractalConfig a -> PingPongStrength a -> Noise2 a -> Noise2 a pingPong2 config strength =- Noise2 . fractal2With (pingPongNoiseMod strength) (pingPongAmpMod config) config . unNoise2-{-# INLINE pingPong2 #-}+ mkNoise2 . fractal2With (pingPongNoiseMod strength) (pingPongAmpMod config) config . noise2At+{-# INLINE [2] pingPong2 #-} fractal2With :: (RealFrac a)@@ -140,46 +141,46 @@ -> a -> a fractal2With modNoise modAmps FractalConfig{..} noise2 seed x y- | octaves < 1 = error "octaves must be a positive integer"+ | octaves < 1 = 0 | otherwise =- let bounding = fractalBounding FractalConfig{..}+ let !bounding = fractalBounding FractalConfig{..} in go octaves 0 seed 1 bounding where- go 0 acc _ _ _ = acc- go o acc s freq amp =- let noise = amp * modNoise (noise2 s (freq * x) (freq * y))- amp' = amp * gain * modAmps (min (noise + 1) 2)+ go 0 !acc !_ !_ !_ = acc+ go !o !acc !s !freq !amp =+ let !noise = amp * modNoise (noise2 s (freq * x) (freq * y))+ !amp' = amp * gain * modAmps (min (noise + 1) 2) in go (o - 1) (acc + noise) (s + 1) (freq * lacunarity) amp'-{-# INLINE fractal2With #-}+{-# INLINE [1] fractal2With #-} -- | Apply Fractal Brownian Motion (FBM) to a 3D noise function. -- -- 3D version of 'fractal2'. See 'fractal2' for details. fractal3 :: (RealFrac a) => FractalConfig a -> Noise3 a -> Noise3 a-fractal3 config = Noise3 . fractal3With fractalNoiseMod (fractalAmpMod config) config . unNoise3-{-# INLINE fractal3 #-}+fractal3 config = mkNoise3 . fractal3With fractalNoiseMod (fractalAmpMod config) config . noise3At+{-# INLINE [2] fractal3 #-} -- | Apply billow fractal to a 3D noise function. -- -- 3D version of 'billow2'. See 'billow2' for details. billow3 :: (RealFrac a) => FractalConfig a -> Noise3 a -> Noise3 a-billow3 config = Noise3 . fractal3With billowNoiseMod (billowAmpMod config) config . unNoise3-{-# INLINE billow3 #-}+billow3 config = mkNoise3 . fractal3With billowNoiseMod (billowAmpMod config) config . noise3At+{-# INLINE [2] billow3 #-} -- | Apply ridged fractal to a 3D noise function. -- -- 3D version of 'ridged2'. See 'ridged2' for details. ridged3 :: (RealFrac a) => FractalConfig a -> Noise3 a -> Noise3 a-ridged3 config = Noise3 . fractal3With ridgedNoiseMod (ridgedAmpMod config) config . unNoise3-{-# INLINE ridged3 #-}+ridged3 config = mkNoise3 . fractal3With ridgedNoiseMod (ridgedAmpMod config) config . noise3At+{-# INLINE [2] ridged3 #-} -- | Apply ping-pong fractal to a 3D noise function. -- -- 3D version of 'pingPong2'. See 'pingPong2' for details. pingPong3 :: (RealFrac a) => FractalConfig a -> PingPongStrength a -> Noise3 a -> Noise3 a pingPong3 config strength =- Noise3 . fractal3With (pingPongNoiseMod strength) (pingPongAmpMod config) config . unNoise3-{-# INLINE pingPong3 #-}+ mkNoise3 . fractal3With (pingPongNoiseMod strength) (pingPongAmpMod config) config . noise3At+{-# INLINE [2] pingPong3 #-} fractal3With :: (RealFrac a)@@ -195,23 +196,23 @@ -> a -> a fractal3With modNoise modAmps FractalConfig{..} noise3 seed x y z- | octaves < 1 = error "octaves must be a positive integer"- | otherwise = go octaves 0 seed 1 bounding+ | octaves < 1 = 0+ | otherwise =+ let !bounding = fractalBounding FractalConfig{..}+ in go octaves 0 seed 1 bounding where- bounding = fractalBounding FractalConfig{..}-- go 0 acc _ _ _ = acc- go o acc s freq amp =- let noise = amp * modNoise (noise3 s (freq * x) (freq * y) (freq * z))- amp' = amp * gain * modAmps (min (noise + 1) 2)+ go 0 !acc !_ !_ !_ = acc+ go !o !acc !s !freq !amp =+ let !noise = amp * modNoise (noise3 s (freq * x) (freq * y) (freq * z))+ !amp' = amp * gain * modAmps (min (noise + 1) 2) in go (o - 1) (acc + noise) (s + 1) (freq * lacunarity) amp'-{-# INLINE fractal3With #-}+{-# INLINE [1] fractal3With #-} fractalBounding :: (RealFrac a) => FractalConfig a -> a fractalBounding FractalConfig{..} = recip (sum amps + 1) where- ~amps = take octaves $ iterate (* gain) gain-{-# INLINE fractalBounding #-}+ amps = take octaves $ iterate (* gain) gain+{-# INLINE [2] fractalBounding #-} -- | Identity noise modifier for standard FBM. --@@ -281,7 +282,7 @@ pingPongNoiseMod (PingPongStrength s) n = let n' = (n + 1) * s t = n' - fromIntegral @Int (truncate (n' * 0.5) * 2)- in if t < 1 then t else 2 - t+ in 1 - abs (t - 1) {-# INLINE pingPongNoiseMod #-} -- | Amplitude modifier for ping-pong fractal.
src/Numeric/Noise/Internal.hs view
@@ -3,14 +3,33 @@ -- Stability : experimental module Numeric.Noise.Internal ( module Math,- Noise2 (..),+ Noise (..),+ constant,+ remap,+ warp,+ reseed,+ blend,+ sliceX2,+ sliceY2,+ sliceX3,+ sliceY3,+ sliceZ3,+ Noise1',+ Noise1,+ mkNoise1,+ noise1At,+ Noise2',+ Noise2,+ mkNoise2,+ noise2At, next2,- map2, clamp2, const2,- Noise3 (..),+ Noise3',+ Noise3,+ mkNoise3,+ noise3At, next3,- map3, clamp3, const3, ) where@@ -25,195 +44,340 @@ quinticInterp, ) --- | A 2D noise function parameterized by a seed and two coordinates.+-- | 'Noise' represents a function from a 'Seed' and coordinates @p@ to a noise+-- value @v@. ----- 'Noise2' wraps a function @Seed -> a -> a -> a@ that takes a seed value--- and x, y coordinates to produce a noise value.+-- For convenience, dimension-specific type aliases are provided: ----- This type supports 'Num', 'Fractional', and 'Floating' instances, allowing--- noise functions to be combined algebraically:+-- Use 'warp' to transform coordinates and 'remap' (or 'fmap') to transform values. --+-- To evaluate noise functions, use 'noise1At', 'noise2At', or 'noise3At'+--+-- NB: 'Noise' is a lawful 'Profunctor' where 'lmap' = warp and 'rmap' = remap.+-- There are some useful implications to this, but pure-noise is committed to+-- a minimal dependency footprint and so will not provide this instance itself.+--+-- === __Algebraic composition__+--+-- 'Noise' can be composed algebraically:+-- -- @--- combined :: Noise2 Float+-- combined :: Noise (Float, Float) Float -- combined = (perlin2 + superSimplex2) / 2 -- @ ----- To evaluate a 'Noise2', use 'noise2At' from "Numeric.Noise".-newtype Noise2 a = Noise2- {unNoise2 :: Seed -> a -> a -> a}---- | Increment the seed for a 2D noise function.+-- === __Coordinate Transformation__ ----- This is useful for generating independent noise layers:+-- This allows you to, for example, compose multiple layers of noise at different+-- offsets. -- -- @--- layer1 = perlin2--- layer2 = next2 perlin2--- layer3 = next2 (next2 perlin2)+-- scaled :: Noise2 Float+-- scaled = warp (\\(x, y) -> (x * 2, y * 2)) perlin2 -- @-next2 :: Noise2 a -> Noise2 a-next2 (Noise2 f) = Noise2 (\s x y -> f (s + 1) x y)-{-# INLINE next2 #-}+newtype Noise p v = Noise {unNoise :: Seed -> p -> v} -map2 :: (a -> a) -> Noise2 a -> Noise2 a-map2 f (Noise2 g) = Noise2 (\s x y -> f (g s x y))-{-# INLINE map2 #-}+-- NOTE: Noise p v is isomorphic to Reader (Seed, p), so it has trivial+-- instances of Monad and Category, Arrow, ArrowChoice, ArrowApply, etc.+--+-- I've decided not to include Category et al. as instances for now+-- because I can't come up with a use-case that is not sufficiently+-- covered by the monad instance. --- | Clamp the output of a 2D noise function to the range @[lower, upper]@.+-- | Noise admits 'Functor' on the value it produces+instance Functor (Noise p) where+ fmap f (Noise g) = Noise (\seed -> f . g seed)++-- | Noise admits 'Applicative' on the value it produces+instance Applicative (Noise p) where+ pure a = Noise $ \_ _ -> a+ liftA2 f (Noise g) (Noise h) = Noise (\s p -> g s p `f` h s p)++-- | Note: The 'Monad' instance evaluates all noise functions at the same+-- seed and coordinate. For independent sampling at different coordinates,+-- use 'warp' to transform the coordinate space. -- -- @--- clamped :: Noise2 Float--- clamped = clamp2 0 1 perlin2 -- clamp to [0, 1]+-- do n1 <- perlin2+-- n2 <- superSimplex2+-- return (n1 + n2) -- @-clamp2 :: (Ord a) => a -> a -> Noise2 a -> Noise2 a-clamp2 l u (Noise2 f) = Noise2 $ \s x y -> clamp l u (f s x y)-{-# INLINE clamp2 #-}+--+-- is equivalent to:+--+-- @+-- perlin2 + superSimplex2+-- @+--+-- This is useful for domain warping.+instance Monad (Noise p) where+ Noise g >>= f = Noise (\s p -> unNoise (f (g s p)) s p) -const2 :: a -> Noise2 a-const2 a = Noise2 (\_ _ _ -> a)-{-# INLINE const2 #-}+instance (Num a) => Num (Noise p a) where+ (+) = liftA2 (+)+ (*) = liftA2 (*)+ abs = fmap abs+ signum = fmap signum+ fromInteger i = pure (fromInteger i)+ negate = fmap negate --- | Arithmetic operations on 'Noise2' are performed point-wise.+instance (Fractional a) => Fractional (Noise p a) where+ fromRational = pure . fromRational+ recip = fmap recip+ (/) = liftA2 (/)++instance (Floating a) => Floating (Noise p a) where+ pi = pure pi+ exp = fmap exp+ log = fmap log+ sin = fmap sin+ cos = fmap cos+ asin = fmap asin+ acos = fmap acos+ atan = fmap atan+ sinh = fmap sinh+ cosh = fmap cosh+ asinh = fmap asinh+ acosh = fmap acosh+ atanh = fmap atanh++type Noise1' p v = Noise p v+type Noise1 v = Noise1' v v++mkNoise1 :: (Seed -> p -> v) -> Noise1' p v+mkNoise1 = Noise+{-# INLINE mkNoise1 #-}++-- | Evaluate a 1D noise function at the given coordinates with the given seed.+-- Currently, you must use a slicing function like 'sliceX' to reduce+-- higher-dimensional noise into 1D noise.+noise1At :: Noise1 a -> Seed -> a -> a+noise1At = unNoise+{-# INLINE noise1At #-}++type Noise2' p v = Noise (p, p) v+type Noise2 v = Noise2' v v++mkNoise2 :: (Seed -> p -> p -> v) -> Noise2' p v+mkNoise2 f = Noise (\s (x, y) -> f s x y)+{-# INLINE mkNoise2 #-}++-- | Evaluate a 2D noise function at the given coordinates with the given seed.+noise2At+ :: Noise2 a+ -> Seed+ -- ^ deterministic seed+ -> a+ -- ^ x coordinate+ -> a+ -- ^ y coordinate+ -> a+noise2At (Noise f) seed x y = f seed (x, y)+{-# INLINE noise2At #-}++type Noise3' p v = Noise (p, p, p) v+type Noise3 v = Noise3' v v++mkNoise3 :: (Seed -> p -> p -> p -> v) -> Noise3' p v+mkNoise3 f = Noise (\s (x, y, z) -> f s x y z)+{-# INLINE mkNoise3 #-}++-- | Evaluate a 3D noise function at the given coordinates with the given seed.+noise3At+ :: Noise3 a+ -> Seed+ -- ^ deterministic seed+ -> a+ -- ^ x coordinate+ -> a+ -- ^ y coordinate+ -> a+ -- ^ z coordinate+ -> a+noise3At (Noise f) seed x y z = f seed (x, y, z)+{-# INLINE noise3At #-}++-- | Transform the values produced by a noise function. ----- For example, @n1 + n2@ creates a new noise function that adds the--- results of @n1@ and @n2@ at each coordinate.-instance (Num a) => Num (Noise2 a) where- Noise2 f + Noise2 g = Noise2 $ \s x y -> f s x y + g s x y- {-# INLINE (+) #-}- Noise2 f * Noise2 g = Noise2 $ \s x y -> f s x y * g s x y- {-# INLINE (*) #-}- abs (Noise2 f) = Noise2 $ \s x y -> abs (f s x y)- {-# INLINE abs #-}- signum (Noise2 f) = Noise2 $ \s x y -> signum (f s x y)- {-# INLINE signum #-}- fromInteger i = const2 (fromInteger i)- {-# INLINE fromInteger #-}- negate (Noise2 f) = Noise2 $ \s x y -> negate (f s x y)- {-# INLINE negate #-}+-- This is an alias for 'fmap'. Use it to transform noise values after generation:+--+-- === __Examples__+--+-- @+-- -- Scale noise from [-1, 1] to [0, 1]+-- normalized :: Noise2 Float+-- normalized = remap (\\x -> (x + 1) / 2) perlin2+-- @+remap :: (a -> b) -> Noise p a -> Noise p b+remap = fmap+{-# INLINE remap #-} -instance (Fractional a) => Fractional (Noise2 a) where- fromRational r = const2 (fromRational r)- {-# INLINE fromRational #-}- recip (Noise2 f) = Noise2 $ \s x y -> recip (f s x y)- {-# INLINE recip #-}- Noise2 f / Noise2 g = Noise2 $ \s x y -> f s x y / g s x y- {-# INLINE (/) #-}+-- | Transform the coordinate space of a noise function.+--+-- This allows you to scale, rotate, or otherwise modify coordinates before+-- they're passed to the noise function:+--+-- NB: This is 'contramap'+--+-- === __Examples__+--+-- @+-- -- Scale the noise frequency+-- scaled :: Noise2 Float+-- scaled = warp (\\(x, y) -> (x * 2, y * 2)) perlin2+--+-- -- Rotate the noise field+-- rotated :: Noise2 Float+-- rotated = warp (\\(x, y) -> (x * cos a - y * sin a, x * sin a + y * cos a)) perlin2+-- where a = pi / 4+-- @+warp :: (p -> p') -> Noise p' v -> Noise p v+warp f (Noise g) = Noise (\s p -> g s (f p))+{-# INLINE warp #-} -instance (Floating a) => Floating (Noise2 a) where- pi = const2 pi- {-# INLINE pi #-}- exp (Noise2 f) = Noise2 $ \s x y -> exp (f s x y)- {-# INLINE exp #-}- log (Noise2 f) = Noise2 $ \s x y -> log (f s x y)- {-# INLINE log #-}- sin (Noise2 f) = Noise2 $ \s x y -> sin (f s x y)- {-# INLINE sin #-}- cos (Noise2 f) = Noise2 $ \s x y -> cos (f s x y)- {-# INLINE cos #-}- asin (Noise2 f) = Noise2 $ \s x y -> asin (f s x y)- {-# INLINE asin #-}- acos (Noise2 f) = Noise2 $ \s x y -> acos (f s x y)- {-# INLINE acos #-}- atan (Noise2 f) = Noise2 $ \s x y -> atan (f s x y)- {-# INLINE atan #-}- sinh (Noise2 f) = Noise2 $ \s x y -> sinh (f s x y)- {-# INLINE sinh #-}- cosh (Noise2 f) = Noise2 $ \s x y -> cosh (f s x y)- {-# INLINE cosh #-}- asinh (Noise2 f) = Noise2 $ \s x y -> asinh (f s x y)- {-# INLINE asinh #-}- acosh (Noise2 f) = Noise2 $ \s x y -> acosh (f s x y)- {-# INLINE acosh #-}- atanh (Noise2 f) = Noise2 $ \s x y -> atanh (f s x y)- {-# INLINE atanh #-}+-- | Modify the seed used by a noise function.+--+-- This is useful for generating independent layers of noise:+--+-- See also 'next2' and 'next3' for convenient increment-by-one variants.+--+-- === __Examples__+-- @+-- layer1 = perlin2+-- layer2 = reseed (+1) perlin2+-- layer3 = reseed (+2) perlin2+--+-- combined = (layer1 + layer2 + layer3) / 3+-- @+reseed :: (Seed -> Seed) -> Noise p a -> Noise p a+reseed f (Noise g) = Noise (g . f)+{-# INLINE reseed #-} --- | A 3D noise function parameterized by a seed and three coordinates.+constant :: a -> Noise c a+constant = pure+{-# INLINE constant #-}++-- | Combine two noise functions with a custom blending function. ----- 'Noise3' wraps a function @Seed -> a -> a -> a -> a@ that takes a seed value--- and x, y, z coordinates to produce a noise value.+-- This is an alias for 'liftA2'. Use it to mix multiple noise sources: ----- Like 'Noise2', this type supports 'Num', 'Fractional', and 'Floating' instances--- for algebraic composition.+-- @+-- -- Multiply two noise functions+-- multiplied :: Noise2 Float+-- multiplied = blend (*) perlin2 superSimplex2 ----- To evaluate a 'Noise3', use 'noise3At' from "Numeric.Noise".-newtype Noise3 a = Noise3- {unNoise3 :: Seed -> a -> a -> a -> a}+-- -- Custom blending based on values+-- custom :: Noise2 Float+-- custom = blend (\\a b -> if a > 0 then a else b) perlin2 superSimplex2+-- @+blend :: (a -> b -> c) -> Noise p a -> Noise p b -> Noise p c+blend = liftA2+{-# INLINE blend #-} --- | Increment the seed for a 3D noise function.+-- | Clamp a noise function between the given lower and higher bound+clampNoise :: (Ord a) => a -> a -> Noise p a -> Noise p a+clampNoise l u = fmap (clamp l u)+{-# INLINE clampNoise #-}++-- | Slice a 2D noise function at a fixed X coordinate to produce 1D noise. ----- Analogous to 'next2', this is useful for generating independent 3D noise layers.-next3 :: Noise3 a -> Noise3 a-next3 (Noise3 f) = Noise3 (\s x y z -> f (s + 1) x y z)-{-# INLINE next3 #-}+-- === __Examples__+--+-- @+-- noise1d :: Noise1 Float+-- noise1d = sliceX2 0.0 perlin2 -- Fix X at 0, vary Y+--+-- -- Evaluate at Y = 5.0+-- value = noise1At noise1d seed 5.0+-- @+sliceX2 :: p -> Noise2' p v -> Noise1' p v+sliceX2 x = warp (x,)+{-# INLINE sliceX2 #-} -map3 :: (a -> a) -> Noise3 a -> Noise3 a-map3 f (Noise3 g) = Noise3 (\s x y z -> f (g s x y z))-{-# INLINE map3 #-}+-- | Slice a 2D noise function at a fixed Y coordinate to produce 1D noise.+--+-- === __Examples__+--+-- @+-- noise1d :: Noise1 Float+-- noise1d = sliceY2 0.0 perlin2 -- Fix Y at 0, vary X+--+-- -- Evaluate at X = 5.0+-- value = noise1At noise1d seed 5.0+-- @+sliceY2 :: p -> Noise2' p v -> Noise1' p v+sliceY2 y = warp (,y)+{-# INLINE sliceY2 #-} -const3 :: a -> Noise3 a-const3 a = Noise3 (\_ _ _ _ -> a)-{-# INLINE const3 #-}+-- | Slice a 3D noise function at a fixed X coordinate to produce 2D noise.+--+-- === __Examples__+--+-- @+-- noise2d :: Noise2 Float+-- noise2d = sliceX3 0.0 perlin3 -- Fix X at 0, vary Y and Z+--+-- -- Evaluate at Y = 1.0, Z = 2.0+-- value = noise2At noise2d seed 1.0 2.0+-- @+sliceX3 :: p -> Noise3' p v -> Noise2' p v+sliceX3 x = warp (\(y, z) -> (x, y, z))+{-# INLINE sliceX3 #-} --- | Clamp the output of a 3D noise function to the range @[lower, upper]@.+-- | Slice a 3D noise function at a fixed Y coordinate to produce 2D noise. --+-- === __Examples__+-- -- @--- clamped :: Noise3 Float--- clamped = clamp3 (-0.5) 0.5 perlin3 -- clamp to [-0.5, 0.5]+-- noise2d :: Noise2 Float+-- noise2d = sliceY3 0.0 perlin3 -- Fix Y at 0, vary X and Z -- @-clamp3 :: (Ord a) => a -> a -> Noise3 a -> Noise3 a-clamp3 l u (Noise3 f) = Noise3 $ \s x y z -> clamp l u (f s x y z)-{-# INLINE clamp3 #-}+sliceY3 :: p -> Noise3' p v -> Noise2' p v+sliceY3 y = warp (\(x, z) -> (x, y, z))+{-# INLINE sliceY3 #-} --- | Arithmetic operations on 'Noise3' are performed point-wise.+-- | Slice a 3D noise function at a fixed Z coordinate to produce 2D noise. ----- For example, @n1 * n2@ creates a new noise function that multiplies the--- results of @n1@ and @n2@ at each coordinate.-instance (Num a) => Num (Noise3 a) where- Noise3 f + Noise3 g = Noise3 $ \s x y z -> f s x y z + g s x y z- {-# INLINE (+) #-}- Noise3 f * Noise3 g = Noise3 $ \s x y z -> f s x y z * g s x y z- {-# INLINE (*) #-}- abs (Noise3 f) = Noise3 $ \s x y z -> abs (f s x y z)- {-# INLINE abs #-}- signum (Noise3 f) = Noise3 $ \s x y z -> signum (f s x y z)- {-# INLINE signum #-}- fromInteger i = const3 (fromInteger i)- {-# INLINE fromInteger #-}- negate (Noise3 f) = Noise3 $ \s x y z -> negate (f s x y z)- {-# INLINE negate #-}+-- This is useful for extracting 2D slices from 3D noise at different heights:+--+-- === __Examples__+--+-- @+-- heightmap :: Noise2 Float+-- heightmap = sliceZ3 10.0 perlin3 -- Sample at Z = 10+-- @+sliceZ3 :: p -> Noise3' p v -> Noise2' p v+sliceZ3 z = warp (\(x, y) -> (x, y, z))+{-# INLINE sliceZ3 #-} -instance (Fractional a) => Fractional (Noise3 a) where- fromRational r = const3 (fromRational r)- {-# INLINE fromRational #-}- recip (Noise3 f) = Noise3 $ \s x y z -> recip (f s x y z)- {-# INLINE recip #-}- Noise3 f / Noise3 g = Noise3 $ \s x y z -> f s x y z / g s x y z- {-# INLINE (/) #-}+-- | Increment the seed for a 2D noise function. See 'reseed'+next2 :: Noise2 a -> Noise2 a+next2 = reseed (+ 1)+{-# INLINE next2 #-} -instance (Floating a) => Floating (Noise3 a) where- pi = const3 pi- {-# INLINE pi #-}- exp (Noise3 f) = Noise3 $ \s x y z -> exp (f s x y z)- {-# INLINE exp #-}- log (Noise3 f) = Noise3 $ \s x y z -> log (f s x y z)- {-# INLINE log #-}- sin (Noise3 f) = Noise3 $ \s x y z -> sin (f s x y z)- {-# INLINE sin #-}- cos (Noise3 f) = Noise3 $ \s x y z -> cos (f s x y z)- {-# INLINE cos #-}- asin (Noise3 f) = Noise3 $ \s x y z -> asin (f s x y z)- {-# INLINE asin #-}- acos (Noise3 f) = Noise3 $ \s x y z -> acos (f s x y z)- {-# INLINE acos #-}- atan (Noise3 f) = Noise3 $ \s x y z -> atan (f s x y z)- {-# INLINE atan #-}- sinh (Noise3 f) = Noise3 $ \s x y z -> sinh (f s x y z)- {-# INLINE sinh #-}- cosh (Noise3 f) = Noise3 $ \s x y z -> cosh (f s x y z)- {-# INLINE cosh #-}- asinh (Noise3 f) = Noise3 $ \s x y z -> asinh (f s x y z)- {-# INLINE asinh #-}- acosh (Noise3 f) = Noise3 $ \s x y z -> acosh (f s x y z)- {-# INLINE acosh #-}- atanh (Noise3 f) = Noise3 $ \s x y z -> atanh (f s x y z)- {-# INLINE atanh #-}+-- | Clamp the output of a 2D noise function to the range @[lower, upper]@.+clamp2 :: (Ord a) => a -> a -> Noise2 a -> Noise2 a+clamp2 = clampNoise+{-# INLINE clamp2 #-}++-- | A noise function that produces the same value everywhere. Alias of 'pure'.+const2 :: a -> Noise2 a+const2 = pure+{-# INLINE const2 #-}++-- | Increment the seed for a 3D noise function. See 'reseed'+next3 :: Noise3 a -> Noise3 a+next3 = reseed (+ 1)+{-# INLINE next3 #-}++-- | A noise function that produces the same value everywhere. Alias of 'pure'+--+-- Used to provide the 'Num' instance.+const3 :: a -> Noise3 a+const3 = pure+{-# INLINE const3 #-}++-- | Clamp the output of a 3D noise function to the range @[lower, upper]@.+clamp3 :: (Ord a) => a -> a -> Noise3 a -> Noise3 a+clamp3 = clampNoise+{-# INLINE clamp3 #-}
src/Numeric/Noise/Internal/Math.hs view
@@ -55,25 +55,93 @@ -- ^ parameter in range [0, 1] -> a lerp v0 v1 t = v0 + t * (v1 - v0)-{-# INLINE lerp #-}+{-# INLINE [1] lerp #-} +{-# RULES+"lerp/Float/0" forall (a :: Float) b.+ lerp a b 0 =+ a+"lerp/Double/0" forall (a :: Double) b.+ lerp a b 0 =+ a+"lerp/Float/1" forall (a :: Float) b.+ lerp a b 1 =+ b+"lerp/Double/1" forall (a :: Double) b.+ lerp a b 1 =+ b+"lerp/id" forall a t. lerp a a t = a+"lerp/compose/start" forall a b t u.+ lerp (lerp a b u) b t =+ lerp a b (u + t - t * u)+"lerp/compose/end" forall a b t u.+ lerp a (lerp a b u) t =+ lerp a b (t * u)+ #-}+ -- | cubic interpolation cubicInterp :: (Num a) => a -> a -> a -> a -> a -> a-cubicInterp a b c d t =- let !p = (d - c) - (a - b)- in t * t * t * p + t * t * ((a - b) - p) + t * (c - a) + b-{-# INLINE cubicInterp #-}+cubicInterp a !b c d !t =+ let !c' = c - a+ !a' = a - b+ !p = (d - c) - a'+ !b' = a' - p+ in b + t * (c' + t * (b' + t * p))+{-# INLINE [1] cubicInterp #-} +{-# RULES+"cubicInterp/Float/0" forall (a :: Float) b c d.+ cubicInterp a b c d 0 =+ b+"cubicInterp/Double/0" forall (a :: Double) b c d.+ cubicInterp a b c d 0 =+ b+"cubicInterp/Float/1" forall (a :: Float) b c d.+ cubicInterp a b c d 1 =+ c+"cubicInterp/Double/1" forall (a :: Double) b c d.+ cubicInterp a b c d 1 =+ c+"cubicInterp/Float/0.5" forall (a :: Float) b c d.+ cubicInterp a b c d (0.5 :: Float) =+ 0.125 * (-a + 5 * b + 5 * c - d)+"cubicInterp/Double/0.5" forall (a :: Double) b c d.+ cubicInterp a b c d (0.5 :: Double) =+ 0.125 * (-a + 5 * b + 5 * c - d)+ #-}+ -- | hermite interpolation hermiteInterp :: (Num a) => a -> a hermiteInterp t = t * t * (3 - 2 * t)-{-# INLINE hermiteInterp #-}+{-# INLINE [1] hermiteInterp #-} +{-# RULES+"hermiteInterp/Float/0" hermiteInterp (0 :: Float) = 0+"hermiteInterp/Double/0" hermiteInterp (0 :: Double) = 0+"hermiteInterp/Float/1" hermiteInterp (1 :: Float) = 1+"hermiteInterp/Double/1" hermiteInterp (1 :: Double) = 1+ #-}+ -- | quintic interpolation quinticInterp :: (Num a) => a -> a quinticInterp t = t * t * t * (t * (t * 6 - 15) + 10)-{-# INLINE quinticInterp #-}+{-# INLINE [1] quinticInterp #-} +{-# RULES+"quinticInterp/Float/0"+ quinticInterp (0 :: Float) =+ 0+"quinticInterp/Double/0"+ quinticInterp (0 :: Double) =+ 0+"quinticInterp/Float/1"+ quinticInterp (1 :: Float) =+ 1+"quinticInterp/Double/1"+ quinticInterp (1 :: Double) =+ 1+ #-}+ -- | Clamp a value to a specified range. -- -- Returns the value if it's within bounds, otherwise returns@@ -87,10 +155,7 @@ -> a -- ^ value -> a-clamp l u v- | v < l = l- | v > u = u- | otherwise = v+clamp l u v = min (max v l) u {-# INLINE clamp #-} primeX, primeY, primeZ :: Hash@@ -125,48 +190,66 @@ sqrt3 = 1.7320508075688772935274463415059 {-# INLINE sqrt3 #-} -valCoord2 :: (RealFrac a) => Word64 -> Hash -> Hash -> a+valCoord2 :: (RealFrac a) => Seed -> Hash -> Hash -> a valCoord2 seed xPrimed yPrimed = let !hash = hash2 seed xPrimed yPrimed !val = (hash * hash) `xor` (hash `shiftL` 19)- in fromIntegral val / maxHash+ in fromIntegral val * recip (maxHash + 1) {-# INLINE valCoord2 #-} -valCoord3 :: (RealFrac a) => Word64 -> Hash -> Hash -> Hash -> a+valCoord3 :: (RealFrac a) => Seed -> Hash -> Hash -> Hash -> a valCoord3 seed xPrimed yPrimed zPrimed = let !hash = hash3 seed xPrimed yPrimed zPrimed !val = (hash * hash) `xor` (hash `shiftL` 19)- in fromIntegral val / maxHash+ in fromIntegral val * recip (maxHash + 1) {-# INLINE valCoord3 #-} gradCoord2 :: (RealFrac a) => Seed -> Hash -> Hash -> a -> a -> a gradCoord2 seed xPrimed yPrimed xd yd = let !hash = hash2 seed xPrimed yPrimed !ix = (hash `xor` (hash `shiftR` 15)) .&. 0xFE- !xg = grad2d `indexPrimArray` fromIntegral ix- !yg = grad2d `indexPrimArray` fromIntegral (ix .|. 1)- in xd * realToFrac xg + yd * realToFrac yg-{-# INLINE gradCoord2 #-}+ !xg = lookupGrad2 ix+ !yg = lookupGrad2 (ix .|. 1)+ in xd * xg + yd * yg+-- Phase 2 inlining ensures specialization happens after hash computation+-- but before gradient lookup, allowing REWRITE RULES to fire effectively+{-# INLINE [2] gradCoord2 #-} gradCoord3 :: (RealFrac a) => Seed -> Hash -> Hash -> Hash -> a -> a -> a -> a gradCoord3 seed xPrimed yPrimed zPrimed xd yd zd = let !hash = hash3 seed xPrimed yPrimed zPrimed !ix = (hash `xor` (hash `shiftR` 15)) .&. 0xFC- !xg = grad3d `indexPrimArray` fromIntegral ix- !yg = grad3d `indexPrimArray` fromIntegral (ix .|. 1)- !zg = grad3d `indexPrimArray` fromIntegral (ix .|. 2)- in xd * fromIntegral xg + yd * fromIntegral yg + zd * fromIntegral zg+ !xg = lookupGrad3 ix+ !yg = lookupGrad3 (ix .|. 1)+ !zg = lookupGrad3 (ix .|. 2)+ in xd * xg + yd * yg + zd * zg {-# INLINE gradCoord3 #-} maxHash :: (RealFrac a) => a-maxHash = realToFrac (maxBound @Hash)+maxHash = fromIntegral (maxBound @Hash) {-# INLINE maxHash #-} +lookupGrad2 :: (RealFrac a) => Hash -> a+lookupGrad2 = realToFrac . (grad2dd `indexPrimArray`) . fromIntegral+{-# INLINE [0] lookupGrad2 #-}++{-# RULES+"lookupGrad2/Float" forall (i :: Hash).+ lookupGrad2 i =+ indexPrimArray grad2df (fromIntegral i)+"lookupGrad2/Double" forall (i :: Hash).+ lookupGrad2 i =+ indexPrimArray grad2dd (fromIntegral i)+ #-}++grad2df :: PrimArray Float+grad2df = mapPrimArray realToFrac grad2dd+ {- ORMOLU_DISABLE -} -- >>> sizeofPrimArray grad2d == 256 -- True-grad2d :: PrimArray Float-grad2d =+grad2dd :: PrimArray Double+grad2dd = [ 0.130526192220052, 0.99144486137381 , 0.38268343236509 , 0.923879532511287, 0.608761429008721, 0.793353340291235, 0.793353340291235, 0.608761429008721, 0.923879532511287, 0.38268343236509 , 0.99144486137381 , 0.130526192220051, 0.99144486137381 , -0.130526192220051, 0.923879532511287, -0.38268343236509, 0.793353340291235, -0.60876142900872 , 0.608761429008721, -0.793353340291235, 0.38268343236509 , -0.923879532511287, 0.130526192220052, -0.99144486137381,@@ -200,12 +283,30 @@ 0.38268343236509 , 0.923879532511287, 0.923879532511287, 0.38268343236509 , 0.923879532511287, -0.38268343236509 , 0.38268343236509 , -0.923879532511287, -0.38268343236509 , -0.923879532511287, -0.923879532511287, -0.38268343236509 , -0.923879532511287, 0.38268343236509 , -0.38268343236509 , 0.923879532511287 ]-{-# INLINABLE grad2d #-} +{- ORMOLU_ENABLE -}++lookupGrad3 :: (RealFrac a) => Hash -> a+lookupGrad3 = realToFrac . (grad3dd `indexPrimArray`) . fromIntegral+{-# INLINE [0] lookupGrad3 #-}++{-# RULES+"lookupGrad3/Float" forall (i :: Hash).+ lookupGrad3 i =+ indexPrimArray grad3df (fromIntegral i)+"lookupGrad3/Double" forall (i :: Hash).+ lookupGrad3 i =+ indexPrimArray grad3dd (fromIntegral i)+ #-}++grad3df :: PrimArray Float+grad3df = mapPrimArray realToFrac grad3dd++{- ORMOLU_DISABLE -} -- >>> sizeofPrimArray grad3d == 256 -- True-grad3d :: PrimArray Int-grad3d =+grad3dd :: PrimArray Double+grad3dd = [ 0, 1, 1, 0, 0, -1, 1, 0, 0, 1, -1, 0, 0, -1, -1, 0 , 1, 0, 1, 0, -1, 0, 1, 0, 1, 0, -1, 0, -1, 0, -1, 0 , 1, 1, 0, 0, -1, 1, 0, 0, 1, -1, 0, 0, -1, -1, 0, 0@@ -223,4 +324,3 @@ , 1, 1, 0, 0, -1, 1, 0, 0, 1, -1, 0, 0, -1, -1, 0, 0 , 1, 1, 0, 0, 0, -1, 1, 0, -1, 1, 0, 0, 0, -1, -1, 0 ]-{-# INLINABLE grad3d #-}
src/Numeric/Noise/OpenSimplex.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE Strict #-}- -- | -- Maintainer: Jeremy Nuttall <jeremy@jeremy-nuttall.com> -- Stability: experimental@@ -11,76 +9,59 @@ noise2Base, ) where +import Data.Bool (bool) import Numeric.Noise.Internal import Numeric.Noise.Internal.Math noise2 :: (RealFrac a) => Noise2 a-noise2 = Noise2 noise2Base+noise2 = mkNoise2 noise2Base {-# INLINE noise2 #-} noise2Base :: (RealFrac a) => Seed -> a -> a -> a noise2Base seed xo yo =- let f2 = 0.5 * (sqrt3 - 1)- to = (xo + yo) * f2- x = xo + to- y = yo + to+ let !f2 = 0.5 * (sqrt3 - 1)+ !to = (xo + yo) * f2+ !x = xo + to+ !y = yo + to - fx = floor x- fy = floor y- xi = x - fromIntegral fx- yi = y - fromIntegral fy+ !fx = floor x+ !fy = floor y+ !xi = x - fromIntegral fx+ !yi = y - fromIntegral fy - t = (xi + yi) * g2- x0 = xi - t- y0 = yi - t- i = fx * primeX- j = fy * primeY+ !t = (xi + yi) * g2+ !x0 = xi - t+ !y0 = yi - t+ !i = fx * primeX+ !j = fy * primeY - a = 0.5 - x0 * x0 - y0 * y0- n0- | a <= 0 = 0- | otherwise =- (a * a)- * (a * a)- * gradCoord2 seed i j x0 y0+ !a = 0.5 - x0 * x0 - y0 * y0+ n0 = attenuate a seed i j x0 y0 - n1- | y0 > x0 =- let ~x1 = x0 + g2- ~i1 = i- ~y1 = y0 + (g2 - 1)- ~j1 = j + primeY- ~b = 0.5 - x1 * x1 - y1 * y1- in if b <= 0- then 0- else- (b * b)- * (b * b)- * gradCoord2 seed i1 j1 x1 y1- | otherwise =- let ~x1 = x0 + (g2 - 1)- ~i1 = i + primeX- ~y1 = y0 + g2- ~j1 = j- ~b = 0.5 - x1 * x1 - y1 * y1- in if b <= 0- then 0- else- (b * b)- * (b * b)- * gradCoord2 seed i1 j1 x1 y1+ n1 =+ let cond = bool 0 1 (y0 > x0)+ x1 = (x0 + g2 - 1) + fromIntegral cond+ y1 = (y0 + g2) - fromIntegral cond+ i1 = i + (1 - cond) * primeX+ j1 = j + cond * primeY+ b = 0.5 - x1 * x1 - y1 * y1+ in attenuate b seed i1 j1 x1 y1 - c =+ !n2 = let g2t = 1 - 2 * g2- in 2 * g2t * (1 / g2 - 2) * t- + (-2 * g2t * g2t + a)- n2- | c <= 0 = 0- | otherwise =- let ~x2 = x0 + (2 * g2 - 1)- ~y2 = y0 + (2 * g2 - 1)- in (c * c)- * (c * c)- * gradCoord2 seed (i + primeX) (j + primeY) x2 y2- in (n0 + n1 + n2) * 99.83685446303647-{-# INLINE noise2Base #-}+ c = 2 * g2t * (1 / g2 - 2) * t + (-2 * g2t * g2t + a)+ x2 = x0 + (2 * g2 - 1)+ y2 = y0 + (2 * g2 - 1)+ in attenuate c seed (i + primeX) (j + primeY) x2 y2+ in normalize $ n0 + n1 + n2+{-# INLINE [2] noise2Base #-}++attenuate :: (RealFrac a) => a -> Seed -> Hash -> Hash -> a -> a -> a+attenuate !vi seed i j x y =+ let !v = max 0 vi+ in (v * v) * (v * v) * gradCoord2 seed i j x y+{-# INLINE attenuate #-}++normalize :: (RealFrac a) => a -> a+normalize = (99.83685446303647 *)+{-# INLINE normalize #-}
src/Numeric/Noise/Perlin.hs view
@@ -16,7 +16,7 @@ import Numeric.Noise.Internal.Math noise2 :: (RealFrac a) => Noise2 a-noise2 = Noise2 noise2Base+noise2 = mkNoise2 noise2Base {-# INLINE noise2 #-} noise2Base :: forall a. (RealFrac a) => Seed -> a -> a -> a@@ -37,8 +37,8 @@ x1p = x0p + primeX y1p = y0p + primeY- in 1.4247691104677813- * lerp+ in normalize2 $+ lerp ( lerp (gradCoord2 seed x0p y0p xd0 yd0) (gradCoord2 seed x1p y0p xd1 yd0)@@ -50,10 +50,14 @@ u ) v-{-# INLINE noise2Base #-}+{-# INLINE [2] noise2Base #-} +normalize2 :: (RealFrac a) => a -> a+normalize2 = (1.4247691104677813 *)+{-# INLINE normalize2 #-}+ noise3 :: (RealFrac a) => Noise3 a-noise3 = Noise3 noise3Base+noise3 = mkNoise3 noise3Base {-# INLINE noise3 #-} noise3Base :: (RealFrac a) => Seed -> a -> a -> a -> a@@ -80,8 +84,8 @@ x1p = x0p + primeX y1p = y0p + primeY z1p = z0p + primeZ- in 0.96492141485214233398437- * lerp+ in normalize3 $+ lerp ( lerp ( lerp (gradCoord3 seed x0p y0p z0p xd0 yd0 zd0)@@ -109,4 +113,8 @@ v ) w-{-# INLINE noise3Base #-}+{-# INLINE [2] noise3Base #-}++normalize3 :: (RealFrac a) => a -> a+normalize3 = (0.96492141485214233398437 *)+{-# INLINE normalize3 #-}
src/Numeric/Noise/SuperSimplex.hs view
@@ -17,7 +17,7 @@ import Numeric.Noise.Internal.Math noise2 :: (RealFrac a) => Noise2 a-noise2 = Noise2 noise2Base+noise2 = mkNoise2 noise2Base {-# INLINE noise2 #-} noise2Base :: (RealFrac a) => Seed -> a -> a -> a@@ -60,89 +60,60 @@ let ~x2 = x0 + (3 * g2 - 2) ~y2 = y0 + (3 * g2 - 1) ~a2 = (2 / 3) - x2 * x2 - y2 * y2- in if a2 > 0- then- (a2 * a2)- * (a2 * a2)- * gradCoord2 seed (i + (primeX `shiftL` 1)) (j + primeY) x2 y2- else 0+ in attenuate a2 seed (i + (primeX `shiftL` 1)) (j + primeY) x2 y2 | otherwise = let ~x2 = x0 + g2 ~y2 = y0 + (g2 - 1) ~a2 = (2 / 3) - x2 * x2 - y2 * y2- in if a2 > 0- then- (a2 * a2)- * (a2 * a2)- * gradCoord2 seed i (j + primeY) x2 y2- else 0+ in attenuate a2 seed i (j + primeY) x2 y2+ ~vgy | yi - xmyi > 1 = let ~x3 = x0 + (3 * g2 - 1) ~y3 = y0 + (3 * g2 - 2) ~a3 = (2 / 3) - x3 * x3 - y3 * y3- in if a3 > 0- then- (a3 * a3)- * (a3 * a3)- * gradCoord2 seed (i + primeX) (j + (primeY `shiftL` 1)) x3 y3- else 0+ in attenuate a3 seed (i + primeX) (j + (primeY `shiftL` 1)) x3 y3 | otherwise = let ~x3 = x0 + (g2 - 1) ~y3 = y0 + g2 ~a3 = (2 / 3) - x3 * x3 - y3 * y3- in if a3 > 0- then- (a3 * a3)- * (a3 * a3)- * gradCoord2 seed (i + primeX) j x3 y3- else 0+ in attenuate a3 seed (i + primeX) j x3 y3 ~vlx | xi + xmyi < 0 = let ~x2 = x0 + (1 - g2) ~y2 = y0 - g2 ~a2 = (2 / 3) - x2 * x2 - y2 * y2- in if a2 > 0- then- (a2 * a2)- * (a2 * a2)- * gradCoord2 seed (i - primeX) j x2 y2- else 0+ in attenuate a2 seed (i - primeX) j x2 y2 | otherwise = let ~x2 = x0 + (g2 - 1) ~y2 = y0 + g2 ~a2 = (2 / 3) - x2 * x2 - y2 * y2- in if a2 > 0- then- (a2 * a2)- * (a2 * a2)- * gradCoord2 seed (i + primeX) j x2 y2- else 0+ in attenuate a2 seed (i + primeX) j x2 y2 ~vly | yi < xmyi = let ~x2 = x0 - g2 ~y2 = y0 - (g2 - 1) ~a2 = (2 / 3) - x2 * x2 - y2 * y2- in if a2 > 0- then- (a2 * a2)- * (a2 * a2)- * gradCoord2 seed i (j - primeY) x2 y2- else 0+ in attenuate a2 seed i (j - primeY) x2 y2 | otherwise = let ~x2 = x0 + g2 ~y2 = y0 + (g2 - 1) ~a2 = (2 / 3) - x2 * x2 - y2 * y2- in if a2 > 0- then- (a2 * a2)- * (a2 * a2)- * gradCoord2 seed i (j + primeY) x2 y2- else 0+ in attenuate a2 seed i (j + primeY) x2 y2 v2 | t > g2 = vgx + vgy | otherwise = vlx + vly- in (v0 + v1 + v2) * 18.24196194486065-{-# INLINE noise2Base #-}+ in normalize $ v0 + v1 + v2+{-# INLINE [2] noise2Base #-}++attenuate :: (RealFrac a) => a -> Seed -> Hash -> Hash -> a -> a -> a+attenuate !vi !seed !i !j !x !y =+ let !v = max 0 vi+ in (v * v) * (v * v) * gradCoord2 seed i j x y+{-# INLINE attenuate #-}++normalize :: (RealFrac a) => a -> a+normalize = (18.24196194486065 *)+{-# INLINE normalize #-}
src/Numeric/Noise/Value.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE Strict #-}- -- | -- Maintainer: Jeremy Nuttall <jeremy@jeremy-nuttall.com> -- Stability: experimental@@ -20,7 +18,7 @@ import Numeric.Noise.Internal.Math noise2 :: (RealFrac a) => Noise2 a-noise2 = Noise2 noise2Base+noise2 = mkNoise2 noise2Base {-# INLINE noise2 #-} noise2Base :: (RealFrac a) => Seed -> a -> a -> a@@ -48,10 +46,10 @@ xs ) ys-{-# INLINE noise2Base #-}+{-# INLINE [2] noise2Base #-} noise3 :: (RealFrac a) => Noise3 a-noise3 = Noise3 noise3Base+noise3 = mkNoise3 noise3Base {-# INLINE noise3 #-} noise3Base :: (RealFrac a) => Seed -> a -> a -> a -> a@@ -99,4 +97,4 @@ ys ) zs-{-# INLINE noise3Base #-}+{-# INLINE [2] noise3Base #-}
src/Numeric/Noise/ValueCubic.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE Strict #-}- -- | -- Maintainer: Jeremy Nuttall <jeremy@jeremy-nuttall.com> -- Stability : experimental@@ -18,7 +16,7 @@ import Numeric.Noise.Internal.Math noise2 :: (RealFrac a) => Noise2 a-noise2 = Noise2 noise2Base+noise2 = mkNoise2 noise2Base {-# INLINE noise2 #-} noise2Base :: (RealFrac a) => Seed -> a -> a -> a@@ -68,10 +66,10 @@ xs ) ys-{-# INLINE noise2Base #-}+{-# INLINE [2] noise2Base #-} noise3 :: (RealFrac a) => Noise3 a-noise3 = Noise3 noise3Base+noise3 = mkNoise3 noise3Base {-# INLINE noise3 #-} noise3Base :: (RealFrac a) => Seed -> a -> a -> a -> a@@ -223,4 +221,4 @@ ys ) zs-{-# INLINE noise3Base #-}+{-# INLINE [2] noise3Base #-}
+ test/CellularSpec.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE OverloadedStrings #-}++module CellularSpec (test_golden_cellular) where++import Golden.Util+import Numeric.Noise+import Test.Tasty (TestTree, testGroup)++test_golden_cellular :: TestTree+test_golden_cellular =+ testGroup+ "Cellular Golden Tests"+ [ testGroup "Grid Tests" cellularGridTests+ , testGroup "Sparse Tests" cellularSparseTests+ ]++-- All combinations of distance functions and result types+allCellularConfigs :: [(CellularDistanceFn, CellularResult)]+allCellularConfigs = [(df, rt) | df <- [minBound .. maxBound], rt <- [minBound .. maxBound]]++cellularGridTests :: [TestTree]+cellularGridTests =+ [ goldenImageTest2D "cellular" variant (cellular2 config) seed+ | (distFn, result) <- allCellularConfigs+ , let config = defaultCellularConfig{cellularDistanceFn = distFn, cellularResult = result}+ , seed <- cellularSeeds+ , let variant = show distFn ++ "-" <> show result <> "-seed" ++ show seed+ ]++cellularSparseTests :: [TestTree]+cellularSparseTests =+ [ goldenSparseTest2D "cellular" variant (cellular2 config) seed+ | (distFn, result) <- allCellularConfigs+ , let config = defaultCellularConfig{cellularDistanceFn = distFn, cellularResult = result}+ , seed <- cellularSeeds+ , let variant = show distFn <> "-" <> show result <> "-seed" ++ show seed+ ]
+ test/FractalSpec.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE OverloadedStrings #-}++module FractalSpec (test_golden_fractal) where++import Golden.Util+import Numeric.Noise+import Test.Tasty (TestTree, testGroup)++test_golden_fractal :: TestTree+test_golden_fractal =+ testGroup+ "Fractal Golden Tests"+ [ testGroup "2D Grid Tests" fractal2DGridTests+ , testGroup "2D Sparse Tests" fractal2DSparseTests+ , testGroup "3D Grid Tests" fractal3DGridTests+ , testGroup "3D Sparse Tests" fractal3DSparseTests+ ]++-- Fractal types to test+data FractalType = FBM | Billow | Ridged | PingPong+ deriving (Show, Eq, Enum, Bounded)++-- Apply the fractal type to a 2D noise function+applyFractal2D :: FractalType -> Noise2 Double -> Noise2 Double+applyFractal2D FBM = fractal2 defaultFractalConfig+applyFractal2D Billow = billow2 defaultFractalConfig+applyFractal2D Ridged = ridged2 defaultFractalConfig+applyFractal2D PingPong = pingPong2 defaultFractalConfig defaultPingPongStrength++-- Apply the fractal type to a 3D noise function+applyFractal3D :: FractalType -> Noise3 Double -> Noise3 Double+applyFractal3D FBM = fractal3 defaultFractalConfig+applyFractal3D Billow = billow3 defaultFractalConfig+applyFractal3D Ridged = ridged3 defaultFractalConfig+applyFractal3D PingPong = pingPong3 defaultFractalConfig defaultPingPongStrength++fractal2DGridTests :: [TestTree]+fractal2DGridTests =+ [ goldenImageTest2D "fractal" variant (applyFractal2D fractalType perlin2) seed+ | fractalType <- [minBound .. maxBound]+ , seed <- cellularSeeds+ , let variant = show fractalType ++ "-perlin-2d-seed" ++ show seed+ ]++fractal2DSparseTests :: [TestTree]+fractal2DSparseTests =+ [ goldenSparseTest2D "fractal" variant (applyFractal2D fractalType perlin2) seed+ | fractalType <- [minBound .. maxBound]+ , seed <- cellularSeeds+ , let variant = show fractalType ++ "-perlin-2d-seed" ++ show seed+ ]++fractal3DGridTests :: [TestTree]+fractal3DGridTests =+ [ goldenImageTest3D "fractal" variant (applyFractal3D fractalType perlin3) seed zOffset+ | fractalType <- [minBound .. maxBound]+ , seed <- cellularSeeds+ , (idx, zOffset) <- zip [0 :: Int ..] sliceOffsets3D+ , let variant = show fractalType ++ "-perlin-3d-seed_" ++ show seed ++ "-slice_" ++ show idx+ ]++fractal3DSparseTests :: [TestTree]+fractal3DSparseTests =+ [ goldenSparseTest3D "fractal" variant (applyFractal3D fractalType perlin3) seed+ | fractalType <- [minBound .. maxBound]+ , seed <- cellularSeeds+ , let variant = show fractalType ++ "-perlin-3d-seed" ++ show seed+ ]
+ test/Golden/Util.hs view
@@ -0,0 +1,393 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Utilities for golden testing of noise functions+module Golden.Util (+ -- * Test configuration+ defaultSeeds,+ cellularSeeds,+ sliceOffsets3D,++ -- * Grid generation+ generateGrid2D,+ generateGrid3D,++ -- * Sparse sampling+ SparseTest (..),+ generateSparse2D,+ generateSparse3D,++ -- * High-level test builders+ goldenImageTest2D,+ goldenImageTest3D,+ goldenSparseTest2D,+ goldenSparseTest3D,++ -- * Convenience batch functions+ golden2DImageTests,+ golden2DSparseTests,+ golden3DImageTests,+ golden3DSparseTests,+) where++import Codec.Picture+import Control.Monad+import Data.Aeson (FromJSON, ToJSON)+import Data.Aeson.Encode.Pretty (encodePretty)+import Data.ByteString qualified as BS+import Data.ByteString.Lazy qualified as LB+import Data.Massiv.Array (Array, B (..), Comp (..), Ix2 (..), Ix3, IxN (..), Sz (..))+import Data.Massiv.Array qualified as M+import Data.Text.Lazy qualified as LT+import Data.Text.Lazy.Encoding qualified as LT+import Foreign.C (eNOENT)+import Foreign.C.Error (errnoToIOError)+import GHC.Generics (Generic)+import Numeric.Noise (Noise2, Noise3, Seed, noise2At, noise3At, sliceZ3)+import System.Directory+import System.Exit+import System.FilePath+import System.Process.Typed qualified as PT+import Test.Tasty (TestName, TestTree, askOption)+import Test.Tasty.Golden+import Test.Tasty.Golden.Advanced (goldenTest2)++defaultSeeds :: [Seed]+defaultSeeds = [0, 42, 12345]++cellularSeeds :: [Seed]+cellularSeeds = [0, 42]++width2D, height2D :: Int+width2D = 1024+height2D = 1024++width3D, height3D :: Int+width3D = 256+height3D = 256++-- | Z-offsets for 3D slicing (fractional positions avoiding edges)+sliceOffsets3D :: [Double]+sliceOffsets3D = [0.125, 0.375, 0.625, 0.875]++data SparseTest a = SparseTest+ { coordinates :: [a]+ , expected :: a+ }+ deriving (Eq, Show, Generic)++instance (FromJSON a) => FromJSON (SparseTest a)+instance (ToJSON a) => ToJSON (SparseTest a)++-- | Generate a 2D noise grid using massiv+generateGrid2D+ :: Noise2 Double+ -> Seed+ -> Int+ -- ^ Width+ -> Int+ -- ^ Height+ -> Array B Ix2 Double+generateGrid2D noise seed width height =+ M.makeArray Par (Sz2 height width) $ \(row :. col) ->+ let x = fromIntegral col / fromIntegral width+ y = fromIntegral row / fromIntegral height+ in noise2At noise seed x y+{-# INLINE generateGrid2D #-}++-- | Generate a 3D noise grid using massiv+generateGrid3D+ :: Noise3 Double+ -> Seed+ -> Int+ -- ^ Width+ -> Int+ -- ^ Height+ -> Int+ -- ^ Depth+ -> Array B Ix3 Double+generateGrid3D noise seed width height depth =+ M.makeArray Par (Sz3 depth height width) $ \(d :> row :. col) ->+ let x = fromIntegral col / fromIntegral width+ y = fromIntegral row / fromIntegral height+ z = fromIntegral d / fromIntegral depth+ in noise3At noise seed x y z+{-# INLINE generateGrid3D #-}++-- | Convert a 2D noise grid to a grayscale PNG image+-- Maps noise values from [-1, 1] to pixel values [0, 255]+noiseGridToImage :: Array B Ix2 Double -> Image Pixel8+noiseGridToImage arr =+ let Sz2 height width = M.size arr+ getPixel x y =+ let val = arr M.! (y :. x)+ -- Map [-1, 1] to [0, 255]+ normalized = (val + 1.0) / 2.0+ clamped = max 0.0 (min 1.0 normalized)+ in round (clamped * 255.0)+ in generateImage getPixel width height+{-# INLINE noiseGridToImage #-}++-- | Strategic test points for 2D noise+-- Includes corners, edges, zero, unit values, negatives, and fractional coordinates+sparseTestPoints2D :: [(Double, Double)]+sparseTestPoints2D =+ [ -- Corners and edges+ (0.0, 0.0)+ , (1.0, 1.0)+ , (0.0, 1.0)+ , (1.0, 0.0)+ , -- Negative values+ (-1.0, -1.0)+ , (-1.0, 0.0)+ , (0.0, -1.0)+ , (-1.0, 1.0)+ , (1.0, -1.0)+ , -- Fractional coordinates+ (0.5, 0.5)+ , (0.25, 0.75)+ , (0.75, 0.25)+ , (0.1, 0.9)+ , (0.9, 0.1)+ , -- Larger values+ (10.0, 10.0)+ , (100.0, 100.0)+ , (-10.0, -10.0)+ , (5.5, 7.3)+ , (-3.2, 4.7)+ , -- Edge cases+ (1.0e-10, 1.0e-10)+ , (1.0e10, 1.0e10)+ , -- More varied points+ (2.5, 3.7)+ , (-5.2, 8.9)+ , (12.34, -56.78)+ , (0.123, 0.456)+ , (0.789, 0.321)+ , (-0.5, -0.5)+ , (0.5, -0.5)+ , (-0.5, 0.5)+ , -- Prime-like coordinates for good distribution+ (2.0, 3.0)+ , (5.0, 7.0)+ , (11.0, 13.0)+ , (17.0, 19.0)+ , (23.0, 29.0)+ , (31.0, 37.0)+ , (41.0, 43.0)+ , (47.0, 53.0)+ , -- Diagonal patterns+ (2.0, 2.0)+ , (3.0, 3.0)+ , (-2.0, -2.0)+ , -- Anti-diagonal+ (2.0, -2.0)+ , (-2.0, 2.0)+ , -- Discontinuity+ (0.999999, 0.999999)+ , (0.000001, 0.000001)+ , (0.999999999, 0.999999999)+ , (1.000000001, 1.000000001)+ , -- Powers of two+ (256.0, 256.0)+ , (1024.0, 1024.1)+ , (65536.5, 65536.5)+ , -- Large inputs+ (10000.0, 10000.0)+ , (10000.1, 10000.1)+ , -- Floating-point tomfoolery+ (1 / 0, 1.0) -- infinity+ , (-1 / 0, 1.0) -- negative infinity+ , (0 / 0, 1.0) -- NaN+ ]++-- | Strategic test points for 3D noise+sparseTestPoints3D :: [(Double, Double, Double)]+sparseTestPoints3D =+ [ -- Corners+ (0.0, 0.0, 0.0)+ , (1.0, 1.0, 1.0)+ , (0.0, 0.0, 1.0)+ , (0.0, 1.0, 0.0)+ , (1.0, 0.0, 0.0)+ , (0.0, 1.0, 1.0)+ , (1.0, 0.0, 1.0)+ , (1.0, 1.0, 0.0)+ , -- Negative corners+ (-1.0, -1.0, -1.0)+ , (-1.0, -1.0, 1.0)+ , (-1.0, 1.0, -1.0)+ , (1.0, -1.0, -1.0)+ , -- Fractional center and edges+ (0.5, 0.5, 0.5)+ , (0.25, 0.5, 0.75)+ , (0.75, 0.25, 0.5)+ , -- Larger values+ (10.0, 10.0, 10.0)+ , (100.0, 100.0, 100.0)+ , (-10.0, -10.0, -10.0)+ , -- Varied points+ (2.5, 3.7, 4.2)+ , (-5.2, 8.9, -3.1)+ , (1.23, -4.56, 7.89)+ , -- Edge cases+ (1.0e-10, 1.0e-10, 1.0e-10)+ , (1.0e10, 1.0e10, 1.0e10)+ , -- Mixed signs+ (1.0, -1.0, 1.0)+ , (-1.0, 1.0, -1.0)+ , (1.0, 1.0, -1.0)+ , (-1.0, -1.0, 1.0)+ , -- Prime-like distribution+ (2.0, 3.0, 5.0)+ , (7.0, 11.0, 13.0)+ , (17.0, 19.0, 23.0)+ ]++-- | Generate sparse test samples for 2D noise+generateSparse2D :: Noise2 Double -> Seed -> [SparseTest Double]+generateSparse2D noise seed =+ map (\(x, y) -> SparseTest [x, y] (noise2At noise seed x y)) sparseTestPoints2D++-- | Generate sparse test samples for 3D noise+generateSparse3D :: Noise3 Double -> Seed -> [SparseTest Double]+generateSparse3D noise seed =+ map (\(x, y, z) -> SparseTest [x, y, z] (noise3At noise seed x y z)) sparseTestPoints3D++-- -----------------------------------------------------------------------------+-- High-level test builders+-- -----------------------------------------------------------------------------++goldenDir :: FilePath+goldenDir = "test-data" </> "golden"++goldenImageTest :: String -> String -> (String -> IO ()) -> TestTree+goldenImageTest noiseName variant act =+ let testName = noiseName <> " " <> variant+ imageRoot = goldenDir </> "images" </> noiseName+ goldenPath = imageRoot </> variant <.> "png"+ actualPath = imageRoot </> variant <.> "actual" <.> "png"+ in goldenVsImage+ testName+ goldenPath+ actualPath+ (createDirectoryIfMissing True imageRoot >> act actualPath)++-- This is more-or-less the same as goldenVsFileDiff, but it doesn't share stdio with+-- the child process, which is pretty important because odiff doesn't have a quiet option+goldenVsImage :: TestName -> FilePath -> FilePath -> IO () -> TestTree+goldenVsImage name ref new act = askOption $ \sizeCutoff ->+ goldenTest2+ name+ throwIfDoesNotExist+ act+ (\_ _ -> runDiff sizeCutoff)+ update+ delete+ where+ throwIfDoesNotExist = do+ exists <- doesFileExist ref+ unless exists $+ ioError $+ errnoToIOError "goldenVsFileDiff" eNOENT Nothing Nothing+ runDiff+ :: SizeCutoff+ -> IO (Maybe String)+ runDiff sizeCutoff = do+ let (refName, refExt) = splitExtension ref+ proc =+ PT.proc+ "odiff"+ [ "-t"+ , "0.004" -- Tolerate roughly +/- 1 error for 8-bit grayscale.+ , "--diff-overlay"+ , "--fail-on-layout"+ , "--output-diff-lines"+ , ref+ , new+ , refName <.> "diff" <.> refExt+ ]+ procConf = PT.setStdin PT.closed proc++ (exitCode, out) <- PT.readProcessInterleaved procConf+ return $ case exitCode of+ ExitSuccess -> Nothing+ _ -> Just . LT.unpack . LT.decodeUtf8 . truncateLargeOutput sizeCutoff $ out+ truncateLargeOutput (SizeCutoff n) str =+ if LB.length str <= n+ then str+ else+ LB.take n str+ <> "<truncated>"+ <> "\nUse --accept or increase --size-cutoff to see full output."+ update _ = do+ f <- BS.readFile new+ createDirectoriesAndWriteFile ref (LB.fromStrict f)+ delete = removeFile new++goldenImageTest2D :: String -> String -> Noise2 Double -> Seed -> TestTree+goldenImageTest2D noiseName variant noise seed = goldenImageTest noiseName variant $ \path -> do+ let grid = generateGrid2D noise seed width2D height2D+ img = noiseGridToImage grid+ savePngImage path (ImageY8 img)++goldenImageTest3D :: String -> String -> Noise3 Double -> Seed -> Double -> TestTree+goldenImageTest3D noiseName variant noise seed zOffset = goldenImageTest noiseName variant $ \path -> do+ let grid2D = generateGrid2D (sliceZ3 zOffset noise) seed width3D height3D+ img = noiseGridToImage grid2D+ savePngImage path (ImageY8 img)++goldenSparseTest :: String -> String -> (String -> IO ()) -> TestTree+goldenSparseTest noiseName variant act =+ let testName = noiseName <> " " <> variant <> " (sparse)"+ jsonRoot = goldenDir </> "sparse" </> noiseName+ goldenPath = jsonRoot </> variant <.> "json"+ actualPath = jsonRoot </> variant <.> "actual" <.> "json"+ in goldenVsFileDiff+ testName+ (\ref new -> ["diff", "-u", ref, new])+ goldenPath+ actualPath+ (createDirectoryIfMissing True jsonRoot >> act actualPath)++goldenSparseTest2D :: String -> String -> Noise2 Double -> Seed -> TestTree+goldenSparseTest2D noiseName variant noise seed = goldenSparseTest noiseName variant $ \path -> do+ let samples = generateSparse2D noise seed+ json = encodePretty samples+ LB.writeFile path json++goldenSparseTest3D :: String -> String -> Noise3 Double -> Seed -> TestTree+goldenSparseTest3D noiseName variant noise seed = goldenSparseTest noiseName variant $ \path -> do+ let samples = generateSparse3D noise seed+ json = encodePretty samples+ LB.writeFile path json++labelBatch :: (Show a) => String -> a -> String+labelBatch dim seed = dim <> "-seed_" <> show seed++labelBatch3D :: Seed -> Int -> String+labelBatch3D seed sliceIdx = "3d-seed_" <> show seed <> "-slice_" <> show sliceIdx++golden2DImageTests :: String -> [Seed] -> Noise2 Double -> [TestTree]+golden2DImageTests noiseName seeds noise =+ [ goldenImageTest2D noiseName (labelBatch "2d" seed) noise seed+ | seed <- seeds+ ]++golden2DSparseTests :: String -> [Seed] -> Noise2 Double -> [TestTree]+golden2DSparseTests noiseName seeds noise =+ [ goldenSparseTest2D noiseName (labelBatch "2d" seed) noise seed+ | seed <- seeds+ ]++golden3DImageTests :: String -> [Seed] -> Noise3 Double -> [TestTree]+golden3DImageTests noiseName seeds noise =+ [ goldenImageTest3D noiseName (labelBatch3D seed idx) noise seed zOffset+ | seed <- seeds+ , (idx, zOffset) <- zip [0 ..] sliceOffsets3D+ ]++golden3DSparseTests :: String -> [Seed] -> Noise3 Double -> [TestTree]+golden3DSparseTests noiseName seeds noise =+ [ goldenSparseTest3D noiseName (labelBatch "3d" seed) noise seed+ | seed <- seeds+ ]
test/Noise2Spec.hs view
@@ -24,12 +24,12 @@ prop_0_is_additive_identity :: Rational -> Rational -> Rational -> Bool prop_0_is_additive_identity v x y = let n1 = const2 v- in noise2At (n1 + fromInteger 0) seed x y == noise2At n1 seed x y+ in noise2At (n1 + 0) seed x y == noise2At n1 seed x y prop_negate_is_additive_inverse :: Rational -> Rational -> Rational -> Bool prop_negate_is_additive_inverse v x y = let n1 = const2 v- in noise2At (n1 + negate n1) seed x y == 0+ in noise2At (n1 - n1) seed x y == 0 prop_multiplication :: Rational -> Rational -> Bool prop_multiplication x y = noise2At (const2 x * const2 y) seed x y == x * y@@ -40,8 +40,3 @@ n2 = const2 2027 n3 = const2 2069 in noise2At ((n1 * n2) * n3) seed x y == noise2At (n1 * (n2 * n3)) seed x y--prop_1_is_multiplicative_identity :: Rational -> Rational -> Rational -> Bool-prop_1_is_multiplicative_identity v x y =- let n1 = const2 v- in noise2At (n1 * fromInteger 1) seed x y == v
test/Noise3Spec.hs view
@@ -25,12 +25,12 @@ prop_0_is_additive_identity :: Rational -> Rational -> Rational -> Rational -> Bool prop_0_is_additive_identity v x y z = let n1 = const3 v- in noise3At (n1 + fromInteger 0) seed x y z == noise3At n1 seed x y z+ in noise3At (n1 + 0) seed x y z == noise3At n1 seed x y z prop_negate_is_additive_inverse :: Rational -> Rational -> Rational -> Rational -> Bool prop_negate_is_additive_inverse v x y z = let n1 = const3 v- in noise3At (n1 + negate n1) seed x y z == 0+ in noise3At (n1 - n1) seed x y z == 0 prop_multiplication :: Rational -> Rational -> Rational -> Bool prop_multiplication x y z =@@ -46,4 +46,4 @@ prop_1_is_multiplicative_identity :: Rational -> Rational -> Rational -> Rational -> Bool prop_1_is_multiplicative_identity v x y z = let n1 = const3 v- in noise3At (n1 * fromInteger 1) seed x y z == v+ in noise3At (n1 * 1) seed x y z == v
+ test/OpenSimplexSpec.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE OverloadedStrings #-}++module OpenSimplexSpec (test_golden_opensimplex) where++import Golden.Util+import Numeric.Noise+import Test.Tasty (TestTree, testGroup)++test_golden_opensimplex :: TestTree+test_golden_opensimplex =+ testGroup+ "OpenSimplex Golden Tests"+ [ testGroup "2D Grid Tests" openSimplex2DGridTests+ , testGroup "2D Sparse Tests" openSimplex2DSparseTests+ ]++openSimplex2DGridTests :: [TestTree]+openSimplex2DGridTests = golden2DImageTests "opensimplex" defaultSeeds openSimplex2++openSimplex2DSparseTests :: [TestTree]+openSimplex2DSparseTests = golden2DSparseTests "opensimplex" defaultSeeds openSimplex2
test/PerlinSpec.hs view
@@ -1,7 +1,9 @@ module PerlinSpec where import GHC.Exts (noinline)+import Golden.Util import Numeric.Noise+import Test.Tasty (TestTree, testGroup) seed :: Seed seed = 82384@@ -20,3 +22,25 @@ prop_noise2_addition_commutative x y = noise2At (noinline perlin2 + noinline superSimplex2) seed x y == noise2At (noinline superSimplex2 + noinline perlin2) seed x y++test_golden_perlin :: TestTree+test_golden_perlin =+ testGroup+ "Perlin Golden Tests"+ [ testGroup "2D Grid Tests" perlin2DGridTests+ , testGroup "2D Sparse Tests" perlin2DSparseTests+ , testGroup "3D Grid Tests" perlin3DGridTests+ , testGroup "3D Sparse Tests" perlin3DSparseTests+ ]++perlin2DGridTests :: [TestTree]+perlin2DGridTests = golden2DImageTests "perlin" defaultSeeds perlin2++perlin2DSparseTests :: [TestTree]+perlin2DSparseTests = golden2DSparseTests "perlin" defaultSeeds perlin2++perlin3DGridTests :: [TestTree]+perlin3DGridTests = golden3DImageTests "perlin" defaultSeeds perlin3++perlin3DSparseTests :: [TestTree]+perlin3DSparseTests = golden3DSparseTests "perlin" defaultSeeds perlin3
+ test/SuperSimplexSpec.hs view
@@ -0,0 +1,19 @@+module SuperSimplexSpec (test_golden_supersimplex) where++import Golden.Util+import Numeric.Noise+import Test.Tasty (TestTree, testGroup)++test_golden_supersimplex :: TestTree+test_golden_supersimplex =+ testGroup+ "SuperSimplex Golden Tests"+ [ testGroup "2D Grid Tests" superSimplex2DGridTests+ , testGroup "2D Sparse Tests" superSimplex2DSparseTests+ ]++superSimplex2DGridTests :: [TestTree]+superSimplex2DGridTests = golden2DImageTests "supersimplex" defaultSeeds superSimplex2++superSimplex2DSparseTests :: [TestTree]+superSimplex2DSparseTests = golden2DSparseTests "supersimplex" defaultSeeds superSimplex2
+ test/ValueCubicSpec.hs view
@@ -0,0 +1,27 @@+module ValueCubicSpec (test_golden_valuecubic) where++import Golden.Util+import Numeric.Noise+import Test.Tasty (TestTree, testGroup)++test_golden_valuecubic :: TestTree+test_golden_valuecubic =+ testGroup+ "ValueCubic Golden Tests"+ [ testGroup "2D Grid Tests" valueCubic2DGridTests+ , testGroup "2D Sparse Tests" valueCubic2DSparseTests+ , testGroup "3D Grid Tests" valueCubic3DGridTests+ , testGroup "3D Sparse Tests" valueCubic3DSparseTests+ ]++valueCubic2DGridTests :: [TestTree]+valueCubic2DGridTests = golden2DImageTests "valuecubic" defaultSeeds valueCubic2++valueCubic2DSparseTests :: [TestTree]+valueCubic2DSparseTests = golden2DSparseTests "valuecubic" defaultSeeds valueCubic2++valueCubic3DGridTests :: [TestTree]+valueCubic3DGridTests = golden3DImageTests "valuecubic" defaultSeeds valueCubic3++valueCubic3DSparseTests :: [TestTree]+valueCubic3DSparseTests = golden3DSparseTests "valuecubic" defaultSeeds valueCubic3
+ test/ValueSpec.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE OverloadedStrings #-}++module ValueSpec (test_golden_value) where++import Golden.Util+import Numeric.Noise+import Test.Tasty (TestTree, testGroup)++test_golden_value :: TestTree+test_golden_value =+ testGroup+ "Value Golden Tests"+ [ testGroup "2D Grid Tests" value2DGridTests+ , testGroup "2D Sparse Tests" value2DSparseTests+ , testGroup "3D Grid Tests" value3DGridTests+ , testGroup "3D Sparse Tests" value3DSparseTests+ ]++value2DGridTests :: [TestTree]+value2DGridTests = golden2DImageTests "value" defaultSeeds value2++value2DSparseTests :: [TestTree]+value2DSparseTests = golden2DSparseTests "value" defaultSeeds value2++value3DGridTests :: [TestTree]+value3DGridTests = golden3DImageTests "value" defaultSeeds value3++value3DSparseTests :: [TestTree]+value3DSparseTests = golden3DSparseTests "value" defaultSeeds value3