pure-noise (empty) → 0.1.0.0
raw patch · 21 files changed
+2190/−0 lines, 21 filesdep +basedep +deepseqdep +mwc-randomsetup-changed
Dependencies added: base, deepseq, mwc-random, pure-noise, tasty, tasty-bench, tasty-discover, tasty-hunit, tasty-quickcheck, vector
Files
- CHANGELOG.md +13/−0
- LICENSE +30/−0
- README.md +76/−0
- Setup.hs +3/−0
- bench/Bench.hs +295/−0
- bench/BenchLib.hs +12/−0
- pure-noise.cabal +94/−0
- src/Numeric/Noise.hs +112/−0
- src/Numeric/Noise/Cellular.hs +201/−0
- src/Numeric/Noise/Fractal.hs +187/−0
- src/Numeric/Noise/Internal.hs +162/−0
- src/Numeric/Noise/Internal/Math.hs +211/−0
- src/Numeric/Noise/OpenSimplex.hs +86/−0
- src/Numeric/Noise/Perlin.hs +114/−0
- src/Numeric/Noise/SuperSimplex.hs +148/−0
- src/Numeric/Noise/Value.hs +102/−0
- src/Numeric/Noise/ValueCubic.hs +226/−0
- test/Driver.hs +1/−0
- test/Noise2Spec.hs +48/−0
- test/Noise3Spec.hs +50/−0
- test/PerlinSpec.hs +19/−0
+ CHANGELOG.md view
@@ -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
+ LICENSE view
@@ -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.
+ README.md view
@@ -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_+++++_Perlin_++++_Cellular_+++
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain
+ bench/Bench.hs view
@@ -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 #-}
+ bench/BenchLib.hs view
@@ -0,0 +1,12 @@+module BenchLib (+ Benchmark,+ Benchmarkable,+ bgroup,+ defaultMain,+ env,+ bench,+ nf,+ whnf,+) where++import Test.Tasty.Bench
+ pure-noise.cabal view
@@ -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 <https://github.com/jtnuttall/pure-noise#readme>+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
+ src/Numeric/Noise.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE Strict #-}++-- |+-- Maintainer: Jeremy Nuttall <jeremy@jeremy-nuttall.com>+-- 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 #-}
+ src/Numeric/Noise/Cellular.hs view
@@ -0,0 +1,201 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE RecordWildCards #-}++-- |+-- Maintainer: Jeremy Nuttall <jeremy@jeremy-nuttall.com>+-- 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+ ]
+ src/Numeric/Noise/Fractal.hs view
@@ -0,0 +1,187 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE Strict #-}++-- |+-- Maintainer: Jeremy Nuttall <jeremy@jeremy-nuttall.com>+-- 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 #-}
+ src/Numeric/Noise/Internal.hs view
@@ -0,0 +1,162 @@+-- |+-- Maintainer: Jeremy Nuttall <jeremy@jeremy-nuttall.com>+-- 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 #-}
+ src/Numeric/Noise/Internal/Math.hs view
@@ -0,0 +1,211 @@+{-# LANGUAGE OverloadedLists #-}++-- |+-- Maintainer: Jeremy Nuttall <jeremy@jeremy-nuttall.com>+-- 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+ ]
+ src/Numeric/Noise/OpenSimplex.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE Strict #-}++-- |+-- Maintainer: Jeremy Nuttall <jeremy@jeremy-nuttall.com>+-- 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 #-}
+ src/Numeric/Noise/Perlin.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE Strict #-}++-- |+-- Maintainer: Jeremy Nuttall <jeremy@jeremy-nuttall.com>+-- 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 #-}
+ src/Numeric/Noise/SuperSimplex.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE Strict #-}++-- |+-- Maintainer: Jeremy Nuttall <jeremy@jeremy-nuttall.com>+-- 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 #-}
+ src/Numeric/Noise/Value.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE Strict #-}++-- |+-- Maintainer: Jeremy Nuttall <jeremy@jeremy-nuttall.com>+-- 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 #-}
+ src/Numeric/Noise/ValueCubic.hs view
@@ -0,0 +1,226 @@+{-# LANGUAGE Strict #-}++-- |+-- Maintainer: Jeremy Nuttall <jeremy@jeremy-nuttall.com>+-- 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 #-}
+ test/Driver.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display #-}
+ test/Noise2Spec.hs view
@@ -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
+ test/Noise3Spec.hs view
@@ -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
+ test/PerlinSpec.hs view
@@ -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