diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 +``` + +![Domain Warped Noise](https://raw.githubusercontent.com/jtnuttall/pure-noise/main/demo/images/domain-warp.png) + +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 ![OpenSimplex2](https://raw.githubusercontent.com/jtnuttall/pure-noise/main/demo/images/opensimplex.png) ![OpenSimplex2 ridged](https://raw.githubusercontent.com/jtnuttall/pure-noise/main/demo/images/opensimplex-ridged.png) -_Perlin_ +### Perlin ![Perlin fBm](https://raw.githubusercontent.com/jtnuttall/pure-noise/main/demo/images/perlin-fbm.png) -_Cellular_ +### Cellular ![value](https://raw.githubusercontent.com/jtnuttall/pure-noise/main/demo/images/cell-value.png) ![distance2add](https://raw.githubusercontent.com/jtnuttall/pure-noise/main/demo/images/cell-d2.png) diff --git a/bench/Bench.hs b/bench/Bench.hs --- a/bench/Bench.hs +++ b/bench/Bench.hs @@ -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) + ] + ] diff --git a/pure-noise.cabal b/pure-noise.cabal --- a/pure-noise.cabal +++ b/pure-noise.cabal @@ -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 diff --git a/src/Numeric/Noise.hs b/src/Numeric/Noise.hs --- a/src/Numeric/Noise.hs +++ b/src/Numeric/Noise.hs @@ -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 diff --git a/src/Numeric/Noise/Cellular.hs b/src/Numeric/Noise/Cellular.hs --- a/src/Numeric/Noise/Cellular.hs +++ b/src/Numeric/Noise/Cellular.hs @@ -1,6 +1,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StrictData #-} -- | -- Maintainer: Jeremy Nuttall @@ -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 diff --git a/src/Numeric/Noise/Fractal.hs b/src/Numeric/Noise/Fractal.hs --- a/src/Numeric/Noise/Fractal.hs +++ b/src/Numeric/Noise/Fractal.hs @@ -1,5 +1,5 @@ {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE Strict #-} +{-# LANGUAGE StrictData #-} -- | -- Maintainer: Jeremy Nuttall @@ -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. diff --git a/src/Numeric/Noise/Internal.hs b/src/Numeric/Noise/Internal.hs --- a/src/Numeric/Noise/Internal.hs +++ b/src/Numeric/Noise/Internal.hs @@ -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 #-} diff --git a/src/Numeric/Noise/Internal/Math.hs b/src/Numeric/Noise/Internal/Math.hs --- a/src/Numeric/Noise/Internal/Math.hs +++ b/src/Numeric/Noise/Internal/Math.hs @@ -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 #-} diff --git a/src/Numeric/Noise/OpenSimplex.hs b/src/Numeric/Noise/OpenSimplex.hs --- a/src/Numeric/Noise/OpenSimplex.hs +++ b/src/Numeric/Noise/OpenSimplex.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE Strict #-} - -- | -- Maintainer: Jeremy Nuttall -- 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 #-} diff --git a/src/Numeric/Noise/Perlin.hs b/src/Numeric/Noise/Perlin.hs --- a/src/Numeric/Noise/Perlin.hs +++ b/src/Numeric/Noise/Perlin.hs @@ -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 #-} diff --git a/src/Numeric/Noise/SuperSimplex.hs b/src/Numeric/Noise/SuperSimplex.hs --- a/src/Numeric/Noise/SuperSimplex.hs +++ b/src/Numeric/Noise/SuperSimplex.hs @@ -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 #-} diff --git a/src/Numeric/Noise/Value.hs b/src/Numeric/Noise/Value.hs --- a/src/Numeric/Noise/Value.hs +++ b/src/Numeric/Noise/Value.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE Strict #-} - -- | -- Maintainer: Jeremy Nuttall -- 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 #-} diff --git a/src/Numeric/Noise/ValueCubic.hs b/src/Numeric/Noise/ValueCubic.hs --- a/src/Numeric/Noise/ValueCubic.hs +++ b/src/Numeric/Noise/ValueCubic.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE Strict #-} - -- | -- Maintainer: Jeremy Nuttall -- 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 #-} diff --git a/test/CellularSpec.hs b/test/CellularSpec.hs new file mode 100644 --- /dev/null +++ b/test/CellularSpec.hs @@ -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 + ] diff --git a/test/FractalSpec.hs b/test/FractalSpec.hs new file mode 100644 --- /dev/null +++ b/test/FractalSpec.hs @@ -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 + ] diff --git a/test/Golden/Util.hs b/test/Golden/Util.hs new file mode 100644 --- /dev/null +++ b/test/Golden/Util.hs @@ -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 + <> "" + <> "\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 + ] diff --git a/test/Noise2Spec.hs b/test/Noise2Spec.hs --- a/test/Noise2Spec.hs +++ b/test/Noise2Spec.hs @@ -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 diff --git a/test/Noise3Spec.hs b/test/Noise3Spec.hs --- a/test/Noise3Spec.hs +++ b/test/Noise3Spec.hs @@ -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 diff --git a/test/OpenSimplexSpec.hs b/test/OpenSimplexSpec.hs new file mode 100644 --- /dev/null +++ b/test/OpenSimplexSpec.hs @@ -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 diff --git a/test/PerlinSpec.hs b/test/PerlinSpec.hs --- a/test/PerlinSpec.hs +++ b/test/PerlinSpec.hs @@ -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 diff --git a/test/SuperSimplexSpec.hs b/test/SuperSimplexSpec.hs new file mode 100644 --- /dev/null +++ b/test/SuperSimplexSpec.hs @@ -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 diff --git a/test/ValueCubicSpec.hs b/test/ValueCubicSpec.hs new file mode 100644 --- /dev/null +++ b/test/ValueCubicSpec.hs @@ -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 diff --git a/test/ValueSpec.hs b/test/ValueSpec.hs new file mode 100644 --- /dev/null +++ b/test/ValueSpec.hs @@ -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