From 117bb8fcf24d3b8f8b2686d12d77dca3cebed558 Mon Sep 17 00:00:00 2001 From: Jason Dagit Date: Mon, 22 Apr 2013 23:08:41 -0700 Subject: [PATCH] Add basic support for perlin noise textures --- haray.cabal | 1 + scenes/example7 | 21 ++++ src/Graphics/Rendering/Haray/Render.hs | 2 +- src/Graphics/Rendering/Haray/Scene.hs | 73 +++++++----- src/Graphics/Rendering/Haray/SolidNoise.hs | 124 ++++++++++++++++++++- src/Graphics/Rendering/Haray/Texture.hs | 24 ++++ 6 files changed, 212 insertions(+), 33 deletions(-) create mode 100644 scenes/example7 diff --git a/haray.cabal b/haray.cabal index e541308..f6fafcc 100644 --- a/haray.cabal +++ b/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 diff --git a/scenes/example7 b/scenes/example7 new file mode 100644 index 0000000..76b8535 --- /dev/null +++ b/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) }) +] diff --git a/src/Graphics/Rendering/Haray/Render.hs b/src/Graphics/Rendering/Haray/Render.hs index 7900fd5..5790ab0 100644 --- a/src/Graphics/Rendering/Haray/Render.hs +++ b/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 diff --git a/src/Graphics/Rendering/Haray/Scene.hs b/src/Graphics/Rendering/Haray/Scene.hs index 70ad30a..9fe15ed 100644 --- a/src/Graphics/Rendering/Haray/Scene.hs +++ b/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,12 +49,14 @@ 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 @@ -59,11 +64,13 @@ data Sphere a = Sphere , 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 @@ -71,20 +78,28 @@ data Plane a = Plane , 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 diff --git a/src/Graphics/Rendering/Haray/SolidNoise.hs b/src/Graphics/Rendering/Haray/SolidNoise.hs index 623cc2a..a485d9f 100644 --- a/src/Graphics/Rendering/Haray/SolidNoise.hs +++ b/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 #-} diff --git a/src/Graphics/Rendering/Haray/Texture.hs b/src/Graphics/Rendering/Haray/Texture.hs index 04ecac8..7d10f99 100644 --- a/src/Graphics/Rendering/Haray/Texture.hs +++ b/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 }))