diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,13 @@ +# Changelog for `pure-noise` + +All notable changes to this project will be documented in this file. + +The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), +and this project adheres to the +[Haskell Package Versioning Policy](https://pvp.haskell.org/). + +## Unreleased + +## 0.1.0.0 - 2024-09-24 + +- Initial public commit diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Jeremy Nuttall (c) 2024 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Jeremy Nuttall nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,76 @@ +# pure-noise + +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. + +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. + +## 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. + +Noise values are generally clamped to `[-1, 1]`, although some noise functions may occasionally produce values slightly outside this range. + +```haskell +import Numeric.Noise qualified as Noise + +myNoise2 :: (RealFrac a) => Seed -> a -> a -> a +myNoise2 = + let fractalConfig = Noise.defaultFractalConfig + in Noise.noise2At $ + Noise.fractal2 fractalConfig ((perlin2 + superSimplex2) / 2) +``` + +More examples can be found in `bench` and `demo`. + +## 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. + +## Benchmarks + +### Results + +Measured by values / second generated by the noise functions. These results come from a benchmark with `-fllvm` enabled. + +All results are for `Float`s. + +There's inevitably some noise in the measurements because all of the results are forced into an unboxed vector. + +#### 2D + +| name | values / second | +| ------------- | --------------- | +| value2 | 157_347_680 | +| perlin2 | 129_541_747 | +| openSimplex2 | 64_758_006 | +| superSimplex2 | 64_072_639 | +| valueCubic2 | 52_110_819 | +| cellular2 | 15_743_434 | + +#### 3D + +| name | values / second | +| ----------- | --------------- | +| value3 | 85_438_023 | +| perlin3 | 56_830_482 | +| valueCubic3 | 15_559_523 | + +## Examples + +There's an interactive [demo app](demo/README.md) in the `demo` directory. + +_OpenSimplex2_ + +![OpenSimplex2](demo/images/opensimplex.png) +![OpenSimplex2 ridged](demo/images/opensimplex-ridged.png) + +_Perlin_ + +![Perlin fBm](demo/images/perlin-fbm.png) + +_Cellular_ + +![value](demo/images/cell-value.png) +![distance2add](demo/images/cell-d2.png) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/bench/Bench.hs b/bench/Bench.hs new file mode 100644 --- /dev/null +++ b/bench/Bench.hs @@ -0,0 +1,295 @@ +import BenchLib +import Data.Typeable +import Data.Vector.Unboxed qualified as U +import Numeric.Noise +import Numeric.Noise.Internal (const2, const3) +import System.Random.MWC qualified as MWC + +main :: IO () +main = do + let sz = 1_000_000 + seed = 1337 + octaves = 8 + 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 + ) + , bgroup + "3D" + ( baseline3 seed sz + <> benchPerlin3 seed octaves sz + <> benchValue3 seed octaves sz + <> benchValueCubic3 seed octaves sz + ) + ] + +label :: (Typeable a) => String -> Int -> Seed -> Proxy a -> String +label lbl sz seed px = + let lbl' = case lbl of + "" -> "" + v -> v <> ": " + in lbl' <> showsTypeRep (typeRep px) "" <> "[seed=" <> show seed <> "] x" <> show sz + +createEnv2 :: forall a. (U.Unbox a, MWC.UniformRange a, RealFrac a) => Int -> IO (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) +{-# INLINE createEnv2 #-} + +benchMany2 + :: forall a + . (Typeable a, MWC.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))) $ + nf (U.map (uncurry (noise2At f seed))) v +{-# INLINE benchMany2 #-} + +baseline2 :: Seed -> Int -> [Benchmark] +baseline2 seed sz = + [ bgroup + "baseline2" + [ benchMany2 @Float "" sz seed (const2 1) + , benchMany2 @Double "" sz seed (const2 2) + ] + ] +{-# INLINE baseline2 #-} + +benchPerlin2 :: Seed -> Int -> Int -> [Benchmark] +benchPerlin2 seed 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) + ] + ] +{-# INLINE benchPerlin2 #-} + +benchOpenSimplex2 :: Seed -> Int -> Int -> [Benchmark] +benchOpenSimplex2 seed 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) + ] + ] +{-# INLINE benchOpenSimplex2 #-} + +benchOpenSimplexSmooth2 :: Seed -> Int -> Int -> [Benchmark] +benchOpenSimplexSmooth2 seed 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) + ] + ] +{-# INLINE benchOpenSimplexSmooth2 #-} + +benchValue2 :: Seed -> Int -> Int -> [Benchmark] +benchValue2 seed 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) + ] + ] +{-# INLINE benchValue2 #-} + +benchValueCubic2 :: Seed -> Int -> Int -> [Benchmark] +benchValueCubic2 seed 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) + ] + ] +{-# INLINE benchValueCubic2 #-} + +benchCombo2 :: Seed -> Int -> Int -> [Benchmark] +benchCombo2 seed octaves sz = + [ bgroup + "numeric combination" + [ benchMany2 @Float "perlin * opensimplex/2" sz seed $ + openSimplex2 / 2 * perlin2 + , benchMany2 @Float "(4 * perlin) / 4" sz seed $ + 4 * perlin2 / 4 + , benchMany2 @Float "(perlin + perlin + perlin + perlin) / 4" sz seed $ + (perlin2 + perlin2 + perlin2 + perlin2) / 4 + , benchMany2 @Float "fractal (perlin * opensimplex/2)" sz seed $ + fractal2 defaultFractalConfig{octaves} (openSimplex2 / 2 * perlin2) + , benchMany2 @Float "fractal perlin * fractal opensimplex" sz seed $ + fractal2 defaultFractalConfig{octaves} perlin2 + * fractal2 defaultFractalConfig{octaves} openSimplex2 + ] + ] +{-# INLINE benchCombo2 #-} + +benchCellular2 :: Seed -> Int -> Int -> [Benchmark] +benchCellular2 seed _ sz = + [ bgroup + "cellular2" + ( benches @Float Proxy + <> benches @Double Proxy + ) + ] + 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)) +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 +{-# INLINE createEnv3 #-} + +benchMany3 + :: forall a + . (Typeable 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))) $ + nf (U.map (\(x, y, z) -> noise3At f seed x y z)) v +{-# INLINE benchMany3 #-} + +baseline3 :: Seed -> Int -> [Benchmark] +baseline3 seed sz = + [ bgroup + "baseline3" + [ benchMany3 @Float "" sz seed (const3 1) + , benchMany3 @Double "" sz seed (const3 2) + ] + ] +{-# INLINE baseline3 #-} + +benchPerlin3 :: Seed -> Int -> Int -> [Benchmark] +benchPerlin3 seed 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) + ] + ] +{-# INLINE benchPerlin3 #-} + +benchValue3 :: Seed -> Int -> Int -> [Benchmark] +benchValue3 seed 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) + ] + ] +{-# INLINE benchValue3 #-} + +benchValueCubic3 :: Seed -> Int -> Int -> [Benchmark] +benchValueCubic3 seed 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) + ] + ] +{-# INLINE benchValueCubic3 #-} diff --git a/bench/BenchLib.hs b/bench/BenchLib.hs new file mode 100644 --- /dev/null +++ b/bench/BenchLib.hs @@ -0,0 +1,12 @@ +module BenchLib ( + Benchmark, + Benchmarkable, + bgroup, + defaultMain, + env, + bench, + nf, + whnf, +) where + +import Test.Tasty.Bench diff --git a/pure-noise.cabal b/pure-noise.cabal new file mode 100644 --- /dev/null +++ b/pure-noise.cabal @@ -0,0 +1,94 @@ +cabal-version: 2.2 + +-- This file has been generated from package.yaml by hpack version 0.37.0. +-- +-- see: https://github.com/sol/hpack + +name: pure-noise +version: 0.1.0.0 +synopsis: Performant, modern noise generation for Haskell with minimal dependencies. Based on FastNoiseLite. +description: Please see the README on GitHub at +category: Math, Numeric, Noise +homepage: https://github.com/jtnuttall/pure-noise#readme +bug-reports: https://github.com/jtnuttall/pure-noise/issues +author: Jeremy Nuttall +maintainer: jeremy@jeremy-nuttall.com +copyright: 2024 Jeremy Nuttall +license: BSD-3-Clause +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/jtnuttall/pure-noise + +library + exposed-modules: + Numeric.Noise + Numeric.Noise.Cellular + Numeric.Noise.Fractal + Numeric.Noise.Internal + Numeric.Noise.Internal.Math + Numeric.Noise.OpenSimplex + Numeric.Noise.Perlin + Numeric.Noise.SuperSimplex + Numeric.Noise.Value + Numeric.Noise.ValueCubic + other-modules: + Paths_pure_noise + autogen-modules: + Paths_pure_noise + hs-source-dirs: + src + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints + build-depends: + base >=4.7 && <5 + , vector + default-language: GHC2021 + +test-suite pure-noise-test + type: exitcode-stdio-1.0 + main-is: Driver.hs + other-modules: + Noise2Spec + Noise3Spec + PerlinSpec + Paths_pure_noise + autogen-modules: + Paths_pure_noise + hs-source-dirs: + test + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -Wno-missing-export-lists -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.7 && <5 + , pure-noise + , tasty + , tasty-discover + , tasty-hunit + , tasty-quickcheck + , vector + default-language: GHC2021 + +benchmark pure-noise-bench + type: exitcode-stdio-1.0 + main-is: Bench.hs + other-modules: + BenchLib + Paths_pure_noise + autogen-modules: + Paths_pure_noise + hs-source-dirs: + bench + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N +RTS -A32m --nonmoving-gc -T -RTS -O2 -optc-O3 -fproc-alignment=64 -fsimpl-tick-factor=1000 + build-depends: + base >=4.7 && <5 + , deepseq + , mwc-random + , pure-noise + , tasty + , tasty-bench + , vector + default-language: GHC2021 diff --git a/src/Numeric/Noise.hs b/src/Numeric/Noise.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Noise.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE Strict #-} + +-- | +-- Maintainer: Jeremy Nuttall +-- Stability : experimental +module Numeric.Noise ( + -- * Noise functions + + -- ** Noise functions + module NoiseTypes, + noise2At, + noise3At, + + -- ** 2D Noise + cellular2, + openSimplex2, + superSimplex2, + perlin2, + value2, + valueCubic2, + + -- ** 3D Noise + perlin3, + value3, + valueCubic3, + + -- * Noise manipulation + + -- ** Math utility functions + module NoiseUtility, + + -- ** Fractal Brownian Motion + module Fractal, + + -- ** Cellular noise configuration + module Cellular, +) where + +import Numeric.Noise.Cellular as Cellular ( + CellularConfig (..), + CellularDistanceFn (..), + CellularResult (..), + defaultCellularConfig, + ) +import Numeric.Noise.Cellular qualified as Cellular +import Numeric.Noise.Fractal as Fractal +import Numeric.Noise.Internal +import Numeric.Noise.Internal as NoiseTypes ( + Noise2, + Noise3, + Seed, + ) +import Numeric.Noise.Internal as NoiseUtility ( + clamp, + clamp2, + clamp3, + cubicInterp, + hermiteInterp, + lerp, + next2, + next3, + quinticInterp, + ) +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 + +noise2At :: Noise2 a -> Seed -> a -> a -> a +noise2At = unNoise2 +{-# INLINE noise2At #-} + +cellular2 :: (RealFrac a, Floating a) => CellularConfig a -> Noise2 a +cellular2 = Cellular.noise2 +{-# INLINE cellular2 #-} + +openSimplex2 :: (RealFrac a) => Noise2 a +openSimplex2 = OpenSimplex.noise2 +{-# INLINE openSimplex2 #-} + +superSimplex2 :: (RealFrac a) => Noise2 a +superSimplex2 = SuperSimplex.noise2 +{-# INLINE superSimplex2 #-} + +perlin2 :: (RealFrac a) => Noise2 a +perlin2 = Perlin.noise2 +{-# INLINE perlin2 #-} + +noise3At :: Noise3 a -> Seed -> a -> a -> a -> a +noise3At = unNoise3 +{-# INLINE noise3At #-} + +perlin3 :: (RealFrac a) => Noise3 a +perlin3 = Perlin.noise3 +{-# INLINE perlin3 #-} + +value2 :: (RealFrac a) => Noise2 a +value2 = Value.noise2 +{-# INLINE value2 #-} + +value3 :: (RealFrac a) => Noise3 a +value3 = Value.noise3 +{-# INLINE value3 #-} + +valueCubic2 :: (RealFrac a) => Noise2 a +valueCubic2 = ValueCubic.noise2 +{-# INLINE valueCubic2 #-} + +valueCubic3 :: (RealFrac a) => Noise3 a +valueCubic3 = ValueCubic.noise3 +{-# INLINE valueCubic3 #-} diff --git a/src/Numeric/Noise/Cellular.hs b/src/Numeric/Noise/Cellular.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Noise/Cellular.hs @@ -0,0 +1,201 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Maintainer: Jeremy Nuttall +-- Stability : experimental +module Numeric.Noise.Cellular ( + -- * Configuration + CellularConfig (..), + defaultCellularConfig, + CellularDistanceFn (..), + CellularResult (..), + + -- * 2D Noise + noise2, + noise2BaseWith, +) where + +import Data.Bits +import Data.Foldable +import Data.Vector.Unboxed qualified as U +import GHC.Generics (Generic) +import Numeric.Noise.Internal +import Numeric.Noise.Internal.Math + +data CellularConfig a = CellularConfig + { cellularDistanceFn :: !CellularDistanceFn + , cellularJitter :: !a + , cellularResult :: !CellularResult + } + deriving (Generic, Show) + +defaultCellularConfig :: (RealFrac a) => CellularConfig a +defaultCellularConfig = + CellularConfig + { cellularDistanceFn = DistEuclidean + , cellularJitter = 1 + , cellularResult = CellValue + } + +data CellularDistanceFn + = DistEuclidean + | DistEuclideanSq + | DistManhattan + | DistHybrid + deriving (Generic, Read, Show, Eq, Ord, Enum, Bounded) + +data CellularResult + = CellValue + | Distance + | Distance2 + | Distance2Add + | Distance2Sub + | Distance2Mul + | Distance2Div + deriving (Generic, Read, Show, Eq, Ord, Enum, Bounded) + +distance :: (RealFrac a) => CellularDistanceFn -> a -> a -> a +distance = \case + DistEuclidean -> \ !x !y -> x * x + y * y + DistEuclideanSq -> \ !x !y -> x * x + y * y + DistManhattan -> \ !x !y -> abs x + abs y + DistHybrid -> \ !x !y -> abs x + abs y + (x * x + y * y) +{-# INLINE distance #-} + +normDist :: (Floating a) => CellularDistanceFn -> a -> a +normDist = \case + DistEuclidean -> sqrt + _ -> id +{-# INLINE normDist #-} + +noise2 :: (RealFrac a, Floating a) => CellularConfig a -> Noise2 a +noise2 CellularConfig{..} = + let !jitter = cellularJitter * 0.43701595 + !dist = distance cellularDistanceFn + !norm = normDist cellularDistanceFn + coeff = 1 / (fromIntegral (maxBound @Hash) + 1) + in Noise2 $ \seed x y -> + let (!hash, !d0u, !d1u) = noise2BaseWith jitter dist seed x y + !d0 = norm d0u + !d1 = norm d1u + in case cellularResult of + CellValue -> fromIntegral hash * coeff + Distance -> d0 - 1 + Distance2 -> d1 - 1 + Distance2Add -> (d1 + d0) * 0.5 - 1 + Distance2Sub -> d1 - d0 - 1 + Distance2Mul -> d1 * d0 * 0.5 - 1 + Distance2Div -> d0 / d1 - 1 +{-# INLINE noise2 #-} + +-- | Calculate 2D cellular noise values at a given point using the given distance function +noise2BaseWith + :: (RealFrac a) + => a + -- ^ cellular jitter + -> (a -> a -> a) + -- ^ distance function + -> Seed + -> a + -- ^ x + -> a + -- ^ y + -> (Hash, a, a) +noise2BaseWith !jitter !dist !seed !x !y = + foldl' @[] + minmax + (0, infinity, infinity) + [pointDist (rx + xi) (ry + yi) | !xi <- [-1 .. 1], !yi <- [-1 .. 1]] + where + !rx = round x + !ry = round y + + minmax (!c, !d0, !d1) (!h, !d) + | d < d0 = (h, d, d1') + | otherwise = (c, d0, d1') + where + !d1' = max (min d1 d) d0 + + pointDist !xi !yi = + let !px = fromIntegral xi - x + !py = fromIntegral yi - y + !h = hash2 seed (primeX * xi) (primeY * yi) + !i = h .&. 510 + !rvx = randVecs2d `U.unsafeIndex` fromIntegral i + !rvy = randVecs2d `U.unsafeIndex` (fromIntegral i .|. 1) + !d = dist (px + realToFrac rvx * jitter) (py + realToFrac rvy * jitter) + in (h, d) +{-# INLINE noise2BaseWith #-} + +-- >>> U.length randVecs2d == 512 +-- True +{- ORMOLU_DISABLE -} +randVecs2d :: U.Vector Float +randVecs2d = + [-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 + ,-0.9951650832,0.0982163789,0.7724397808,-0.6350880136,0.7573283322,-0.6530343002,-0.9928004525,-0.119780055 + ,-0.0532665713,0.9985803285,0.9754253726,-0.2203300762,-0.7665018163,0.6422421394,0.991636706,0.1290606184 + ,-0.994696838,0.1028503788,-0.5379205513,-0.84299554,0.5022815471,-0.8647041387,0.4559821461,-0.8899889226 + ,-0.8659131224,-0.5001944266,0.0879458407,-0.9961252577,-0.5051684983,0.8630207346,0.7753185226,-0.6315704146 + ,-0.6921944612,0.7217110418,-0.5191659449,-0.8546734591,0.8978622882,-0.4402764035,-0.1706774107,0.9853269617 + ,-0.9353430106,-0.3537420705,-0.9992404798,0.03896746794,-0.2882064021,-0.9575683108,-0.9663811329,0.2571137995 + ,-0.8759714238,-0.4823630009,-0.8303123018,-0.5572983775,0.05110133755,-0.9986934731,-0.8558373281,-0.5172450752 + ,0.09887025282,0.9951003332,0.9189016087,0.3944867976,-0.2439375892,-0.9697909324,-0.8121409387,-0.5834613061 + ,-0.9910431363,0.1335421355,0.8492423985,-0.5280031709,-0.9717838994,-0.2358729591,0.9949457207,0.1004142068 + ,0.6241065508,-0.7813392434,0.662910307,0.7486988212,-0.7197418176,0.6942418282,-0.8143370775,-0.5803922158 + ,0.104521054,-0.9945226741,-0.1065926113,-0.9943027784,0.445799684,-0.8951327509,0.105547406,0.9944142724 + ,-0.992790267,0.1198644477,-0.8334366408,0.552615025,0.9115561563,-0.4111755999,0.8285544909,-0.5599084351 + ,0.7217097654,-0.6921957921,0.4940492677,-0.8694339084,-0.3652321272,-0.9309164803,-0.9696606758,0.2444548501 + ,0.08925509731,-0.996008799,0.5354071276,-0.8445941083,-0.1053576186,0.9944343981,-0.9890284586,0.1477251101 + ,0.004856104961,0.9999882091,0.9885598478,0.1508291331,0.9286129562,-0.3710498316,-0.5832393863,-0.8123003252 + ,0.3015207509,0.9534596146,-0.9575110528,0.2883965738,0.9715802154,-0.2367105511,0.229981792,0.9731949318 + ,0.955763816,-0.2941352207,0.740956116,0.6715534485,-0.9971513787,-0.07542630764,0.6905710663,-0.7232645452 + ,-0.290713703,-0.9568100872,0.5912777791,-0.8064679708,-0.9454592212,-0.325740481,0.6664455681,0.74555369 + ,0.6236134912,0.7817328275,0.9126993851,-0.4086316587,-0.8191762011,0.5735419353,-0.8812745759,-0.4726046147 + ,0.9953313627,0.09651672651,0.9855650846,-0.1692969699,-0.8495980887,0.5274306472,0.6174853946,-0.7865823463 + ,0.8508156371,0.52546432,0.9985032451,-0.05469249926,0.1971371563,-0.9803759185,0.6607855748,-0.7505747292 + ,-0.03097494063,0.9995201614,-0.6731660801,0.739491331,-0.7195018362,-0.6944905383,0.9727511689,0.2318515979 + ,0.9997059088,-0.0242506907,0.4421787429,-0.8969269532,0.9981350961,-0.061043673,-0.9173660799,-0.3980445648 + ,-0.8150056635,-0.5794529907,-0.8789331304,0.4769450202,0.0158605829,0.999874213,-0.8095464474,0.5870558317 + ,-0.9165898907,-0.3998286786,-0.8023542565,0.5968480938,-0.5176737917,0.8555780767,-0.8154407307,-0.5788405779 + ,0.4022010347,-0.9155513791,-0.9052556868,-0.4248672045,0.7317445619,0.6815789728,-0.5647632201,-0.8252529947 + ,-0.8403276335,-0.5420788397,-0.9314281527,0.363925262,0.5238198472,0.8518290719,0.7432803869,-0.6689800195 + ,-0.985371561,-0.1704197369,0.4601468731,0.88784281,0.825855404,0.5638819483,0.6182366099,0.7859920446 + ,0.8331502863,-0.553046653,0.1500307506,0.9886813308,-0.662330369,-0.7492119075,-0.668598664,0.743623444 + ,0.7025606278,0.7116238924,-0.5419389763,-0.8404178401,-0.3388616456,0.9408362159,0.8331530315,0.5530425174 + ,-0.2989720662,-0.9542618632,0.2638522993,0.9645630949,0.124108739,-0.9922686234,-0.7282649308,-0.6852956957 + ,0.6962500149,0.7177993569,-0.9183535368,0.3957610156,-0.6326102274,-0.7744703352,-0.9331891859,-0.359385508 + ,-0.1153779357,-0.9933216659,0.9514974788,-0.3076565421,-0.08987977445,-0.9959526224,0.6678496916,0.7442961705 + ,0.7952400393,-0.6062947138,-0.6462007402,-0.7631674805,-0.2733598753,0.9619118351,0.9669590226,-0.254931851 + ,-0.9792894595,0.2024651934,-0.5369502995,-0.8436138784,-0.270036471,-0.9628500944,-0.6400277131,0.7683518247 + ,-0.7854537493,-0.6189203566,0.06005905383,-0.9981948257,-0.02455770378,0.9996984141,-0.65983623,0.751409442 + ,-0.6253894466,-0.7803127835,-0.6210408851,-0.7837781695,0.8348888491,0.5504185768,-0.1592275245,0.9872419133 + ,0.8367622488,0.5475663786,-0.8675753916,-0.4973056806,-0.2022662628,-0.9793305667,0.9399189937,0.3413975472 + ,0.9877404807,-0.1561049093,-0.9034455656,0.4287028224,0.1269804218,-0.9919052235,-0.3819600854,0.924178821 + ,0.9754625894,0.2201652486,-0.3204015856,-0.9472818081,-0.9874760884,0.1577687387,0.02535348474,-0.9996785487 + ,0.4835130794,-0.8753371362,-0.2850799925,-0.9585037287,-0.06805516006,-0.99768156,-0.7885244045,-0.6150034663 + ,0.3185392127,-0.9479096845,0.8880043089,0.4598351306,0.6476921488,-0.7619021462,0.9820241299,0.1887554194 + ,0.9357275128,-0.3527237187,-0.8894895414,0.4569555293,0.7922791302,0.6101588153,0.7483818261,0.6632681526 + ,-0.7288929755,-0.6846276581,0.8729032783,-0.4878932944,0.8288345784,0.5594937369,0.08074567077,0.9967347374 + ,0.9799148216,-0.1994165048,-0.580730673,-0.8140957471,-0.4700049791,-0.8826637636,0.2409492979,0.9705377045 + ,0.9437816757,-0.3305694308,-0.8927998638,-0.4504535528,-0.8069622304,0.5906030467,0.06258973166,0.9980393407 + ,-0.9312597469,0.3643559849,0.5777449785,0.8162173362,-0.3360095855,-0.941858566,0.697932075,-0.7161639607 + ,-0.002008157227,-0.9999979837,-0.1827294312,-0.9831632392,-0.6523911722,0.7578824173,-0.4302626911,-0.9027037258 + ,-0.9985126289,-0.05452091251,-0.01028102172,-0.9999471489,-0.4946071129,0.8691166802,-0.2999350194,0.9539596344 + ,0.8165471961,0.5772786819,0.2697460475,0.962931498,-0.7306287391,-0.6827749597,-0.7590952064,-0.6509796216 + ,-0.907053853,0.4210146171,-0.5104861064,-0.8598860013,0.8613350597,0.5080373165,0.5007881595,-0.8655698812 + ,-0.654158152,0.7563577938,-0.8382755311,-0.545246856,0.6940070834,0.7199681717,0.06950936031,0.9975812994 + ,0.1702942185,-0.9853932612,0.2695973274,0.9629731466,0.5519612192,-0.8338697815,0.225657487,-0.9742067022 + ,0.4215262855,-0.9068161835,0.4881873305,-0.8727388672,-0.3683854996,-0.9296731273,-0.9825390578,0.1860564427 + ,0.81256471,0.5828709909,0.3196460933,-0.9475370046,0.9570913859,0.2897862643,-0.6876655497,-0.7260276109 + ,-0.9988770922,-0.047376731,-0.1250179027,0.992154486,-0.8280133617,0.560708367,0.9324863769,-0.3612051451 + ,0.6394653183,0.7688199442,-0.01623847064,-0.9998681473,-0.9955014666,-0.09474613458,-0.81453315,0.580117012 + ,0.4037327978,-0.9148769469,0.9944263371,0.1054336766,-0.1624711654,0.9867132919,-0.9949487814,-0.100383875 + ,-0.6995302564,0.7146029809,0.5263414922,-0.85027327,-0.5395221479,0.841971408,0.6579370318,0.7530729462 + ,0.01426758847,-0.9998982128,-0.6734383991,0.7392433447,0.639412098,-0.7688642071,0.9211571421,0.3891908523 + ,-0.146637214,-0.9891903394,-0.782318098,0.6228791163,-0.5039610839,-0.8637263605,-0.7743120191,-0.6328039957 + ] diff --git a/src/Numeric/Noise/Fractal.hs b/src/Numeric/Noise/Fractal.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Noise/Fractal.hs @@ -0,0 +1,187 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE Strict #-} + +-- | +-- Maintainer: Jeremy Nuttall +-- Stability : experimental +module Numeric.Noise.Fractal ( + -- * Configuration + FractalConfig (..), + defaultFractalConfig, + PingPongStrength (..), + defaultPingPongStrength, + + -- * 2D Noise + fractal2, + billow2, + ridged2, + pingPong2, + + -- * 3D Noise + fractal3, + billow3, + ridged3, + pingPong3, + + -- * Utility + fractalNoiseMod, + fractalAmpMod, + billowNoiseMod, + billowAmpMod, + ridgedNoiseMod, + ridgedAmpMod, + pingPongNoiseMod, + pingPongAmpMod, +) where + +import GHC.Generics +import Numeric.Noise.Internal + +data FractalConfig a = FractalConfig + { octaves :: Int + , lacunarity :: a + , gain :: a + , weightedStrength :: a + } + deriving (Generic, Read, Show, Eq) + +defaultFractalConfig :: (RealFrac a) => FractalConfig a +defaultFractalConfig = + FractalConfig + { octaves = 7 + , lacunarity = 2 + , gain = 0.5 + , weightedStrength = 0 + } + +fractal2 :: (RealFrac a) => FractalConfig a -> Noise2 a -> Noise2 a +fractal2 config = Noise2 . fractal2With fractalNoiseMod (fractalAmpMod config) config . unNoise2 +{-# INLINE fractal2 #-} + +billow2 :: (RealFrac a) => FractalConfig a -> Noise2 a -> Noise2 a +billow2 config = Noise2 . fractal2With billowNoiseMod (billowAmpMod config) config . unNoise2 +{-# INLINE billow2 #-} + +ridged2 :: (RealFrac a) => FractalConfig a -> Noise2 a -> Noise2 a +ridged2 config = Noise2 . fractal2With ridgedNoiseMod (ridgedAmpMod config) config . unNoise2 +{-# INLINE ridged2 #-} + +pingPong2 :: (RealFrac a) => FractalConfig a -> PingPongStrength a -> Noise2 a -> Noise2 a +pingPong2 config strength = + Noise2 . fractal2With (pingPongNoiseMod strength) (pingPongAmpMod config) config . unNoise2 +{-# INLINE pingPong2 #-} + +fractal2With + :: (RealFrac a) + => (a -> a) + -- ^ modify noise before summation + -> (a -> a) + -- ^ modify amplitude + -> FractalConfig a + -> (Seed -> a -> a -> a) + -> Seed + -> a + -> a + -> a +fractal2With modNoise modAmps FractalConfig{..} noise2 seed x y + | octaves < 1 = error "octaves must be a positive integer" + | otherwise = + 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) + in go (o - 1) (acc + noise) (s + 1) (freq * lacunarity) amp' +{-# INLINE fractal2With #-} + +fractal3 :: (RealFrac a) => FractalConfig a -> Noise3 a -> Noise3 a +fractal3 config = Noise3 . fractal3With fractalNoiseMod (fractalAmpMod config) config . unNoise3 +{-# INLINE fractal3 #-} + +billow3 :: (RealFrac a) => FractalConfig a -> Noise3 a -> Noise3 a +billow3 config = Noise3 . fractal3With billowNoiseMod (billowAmpMod config) config . unNoise3 +{-# INLINE billow3 #-} + +ridged3 :: (RealFrac a) => FractalConfig a -> Noise3 a -> Noise3 a +ridged3 config = Noise3 . fractal3With ridgedNoiseMod (ridgedAmpMod config) config . unNoise3 +{-# INLINE ridged3 #-} + +pingPong3 :: (RealFrac a) => FractalConfig a -> PingPongStrength a -> Noise3 a -> Noise3 a +pingPong3 config strength = + Noise3 . fractal3With (pingPongNoiseMod strength) (pingPongAmpMod config) config . unNoise3 +{-# INLINE pingPong3 #-} + +fractal3With + :: (RealFrac a) + => (a -> a) + -- ^ modify noise before summation + -> (a -> a) + -- ^ modify amplitude + -> FractalConfig a + -> (Seed -> a -> a -> a -> a) + -> Seed + -> a + -> a + -> a + -> a +fractal3With modNoise modAmps FractalConfig{..} noise3 seed x y z + | octaves < 1 = error "octaves must be a positive integer" + | otherwise = + 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 (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 #-} + +fractalBounding :: (RealFrac a) => FractalConfig a -> a +fractalBounding FractalConfig{..} = + let amps = take octaves $ iterate (* gain) gain + in 1 / (sum amps + 1) +{-# INLINE fractalBounding #-} + +fractalNoiseMod :: a -> a +fractalNoiseMod = id +{-# INLINE fractalNoiseMod #-} +fractalAmpMod :: (Num a) => FractalConfig a -> a -> a +fractalAmpMod FractalConfig{..} n = lerp 1 n weightedStrength +{-# INLINE fractalAmpMod #-} + +billowNoiseMod :: (Num a) => a -> a +billowNoiseMod n = abs n * 2 - 1 +{-# INLINE billowNoiseMod #-} + +billowAmpMod :: (Num a) => FractalConfig a -> a -> a +billowAmpMod FractalConfig{..} n = lerp 1 n weightedStrength +{-# INLINE billowAmpMod #-} + +ridgedNoiseMod :: (Num a) => a -> a +ridgedNoiseMod n = abs n * (-2) + 1 +{-# INLINE ridgedNoiseMod #-} + +ridgedAmpMod :: (Num a) => FractalConfig a -> a -> a +ridgedAmpMod FractalConfig{..} n = lerp 1 (1 - n) weightedStrength +{-# INLINE ridgedAmpMod #-} + +newtype PingPongStrength a = PingPongStrength a + deriving (Generic) + +defaultPingPongStrength :: (RealFrac a) => PingPongStrength a +defaultPingPongStrength = PingPongStrength 2 +{-# INLINE defaultPingPongStrength #-} + +pingPongNoiseMod :: (RealFrac a) => PingPongStrength a -> a -> a +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 +{-# INLINE pingPongNoiseMod #-} + +pingPongAmpMod :: (Num a) => FractalConfig a -> a -> a +pingPongAmpMod FractalConfig{..} n = lerp 1 n weightedStrength +{-# INLINE pingPongAmpMod #-} diff --git a/src/Numeric/Noise/Internal.hs b/src/Numeric/Noise/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Noise/Internal.hs @@ -0,0 +1,162 @@ +-- | +-- Maintainer: Jeremy Nuttall +-- Stability : experimental +module Numeric.Noise.Internal ( + module Math, + Noise2 (..), + next2, + map2, + clamp2, + const2, + Noise3 (..), + next3, + map3, + clamp3, + const3, +) where + +import Numeric.Noise.Internal.Math as Math ( + Hash, + Seed, + clamp, + cubicInterp, + hermiteInterp, + lerp, + quinticInterp, + ) + +newtype Noise2 a = Noise2 + {unNoise2 :: Seed -> a -> a -> a} + +next2 :: Noise2 a -> Noise2 a +next2 (Noise2 f) = Noise2 (\s x y -> f (s + 1) x y) +{-# INLINE next2 #-} + +map2 :: (a -> a) -> Noise2 a -> Noise2 a +map2 f (Noise2 g) = Noise2 (\s x y -> f (g s x y)) +{-# INLINE map2 #-} + +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 #-} + +const2 :: a -> Noise2 a +const2 a = Noise2 (\_ _ _ -> a) +{-# INLINE const2 #-} + +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 #-} + +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 (/) #-} + +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 #-} + +newtype Noise3 a = Noise3 + {unNoise3 :: Seed -> a -> a -> a -> a} + +next3 :: Noise3 a -> Noise3 a +next3 (Noise3 f) = Noise3 (\s x y z -> f (s + 1) x y z) +{-# INLINE next3 #-} + +map3 :: (a -> a) -> Noise3 a -> Noise3 a +map3 f (Noise3 g) = Noise3 (\s x y z -> f (g s x y z)) +{-# INLINE map3 #-} + +const3 :: a -> Noise3 a +const3 a = Noise3 (\_ _ _ _ -> a) +{-# INLINE const3 #-} + +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 #-} + +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 #-} + +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 #-} + +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 #-} diff --git a/src/Numeric/Noise/Internal/Math.hs b/src/Numeric/Noise/Internal/Math.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Noise/Internal/Math.hs @@ -0,0 +1,211 @@ +{-# LANGUAGE OverloadedLists #-} + +-- | +-- Maintainer: Jeremy Nuttall +-- License: BSD-3-Clause +-- Stability : experimental +module Numeric.Noise.Internal.Math ( + Seed, + Hash, + lerp, + cubicInterp, + hermiteInterp, + quinticInterp, + clamp, + primeX, + primeY, + primeZ, + hash2, + hash3, + infinity, + g2, + sqrt3, + valCoord2, + valCoord3, + gradCoord2, + gradCoord3, + maxHash, +) where + +import Data.Bits +import Data.Int +import Data.Vector.Unboxed qualified as U +import Data.Word + +type Seed = Word64 +type Hash = Int32 + +-- | monotonic lerp +lerp + :: (Num a) + => a + -- ^ start + -> a + -- ^ end + -> a + -- ^ parameter in range [0, 1] + -> a +lerp v0 v1 t = v0 + t * (v1 - v0) +{-# INLINE lerp #-} + +-- | 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 #-} + +-- | hermite interpolation +hermiteInterp :: (Num a) => a -> a +hermiteInterp t = t * t * (3 - 2 * t) +{-# INLINE hermiteInterp #-} + +-- | quintic interpolation +quinticInterp :: (Num a) => a -> a +quinticInterp t = t * t * t * (t * (t * 6 - 15) + 10) +{-# INLINE quinticInterp #-} + +clamp + :: (Ord a) + => a + -- ^ lower bound + -> a + -- ^ upper bound + -> a + -- ^ value + -> a +clamp l u v + | v < l = l + | v > u = u + | otherwise = v +{-# INLINE clamp #-} + +primeX, primeY, primeZ :: Hash +primeX = 501125321 +{-# INLINE primeX #-} +primeY = 1136930381 +{-# INLINE primeY #-} +primeZ = 1720413743 +{-# INLINE primeZ #-} + +hash2 :: Seed -> Hash -> Hash -> Hash +hash2 seed xPrimed yPrimed = + (fromIntegral seed `xor` xPrimed `xor` yPrimed) + * 0x27d4eb2d +{-# INLINE hash2 #-} + +hash3 :: Seed -> Hash -> Hash -> Hash -> Hash +hash3 seed xPrimed yPrimed zPrimed = + (fromIntegral seed `xor` xPrimed `xor` yPrimed `xor` zPrimed) + * 0x27d4eb2d +{-# INLINE hash3 #-} + +infinity :: (Fractional a) => a +infinity = 1 / 0 +{-# INLINE infinity #-} + +g2 :: (Fractional a) => a +g2 = (3 - sqrt3) / 6 +{-# INLINE g2 #-} + +sqrt3 :: (Fractional a) => a +sqrt3 = 1.7320508075688772935274463415059 +{-# INLINE sqrt3 #-} + +valCoord2 :: (RealFrac a) => Word64 -> Hash -> Hash -> a +valCoord2 seed xPrimed yPrimed = + let !hash = hash2 seed xPrimed yPrimed + !val = (hash * hash) `xor` (hash `shiftL` 19) + in fromIntegral val / maxHash +{-# INLINE valCoord2 #-} + +valCoord3 :: (RealFrac a) => Word64 -> 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 +{-# 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 `U.unsafeIndex` fromIntegral ix + !yg = grad2d `U.unsafeIndex` fromIntegral (ix .|. 1) + in xd * realToFrac xg + yd * realToFrac yg +{-# INLINE 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 `U.unsafeIndex` fromIntegral ix + !yg = grad3d `U.unsafeIndex` fromIntegral (ix .|. 1) + !zg = grad3d `U.unsafeIndex` fromIntegral (ix .|. 2) + in xd * fromIntegral xg + yd * fromIntegral yg + zd * fromIntegral zg +{-# INLINE gradCoord3 #-} + +maxHash :: (RealFrac a) => a +maxHash = realToFrac (maxBound @Hash) +{-# INLINE maxHash #-} + +{- ORMOLU_DISABLE -} +-- >>> U.length grad2d == 256 +-- True +grad2d :: U.Vector Float +grad2d = + [ 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, + -0.130526192220052, -0.99144486137381 , -0.38268343236509 , -0.923879532511287, -0.608761429008721, -0.793353340291235, -0.793353340291235, -0.608761429008721, + -0.923879532511287, -0.38268343236509 , -0.99144486137381 , -0.130526192220052, -0.99144486137381 , 0.130526192220051, -0.923879532511287, 0.38268343236509, + -0.793353340291235, 0.608761429008721, -0.608761429008721, 0.793353340291235, -0.38268343236509 , 0.923879532511287, -0.130526192220052, 0.99144486137381, + 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, + -0.130526192220052, -0.99144486137381 , -0.38268343236509 , -0.923879532511287, -0.608761429008721, -0.793353340291235, -0.793353340291235, -0.608761429008721, + -0.923879532511287, -0.38268343236509 , -0.99144486137381 , -0.130526192220052, -0.99144486137381 , 0.130526192220051, -0.923879532511287, 0.38268343236509, + -0.793353340291235, 0.608761429008721, -0.608761429008721, 0.793353340291235, -0.38268343236509 , 0.923879532511287, -0.130526192220052, 0.99144486137381, + 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, + -0.130526192220052, -0.99144486137381 , -0.38268343236509 , -0.923879532511287, -0.608761429008721, -0.793353340291235, -0.793353340291235, -0.608761429008721, + -0.923879532511287, -0.38268343236509 , -0.99144486137381 , -0.130526192220052, -0.99144486137381 , 0.130526192220051, -0.923879532511287, 0.38268343236509, + -0.793353340291235, 0.608761429008721, -0.608761429008721, 0.793353340291235, -0.38268343236509 , 0.923879532511287, -0.130526192220052, 0.99144486137381, + 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, + -0.130526192220052, -0.99144486137381 , -0.38268343236509 , -0.923879532511287, -0.608761429008721, -0.793353340291235, -0.793353340291235, -0.608761429008721, + -0.923879532511287, -0.38268343236509 , -0.99144486137381 , -0.130526192220052, -0.99144486137381 , 0.130526192220051, -0.923879532511287, 0.38268343236509, + -0.793353340291235, 0.608761429008721, -0.608761429008721, 0.793353340291235, -0.38268343236509 , 0.923879532511287, -0.130526192220052, 0.99144486137381, + 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, + -0.130526192220052, -0.99144486137381 , -0.38268343236509 , -0.923879532511287, -0.608761429008721, -0.793353340291235, -0.793353340291235, -0.608761429008721, + -0.923879532511287, -0.38268343236509 , -0.99144486137381 , -0.130526192220052, -0.99144486137381 , 0.130526192220051, -0.923879532511287, 0.38268343236509, + -0.793353340291235, 0.608761429008721, -0.608761429008721, 0.793353340291235, -0.38268343236509 , 0.923879532511287, -0.130526192220052, 0.99144486137381, + 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 + ] + +-- >>> U.length grad3d == 256 +-- True +grad3d :: U.Vector Int +grad3d = + [ 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 + , 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 + , 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 + , 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 + , 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 + , 1, 1, 0, 0, 0, -1, 1, 0, -1, 1, 0, 0, 0, -1, -1, 0 + ] diff --git a/src/Numeric/Noise/OpenSimplex.hs b/src/Numeric/Noise/OpenSimplex.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Noise/OpenSimplex.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE Strict #-} + +-- | +-- Maintainer: Jeremy Nuttall +-- Stability: experimental +-- +-- This module implements a variation of OpenSimplex2 noise derived from FastNoiseLite. +module Numeric.Noise.OpenSimplex ( + -- * 2D Noise + noise2, + noise2Base, +) where + +import Numeric.Noise.Internal +import Numeric.Noise.Internal.Math + +noise2 :: (RealFrac a) => Noise2 a +noise2 = Noise2 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 + + 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 + + a = 0.5 - x0 * x0 - y0 * y0 + n0 + | a <= 0 = 0 + | otherwise = + (a * a) + * (a * a) + * gradCoord2 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 + + c = + 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 #-} diff --git a/src/Numeric/Noise/Perlin.hs b/src/Numeric/Noise/Perlin.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Noise/Perlin.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE Strict #-} + +-- | +-- Maintainer: Jeremy Nuttall +-- Stability : experimental +module Numeric.Noise.Perlin ( + -- * 2D + noise2, + noise2Base, + + -- * 3D + noise3, + noise3Base, +) +where + +import Numeric.Noise.Internal +import Numeric.Noise.Internal.Math + +noise2 :: (RealFrac a) => Noise2 a +noise2 = Noise2 noise2Base +{-# INLINE noise2 #-} + +noise2Base :: forall a. (RealFrac a) => Seed -> a -> a -> a +noise2Base seed x y = + let x0 = floor x + y0 = floor y + + xd0 = x - fromIntegral x0 + yd0 = y - fromIntegral y0 + xd1 = xd0 - 1 + yd1 = yd0 - 1 + + u = quinticInterp xd0 + v = quinticInterp yd0 + + x0p = x0 * primeX + y0p = y0 * primeY + + x1p = x0p + primeX + y1p = y0p + primeY + in 1.4247691104677813 + * lerp + ( lerp + (gradCoord2 seed x0p y0p xd0 yd0) + (gradCoord2 seed x1p y0p xd1 yd0) + u + ) + ( lerp + (gradCoord2 seed x0p y1p xd0 yd1) + (gradCoord2 seed x1p y1p xd1 yd1) + u + ) + v +{-# INLINE noise2Base #-} + +noise3 :: (RealFrac a) => Noise3 a +noise3 = Noise3 noise3Base +{-# INLINE noise3 #-} + +noise3Base :: (RealFrac a) => Seed -> a -> a -> a -> a +noise3Base seed x y z = + let x0 = floor x + y0 = floor y + z0 = floor z + + xd0 = x - fromIntegral x0 + yd0 = y - fromIntegral y0 + zd0 = z - fromIntegral z0 + + xd1 = xd0 - 1 + yd1 = yd0 - 1 + zd1 = zd0 - 1 + + u = quinticInterp xd0 + v = quinticInterp yd0 + w = quinticInterp zd0 + + x0p = x0 * primeX + y0p = y0 * primeY + z0p = z0 * primeZ + x1p = x0p + primeX + y1p = y0p + primeY + z1p = z0p + primeZ + in 0.96492141485214233398437 + * lerp + ( lerp + ( lerp + (gradCoord3 seed x0p y0p z0p xd0 yd0 zd0) + (gradCoord3 seed x1p y0p z0p xd1 yd0 zd0) + u + ) + ( lerp + (gradCoord3 seed x0p y1p z0p xd0 yd1 zd0) + (gradCoord3 seed x1p y1p z0p xd1 yd1 zd0) + u + ) + v + ) + ( lerp + ( lerp + (gradCoord3 seed x0p y0p z1p xd0 yd0 zd1) + (gradCoord3 seed x1p y0p z1p xd1 yd0 zd1) + u + ) + ( lerp + (gradCoord3 seed x0p y1p z1p xd0 yd1 zd1) + (gradCoord3 seed x1p y1p z1p xd1 yd1 zd1) + u + ) + v + ) + w +{-# INLINE noise3Base #-} diff --git a/src/Numeric/Noise/SuperSimplex.hs b/src/Numeric/Noise/SuperSimplex.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Noise/SuperSimplex.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE Strict #-} + +-- | +-- Maintainer: Jeremy Nuttall +-- Stability: experimental +-- +-- This module implements a variation of OpenSimplex2 noise derived from FastNoiseLite. +-- See openSimplex2S +module Numeric.Noise.SuperSimplex ( + -- * 2D Noise + noise2, + noise2Base, +) where + +import Data.Bits +import Numeric.Noise.Internal +import Numeric.Noise.Internal.Math + +noise2 :: (RealFrac a) => Noise2 a +noise2 = Noise2 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 + + fx = floor x + fy = floor y + xi = x - fromIntegral @Hash fx + yi = y - fromIntegral @Hash fy + + i = fx * primeX + j = fy * primeY + i1 = i + primeX + j1 = j + primeY + + t = (xi + yi) * g2 + x0 = xi - t + y0 = yi - t + + a0 = (2 / 3) - x0 * x0 - y0 * y0 + v0 = (a0 * a0) * (a0 * a0) * gradCoord2 seed i j x0 y0 + + v1 = + let g2t = 1 - 2 * g2 + a1 = + (2 * g2t * (1 / g2 - 2)) * t + + ((-2 * g2t * g2t) + a0) + x1 = x0 - g2t + y1 = y0 - g2t + in (a1 * a1) * (a1 * a1) * gradCoord2 seed i1 j1 x1 y1 + + xmyi = xi - yi + + ~vgx + | xi + xmyi > 1 = + 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 + | 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 + ~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 + | 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 + + ~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 + | 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 + ~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 + | 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 + + v2 + | t > g2 = vgx + vgy + | otherwise = vlx + vly + in (v0 + v1 + v2) * 18.24196194486065 +{-# INLINE noise2Base #-} diff --git a/src/Numeric/Noise/Value.hs b/src/Numeric/Noise/Value.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Noise/Value.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE Strict #-} + +-- | +-- Maintainer: Jeremy Nuttall +-- Stability: experimental +-- +-- This module implements a variation of value noise derived from FastNoiseLite. +module Numeric.Noise.Value ( + -- * 2D Noise + noise2, + noise2Base, + + -- * 3D Noise + noise3, + noise3Base, +) +where + +import Numeric.Noise.Internal +import Numeric.Noise.Internal.Math + +noise2 :: (RealFrac a) => Noise2 a +noise2 = Noise2 noise2Base +{-# INLINE noise2 #-} + +noise2Base :: (RealFrac a) => Seed -> a -> a -> a +noise2Base seed x y = + let x0 = floor x + y0 = floor y + + xs = hermiteInterp (x - fromIntegral x0) + ys = hermiteInterp (y - fromIntegral y0) + + x0p = x0 * primeX + y0p = y0 * primeY + + x1 = x0p + primeX + y1 = y0p + primeY + in lerp + ( lerp + (valCoord2 seed x0p y0p) + (valCoord2 seed x1 y0p) + xs + ) + ( lerp + (valCoord2 seed x0p y1) + (valCoord2 seed x1 y1) + xs + ) + ys +{-# INLINE noise2Base #-} + +noise3 :: (RealFrac a) => Noise3 a +noise3 = Noise3 noise3Base +{-# INLINE noise3 #-} + +noise3Base :: (RealFrac a) => Seed -> a -> a -> a -> a +noise3Base seed x y z = + let x0 = floor x + y0 = floor y + z0 = floor z + + xs = hermiteInterp (x - fromIntegral x0) + ys = hermiteInterp (y - fromIntegral y0) + zs = hermiteInterp (z - fromIntegral z0) + + x0p = x0 * primeX + y0p = y0 * primeY + z0p = z0 * primeZ + + x1 = x0p + primeX + y1 = y0p + primeY + z1 = z0p + primeZ + in lerp + ( lerp + ( lerp + (valCoord3 seed x0p y0p z0p) + (valCoord3 seed x1 y0p z0p) + xs + ) + ( lerp + (valCoord3 seed x0p y1 z0p) + (valCoord3 seed x1 y1 z0p) + xs + ) + ys + ) + ( lerp + ( lerp + (valCoord3 seed x0p y0p z1) + (valCoord3 seed x1 y0p z1) + xs + ) + ( lerp + (valCoord3 seed x0p y1 z1) + (valCoord3 seed x1 y1 z1) + xs + ) + ys + ) + zs +{-# INLINE noise3Base #-} diff --git a/src/Numeric/Noise/ValueCubic.hs b/src/Numeric/Noise/ValueCubic.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Noise/ValueCubic.hs @@ -0,0 +1,226 @@ +{-# LANGUAGE Strict #-} + +-- | +-- Maintainer: Jeremy Nuttall +-- Stability : experimental +module Numeric.Noise.ValueCubic ( + -- * 2D Noise + noise2, + noise2Base, + + -- * 3D Noise + noise3, + noise3Base, +) where + +import Data.Bits +import Numeric.Noise.Internal +import Numeric.Noise.Internal.Math + +noise2 :: (RealFrac a) => Noise2 a +noise2 = Noise2 noise2Base +{-# INLINE noise2 #-} + +noise2Base :: (RealFrac a) => Seed -> a -> a -> a +noise2Base seed x y = + let x1f = floor x + y1f = floor y + + xs = x - fromIntegral x1f + ys = y - fromIntegral y1f + + x1 = x1f * primeX + y1 = y1f * primeY + x0 = x1 - primeX + y0 = y1 - primeY + x2 = x1 + primeX + y2 = y1 + primeY + x3 = x1 + (primeX `shiftL` 1) + y3 = y1 + (primeY `shiftL` 1) + in recip (1.5 * 1.5) + * cubicInterp + ( cubicInterp + (valCoord2 seed x0 y0) + (valCoord2 seed x1 y0) + (valCoord2 seed x2 y0) + (valCoord2 seed x3 y0) + xs + ) + ( cubicInterp + (valCoord2 seed x0 y1) + (valCoord2 seed x1 y1) + (valCoord2 seed x2 y1) + (valCoord2 seed x3 y1) + xs + ) + ( cubicInterp + (valCoord2 seed x0 y2) + (valCoord2 seed x1 y2) + (valCoord2 seed x2 y2) + (valCoord2 seed x3 y2) + xs + ) + ( cubicInterp + (valCoord2 seed x0 y3) + (valCoord2 seed x1 y3) + (valCoord2 seed x2 y3) + (valCoord2 seed x3 y3) + xs + ) + ys +{-# INLINE noise2Base #-} + +noise3 :: (RealFrac a) => Noise3 a +noise3 = Noise3 noise3Base +{-# INLINE noise3 #-} + +noise3Base :: (RealFrac a) => Seed -> a -> a -> a -> a +noise3Base seed x y z = + let x1f = floor x + y1f = floor y + z1f = floor z + + xs = x - fromIntegral x1f + ys = y - fromIntegral y1f + zs = z - fromIntegral z1f + + x1 = x1f * primeX + y1 = y1f * primeY + z1 = z1f * primeZ + x0 = x1 - primeX + y0 = y1 - primeY + z0 = z1 - primeZ + x2 = x1 + primeX + y2 = y1 + primeY + z2 = z1 + primeZ + x3 = x1 + (primeX `shiftL` 1) + y3 = y1 + (primeY `shiftL` 1) + z3 = z1 + (primeZ `shiftL` 1) + in recip (1.5 * 1.5 * 1.5) + * cubicInterp + ( cubicInterp + ( cubicInterp + (valCoord3 seed x0 y0 z0) + (valCoord3 seed x1 y0 z0) + (valCoord3 seed x2 y0 z0) + (valCoord3 seed x3 y0 z0) + xs + ) + ( cubicInterp + (valCoord3 seed x0 y1 z0) + (valCoord3 seed x1 y1 z0) + (valCoord3 seed x2 y1 z0) + (valCoord3 seed x3 y1 z0) + xs + ) + ( cubicInterp + (valCoord3 seed x0 y2 z0) + (valCoord3 seed x1 y2 z0) + (valCoord3 seed x2 y2 z0) + (valCoord3 seed x3 y2 z0) + xs + ) + ( cubicInterp + (valCoord3 seed x0 y3 z0) + (valCoord3 seed x1 y3 z0) + (valCoord3 seed x2 y3 z0) + (valCoord3 seed x3 y3 z0) + xs + ) + ys + ) + ( cubicInterp + ( cubicInterp + (valCoord3 seed x0 y0 z1) + (valCoord3 seed x1 y0 z1) + (valCoord3 seed x2 y0 z1) + (valCoord3 seed x3 y0 z1) + xs + ) + ( cubicInterp + (valCoord3 seed x0 y1 z1) + (valCoord3 seed x1 y1 z1) + (valCoord3 seed x2 y1 z1) + (valCoord3 seed x3 y1 z1) + xs + ) + ( cubicInterp + (valCoord3 seed x0 y2 z1) + (valCoord3 seed x1 y2 z1) + (valCoord3 seed x2 y2 z1) + (valCoord3 seed x3 y2 z1) + xs + ) + ( cubicInterp + (valCoord3 seed x0 y3 z1) + (valCoord3 seed x1 y3 z1) + (valCoord3 seed x2 y3 z1) + (valCoord3 seed x3 y3 z1) + xs + ) + ys + ) + ( cubicInterp + ( cubicInterp + (valCoord3 seed x0 y0 z2) + (valCoord3 seed x1 y0 z2) + (valCoord3 seed x2 y0 z2) + (valCoord3 seed x3 y0 z2) + xs + ) + ( cubicInterp + (valCoord3 seed x0 y1 z2) + (valCoord3 seed x1 y1 z2) + (valCoord3 seed x2 y1 z2) + (valCoord3 seed x3 y1 z2) + xs + ) + ( cubicInterp + (valCoord3 seed x0 y2 z2) + (valCoord3 seed x1 y2 z2) + (valCoord3 seed x2 y2 z2) + (valCoord3 seed x3 y2 z2) + xs + ) + ( cubicInterp + (valCoord3 seed x0 y3 z2) + (valCoord3 seed x1 y3 z2) + (valCoord3 seed x2 y3 z2) + (valCoord3 seed x3 y3 z2) + xs + ) + ys + ) + ( cubicInterp + ( cubicInterp + (valCoord3 seed x0 y0 z3) + (valCoord3 seed x1 y0 z3) + (valCoord3 seed x2 y0 z3) + (valCoord3 seed x3 y0 z3) + xs + ) + ( cubicInterp + (valCoord3 seed x0 y1 z3) + (valCoord3 seed x1 y1 z3) + (valCoord3 seed x2 y1 z3) + (valCoord3 seed x3 y1 z3) + xs + ) + ( cubicInterp + (valCoord3 seed x0 y2 z3) + (valCoord3 seed x1 y2 z3) + (valCoord3 seed x2 y2 z3) + (valCoord3 seed x3 y2 z3) + xs + ) + ( cubicInterp + (valCoord3 seed x0 y3 z3) + (valCoord3 seed x1 y3 z3) + (valCoord3 seed x2 y3 z3) + (valCoord3 seed x3 y3 z3) + xs + ) + ys + ) + zs +{-# INLINE noise3Base #-} diff --git a/test/Driver.hs b/test/Driver.hs new file mode 100644 --- /dev/null +++ b/test/Driver.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display #-} diff --git a/test/Noise2Spec.hs b/test/Noise2Spec.hs new file mode 100644 --- /dev/null +++ b/test/Noise2Spec.hs @@ -0,0 +1,48 @@ +module Noise2Spec where + +import Numeric.Noise +import Numeric.Noise.Internal + +seed :: Seed +seed = 55 + +prop_addition :: Rational -> Rational -> Bool +prop_addition x y = noise2At (const2 x + const2 y) seed x y == x + y + +prop_addition_associative :: Rational -> Rational -> Bool +prop_addition_associative x y = + let n1 = const2 2003 + n2 = const2 2027 + n3 = const2 2069 + in noise2At ((n1 + n2) + n3) seed x y == noise2At (n1 + (n2 + n3)) seed x y + +prop_addition_commutative :: Rational -> Rational -> Bool +prop_addition_commutative x y = + let n1 = const2 x + n2 = const2 y + in noise2At (n1 + n2) seed x y == noise2At (n2 + n1) seed x y + +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 + +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 + +prop_multiplication :: Rational -> Rational -> Bool +prop_multiplication x y = noise2At (const2 x * const2 y) seed x y == x * y + +prop_multiplication_associative :: Rational -> Rational -> Bool +prop_multiplication_associative x y = + let n1 = const2 2003 + 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 new file mode 100644 --- /dev/null +++ b/test/Noise3Spec.hs @@ -0,0 +1,50 @@ +module Noise3Spec where + +import Numeric.Noise +import Numeric.Noise.Internal + +seed :: Seed +seed = 2381 + +prop_addition :: Rational -> Rational -> Rational -> Bool +prop_addition x y z = + noise3At (const3 x + const3 y + const3 z) seed x y z == x + y + z + +prop_addition_associative :: Rational -> Rational -> Rational -> Bool +prop_addition_associative x y z = + let n1 = const3 2003 + n2 = const3 2027 + n3 = const3 2069 + in noise3At ((n1 + n2) + n3) seed x y z == noise3At (n1 + (n2 + n3)) seed x y z + +prop_addition_commutative :: Rational -> Rational -> Rational -> Bool +prop_addition_commutative x y z = + let n1 = const3 x + n2 = const3 y + in noise3At (n1 + n2) seed x y z == noise3At (n2 + n1) seed x y z + +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 + +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 + +prop_multiplication :: Rational -> Rational -> Rational -> Bool +prop_multiplication x y z = + noise3At (const3 x * const3 y * const3 z) seed x y z == x * y * z + +prop_multiplication_associative :: Rational -> Rational -> Rational -> Bool +prop_multiplication_associative x y z = + let n1 = const3 2003 + n2 = const3 2027 + n3 = const3 2069 + in noise3At ((n1 * n2) * n3) seed x y z == noise3At (n1 * (n2 * n3)) seed x y z + +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 diff --git a/test/PerlinSpec.hs b/test/PerlinSpec.hs new file mode 100644 --- /dev/null +++ b/test/PerlinSpec.hs @@ -0,0 +1,19 @@ +module PerlinSpec where + +import Numeric.Noise + +seed :: Seed +seed = 82384 + +prop_noise2_normalized :: Double -> Double -> Bool +prop_noise2_normalized x y = + let n = noise2At perlin2 seed x y + in n >= -1 && n <= 1 + +prop_noise2_addition_associative :: Rational -> Rational -> Bool +prop_noise2_addition_associative x y = + noise2At ((perlin2 + perlin2) + perlin2) seed x y == noise2At (perlin2 + (perlin2 + perlin2)) seed x y + +prop_noise2_addition_commutative :: Rational -> Rational -> Bool +prop_noise2_addition_commutative x y = + noise2At (perlin2 + perlin2) seed x y == noise2At (perlin2 + perlin2) seed x y