Add basic support for perlin noise textures

haray.cabal

@@ -28,6 +28,7 @@ Library
                      , lin-alg      == 0.1.*
                      , JuicyPixels  < 4
                      , vector       < 1
+                     , random
 
   Exposed-modules:     Graphics.Rendering.Haray.Bitmap
                      , Graphics.Rendering.Haray.Camera

scenes/example7

@@ -0,0 +1,21 @@
+[ SECamera { camEye     = Vec3 0.0 0.0 300.0
+           , camGaze    = Vec3 0.0 0.0 (-1.0)
+           , camUp      = Vec3 0.0 1.0 0.0
+           , camU0      = -1.2
+           , camV0      = -1.2
+           , camU1      = 1.2
+           , camV1      = 1.2
+           , camDist    = 1.0
+           , camNX      = 500
+           , camNY      = 500
+           , camApeture = 2}
+, SEDirectedLight (DirectedLight { dlDirection = Vec3 0 (-1) 0
+                                 , dlColor = Vec3 0.8 0.8 0.8 })
+, SEAmbientLight (AmbientLight { alColor = Vec3 0.2 0.2 0.2 })
+, SESphere (Sphere { sCenter = Vec3 0.0 0.0 (-30.0)
+                   , sRadius = 150.0
+                   , sTexture = BWNoise})
+, SEPlane (Plane { pCenter = Vec3 0 (-200) 0
+                 , pNormal = Vec3 0 1 0
+                 , pTexture = Matte (Vec3 0.1 0.3 0.7) })
+]

src/Graphics/Rendering/Haray/Render.hs

@@ -32,9 +32,9 @@ renderSceneFromFile from = do
 
 renderScene :: [SceneElement] -> IO (MutableImage RealWorld PixelRGB8)
 renderScene scene = do
+  shapes <- mkShapes scene
   let (camera, nx, ny) = maybe defaultCamera id c'
       c'               = S.mkCamera scene
-      shapes           = mkShapes scene
       directedLights   = mkDirectedLights scene
       ambientLight     = maybe defaultAmbient id (mkAmbientLight scene)
       for              = flip map

src/Graphics/Rendering/Haray/Scene.hs

@@ -10,6 +10,7 @@ import Numeric.LinearAlgebra.Vector
 import Graphics.Rendering.Haray.RGB
 import Graphics.Rendering.Haray.Texture
 import Graphics.Rendering.Haray.Luminaire
+import Control.Applicative
 
 type Scene = [SceneElement]
 
@@ -33,11 +34,13 @@ data SceneElement = SESphere (Sphere Float)
 
 data TextureDescription a = Matte (RGB a)
   | Stripe
+  | BWNoise
   deriving (Read, Show, Eq, Ord)
 
-mkTexture :: (Ord a, Floating a) => TextureDescription a -> Texture a
-mkTexture (Matte rgb) = mkMatteTexture (MatteData rgb)
-mkTexture Stripe = mkStripeTexture
+mkTexture :: (Ord a, RealFrac a, Floating a) => TextureDescription a -> IO (Texture a)
+mkTexture (Matte rgb) = return (mkMatteTexture (MatteData rgb))
+mkTexture Stripe      = return mkStripeTexture
+mkTexture BWNoise     = mkBWNoiseTexture
 
 data Triangle a = Triangle
   { tP0      :: Vec3 a
@@ -46,45 +49,57 @@ data Triangle a = Triangle
   , tTexture :: TextureDescription a
   } deriving (Read, Show, Eq, Ord)
 
-mkTriangle :: (Ord a, Floating a) => Triangle a -> TriangleData a
-mkTriangle (Triangle p0 p1 p2 tex) = TriangleData
-  { tdP0  = p0
-  , tdP1  = p1
-  , tdP2  = p2
-  , tdTex = mkTexture tex }
+mkTriangle :: (Ord a, RealFrac a, Floating a) => Triangle a -> IO (TriangleData a)
+mkTriangle (Triangle p0 p1 p2 tex) = do
+  tex' <- mkTexture tex
+  return (TriangleData
+    { tdP0  = p0
+    , tdP1  = p1
+    , tdP2  = p2
+    , tdTex = tex' })
 
 data Sphere a = Sphere
   { sCenter  :: Vec3 a
   , sRadius  :: a
   , sTexture :: TextureDescription a
   } deriving (Read, Show, Eq, Ord)
 
-mkSphere :: (Ord a, Floating a) => Sphere a -> SphereData a
-mkSphere (Sphere c r tex) = SphereData
-  { sphereCenter = c
-  , sphereRadius = r
-  , sphereTex = mkTexture tex }
+mkSphere :: (Ord a, RealFrac a, Floating a) => Sphere a -> IO (SphereData a)
+mkSphere (Sphere c r tex) = do
+  tex' <- mkTexture tex
+  return (SphereData
+    { sphereCenter = c
+    , sphereRadius = r
+    , sphereTex    = tex' })
 
 data Plane a = Plane
   { pCenter  :: Vec3 a
   , pNormal  :: Vec3 a
   , pTexture :: TextureDescription a
   } deriving (Read, Show, Eq, Ord)
 
-mkPlane :: (Ord a, Floating a) => Plane a -> PlaneData a
-mkPlane (Plane c n tex) = PlaneData
-  { pdCenter  = c
-  , pdNormal  = n
-  , pdTex     = mkTexture tex }
-
-mkShape :: SceneElement -> Maybe (Shape Float)
-mkShape (SESphere sd)   = Just $ Shape.mkSphere (mkSphere sd)
-mkShape (SETriangle td) = Just $ Shape.mkTriangle (mkTriangle td)
-mkShape (SEPlane pd)    = Just $ Shape.mkPlane (mkPlane pd)
-mkShape _               = Nothing
-
-mkShapes :: Scene -> [Shape Float]
-mkShapes = catMaybes . map mkShape
+mkPlane :: (Ord a, RealFrac a, Floating a) => Plane a -> IO (PlaneData a)
+mkPlane (Plane c n tex) = do
+  tex' <- mkTexture tex
+  return (PlaneData
+    { pdCenter  = c
+    , pdNormal  = n
+    , pdTex     = tex' })
+
+mkShape :: SceneElement -> IO (Maybe (Shape Float))
+mkShape (SESphere sd)   = do
+  s <- mkSphere sd
+  return $ Just $ Shape.mkSphere s
+mkShape (SETriangle td) = do
+  t <- mkTriangle td
+  return $ Just $ Shape.mkTriangle t
+mkShape (SEPlane pd)    = do
+  p <- mkPlane pd
+  return $ Just $ Shape.mkPlane p
+mkShape _               = return Nothing
+
+mkShapes :: Scene -> IO [Shape Float]
+mkShapes scene = catMaybes <$> mapM mkShape scene
 
 readScene :: FilePath -> IO Scene
 readScene fp = do
@@ -109,7 +124,7 @@ mkCamera = listToMaybe . catMaybes . map mkCamera'
 readSceneToShapes :: FilePath -> IO [Shape Float]
 readSceneToShapes fp = do
   sc <- readScene fp
-  return (mkShapes sc)
+  mkShapes sc
 
 readSceneToCamera :: FilePath -> IO (Maybe (C.Camera Float, Int, Int))
 readSceneToCamera fp = do

src/Graphics/Rendering/Haray/SolidNoise.hs

@@ -1,7 +1,125 @@
-module Graphics.Rendering.Haray.SolidNoise where
+{-# LANGUAGE BangPatterns #-}
+module Graphics.Rendering.Haray.SolidNoise
+( SolidNoise
+, mkSolidNoise
+, omega
+, gamma
+, intGamma
+, knot
+, turbulence
+, dturbulence
+, noise
+) where
 
-{-# SPECIALIZE omega :: Double -> Double #-}
-{-# SPECIALIZE omega :: Float -> Float #-}
+import Numeric.LinearAlgebra.Vector
+
+import qualified Data.Vector as V
+
+import System.Random -- There are better ways...
+
+data SolidNoise a = SolidNoise
+  { snGradient :: !(V.Vector (Vec3 a)) -- TODO: smart constructor alert: this is meant to have length 16
+  , snPhi      :: !(V.Vector Int)
+  } deriving (Read, Show, Eq, Ord)
+
+gradientSize :: Int
+gradientSize = 16
+
+-- | Computes w(t) = -6|t|^6 + 15|t|^4 - 10|t|^3 + 1
+-- and assumes that t in [-1, 1]
 omega :: (Ord a, Floating a) => a -> a
 omega t | t < 0 = omega (negate t)
 omega t = (-6)*t*t*t*t*t + 15*t*t*t*t + (-10)*t*t*t + 1
+{-# SPECIALIZE INLINE omega :: Double -> Double #-}
+{-# SPECIALIZE INLINE omega :: Float -> Float #-}
+
+gamma :: (Floating a, Ord a) => SolidNoise a -> Int -> Int -> Int -> Vec3 a
+gamma sn i j k = (snGradient sn) V.! idx2
+  where
+  phi  = snPhi sn
+  idx0 = abs k `mod` gradientSize
+  idx1 = phi V.! (abs (j + idx0) `mod` gradientSize)
+  idx2 = phi V.! (abs (i + idx1) `mod` gradientSize)
+{-# SPECIALIZE INLINE gamma :: SolidNoise Double -> Int -> Int -> Int -> Vec3 Double #-}
+{-# SPECIALIZE INLINE gamma :: SolidNoise Float  -> Int -> Int -> Int -> Vec3 Float #-}
+
+intGamma :: (Floating a, Ord a) => SolidNoise a -> Int -> Int -> Int
+intGamma sn i j = idx2
+  where
+  phi = snPhi sn
+  idx0 = abs j `mod` gradientSize
+  idx1 = phi V.! idx0
+  idx2 = phi V.! (abs (i + idx1) `mod` gradientSize)
+{-# SPECIALIZE INLINE intGamma :: SolidNoise Double -> Int -> Int -> Int #-}
+{-# SPECIALIZE INLINE intGamma :: SolidNoise Float  -> Int -> Int -> Int #-}
+
+knot :: (Floating a, Ord a) => SolidNoise a -> Int -> Int -> Int -> Vec3 a -> a
+knot sn i j k v@(Vec3 x y z) = omega x * omega y * omega z * (gamma sn i j k <.> v)
+{-# SPECIALIZE INLINE knot :: SolidNoise Double -> Int -> Int -> Int -> Vec3 Double -> Double #-}
+{-# SPECIALIZE INLINE knot :: SolidNoise Float  -> Int -> Int -> Int -> Vec3 Float  -> Float #-}
+
+mkSolidNoise :: Num a => IO (SolidNoise a)
+mkSolidNoise = do
+  let v = V.fromList [Vec3 1 1 0, Vec3 (-1)    1 0, Vec3 1 (-1)    0, Vec3 (-1) (-1)    0
+                     ,Vec3 1 0 1, Vec3 (-1)    0 1, Vec3 1    0 (-1), Vec3 (-1)    0 (-1)
+                     ,Vec3 0 1 1, Vec3    0 (-1) 1, Vec3 0    1 (-1), Vec3 0    (-1) (-1)
+                     ,Vec3 1 1 0, Vec3 (-1)    1 0, Vec3 0 (-1)    1, Vec3 0    (-1) (-1)]
+      phi = [0..gradientSize-1]
+  phi' <- shuffle phi
+  return $! SolidNoise { snGradient = v, snPhi = V.fromList phi' }
+  where
+  -- This is slightly inefficient in terms of list operations, but our lists are only
+  -- length 16 so it seems like overkill to use other data structures.
+  fetch :: [a] -> IO (a,[a])
+  fetch []  = error "Graphics.Rendering.Haray.SolidNoise.fetch: called on []"
+  fetch [x] = return (x,[])
+  fetch xs  = do
+    i <- randomRIO (1, length xs)
+    let (h,tl) = splitAt i xs
+    return (last h, init h ++ tl)
+
+  shuffle :: [a] -> IO [a]
+  shuffle [] = return []
+  shuffle xs = do
+    (x,xs') <- fetch xs
+    ys      <- shuffle xs'
+    return $! x : ys
+
+turbulence :: (RealFrac a, Floating a) => SolidNoise a -> Vec3 a -> Int -> a
+turbulence _  _ depth | depth < 1 = error "Graphics.Rendering.Haray.SolidNoise.turbulence: depth must be > 0"
+turbulence sn p depth = sum (zipWith (/) ns twos)
+  where
+  twos = map (2^) [0..depth-1]
+  ps   = zipWith (*>) twos (repeat p)
+  ns   = map (abs . (noise sn)) ps
+{-# SPECIALIZE turbulence :: SolidNoise Double -> Vec3 Double -> Int -> Double #-}
+{-# SPECIALIZE turbulence :: SolidNoise Float  -> Vec3 Float  -> Int -> Float  #-}
+
+dturbulence :: (RealFrac a, Floating a) => SolidNoise a -> Vec3 a -> Int -> a -> a
+dturbulence _  _ depth _ | depth < 1 = error "Graphics.Rendering.Haray.SolidNoise.dturbulence: depth must be > 0"
+dturbulence sn p depth d = sum (zipWith (/) ns ds)
+  where
+  ds = map (d^) [0..depth-1]
+  ps = zipWith (*>) ds (repeat p)
+  ns = map (abs . (noise sn)) ps
+{-# SPECIALIZE dturbulence :: SolidNoise Double -> Vec3 Double -> Int -> Double -> Double #-}
+{-# SPECIALIZE dturbulence :: SolidNoise Float  -> Vec3 Float  -> Int -> Float  -> Float  #-}
+
+noise :: (RealFrac a, Floating a) => SolidNoise a -> Vec3 a -> a
+noise sn (Vec3 x y z) = 
+  let !fi = floor x
+      !fj = floor y
+      !fk = floor z
+      !fu = x - fromIntegral fi
+      !fv = y - fromIntegral fj
+      !fw = z - fromIntegral fk
+  in sum [knot sn fi     fj     fk     (Vec3 fu     fv     fw)
+         ,knot sn (fi+1) fj     fk     (Vec3 (fu-1) fv     fw)
+         ,knot sn fi     (fj+1) fk     (Vec3 fu     (fv-1) fw)
+         ,knot sn fi     fj     (fk+1) (Vec3 fu     fv     (fw-1))
+         ,knot sn (fi+1) (fj+1) fk     (Vec3 (fu-1) (fv-1) fw)
+         ,knot sn (fi+1) fj     (fk+1) (Vec3 (fu-1) fv     (fw-1))
+         ,knot sn fi     (fj+1) (fk+1) (Vec3 fu     (fv-1) (fw-1))
+         ,knot sn (fi+1) (fj+1) (fk+1) (Vec3 (fu-1) (fv-1) (fw-1))]
+{-# SPECIALIZE noise :: SolidNoise Double -> Vec3 Double -> Double #-}
+{-# SPECIALIZE noise :: SolidNoise Float  -> Vec3 Float  -> Float #-}

src/Graphics/Rendering/Haray/Texture.hs

@@ -1,7 +1,9 @@
+{-# LANGUAGE BangPatterns #-}
 module Graphics.Rendering.Haray.Texture where
 
 import Numeric.LinearAlgebra.Vector
 import Graphics.Rendering.Haray.RGB
+import Graphics.Rendering.Haray.SolidNoise
 
 type Texture a = Vec2 a -> Vec3 a -> RGB a
 
@@ -17,3 +19,25 @@ mkStripeTexture = \_ (Vec3 x _ _) ->
   if sin x > 0
     then Vec3 0 0 0
     else Vec3 1 1 1
+
+data NoiseData a = NoiseData
+  { ndScale      :: a
+  , ndColor0     :: RGB a
+  , ndColor1     :: RGB a
+  , ndSolidNoise :: SolidNoise a
+  } deriving (Read, Show, Eq, Ord)
+
+mkNoiseTexture :: (RealFrac a, Floating a) => NoiseData a -> Texture a
+mkNoiseTexture (NoiseData scale c0 c1 sn) =
+  \_ p -> let !t = (1 + (noise sn (scale *> p))) / 2
+          in (t*>c0) <+> ((1 - t)*>c1)
+
+mkBWNoiseTexture :: (RealFrac a, Floating a) => IO (Texture a)
+mkBWNoiseTexture = do
+  sn <- mkSolidNoise
+  return (mkNoiseTexture
+           (NoiseData
+             { ndScale      = 0.05
+             , ndColor0     = Vec3 1.0 1.0 1.0
+             , ndColor1     = Vec3 0.0 0.0 0.0
+             , ndSolidNoise = sn }))