Merge pull request #20 from alt-romes/wip/romes/planets

Finally use textures again for planets demo

Author: alt-romes

examples/full-pipeline/Main.hs

@@ -90,7 +90,7 @@ main =
   runCore (640, 480) Linear.do
     (rp1, rp2) <- (Alias.share =<< createSimpleRenderPass ↑)
 
-    pipeline :: RenderPipeline π ps <- (makeRenderPipeline rp1 shaderPipeline (StaticBinding (Ur (defaultCamera @"view" @"proj")) :## GHNil) ↑)
+    pipeline :: RenderPipeline π ps <- (makeRenderPipeline rp1 shaderPipeline (StaticBinding (Ur (cameraLookAt @"view" @"proj" (vec3 0 0 0) (vec3 0 0 1) (640, 480))) :## GHNil) ↑)
     (emptyMat, pipeline) <- (material GHNil pipeline ↑)
     (mesh :: IcosahedronMesh, pipeline) <- (createMeshWithIxs pipeline GHNil icosahedronVerts icosahedronIndices ↑)
 

examples/ghengin-games.cabal

@@ -139,7 +139,7 @@ common common-flags
 executable planets-core
     import:         common-flags
     main-is:        Main.hs
-    other-modules:  Planet, Shaders
+    other-modules:  Planet, Planet.Noise, Shaders
     hs-source-dirs: planets-core
 
 -- library
@@ -229,11 +229,11 @@ executable function-plotting
     hs-source-dirs: function-plotting/
 
 -- An XY oscilloscope; TODO: NOT FINISHED
-executable oscilloscope
-    import:        common-flags
-    main-is:       Main.hs
-    other-modules: Shaders
-    hs-source-dirs: oscilloscope/
+-- executable oscilloscope
+--     import:        common-flags
+--     main-is:       Main.hs
+--     other-modules: Shaders
+--     hs-source-dirs: oscilloscope/
 
 -- The Lorenz Attractor
 executable lorenz-attractor

examples/planets-core/Main.hs

@@ -56,6 +56,7 @@ import Ghengin.Camera
 -- planets!
 import Shaders -- planet shaders
 import Planet
+import Planet.Noise
 
 gameLoop :: _
          => UTCTime -> _ -> _ -> Alias RenderPass ⊸ RenderQueue () ⊸ Core (RenderQueue ())
@@ -85,19 +86,19 @@ main = do
  currTime <- getCurrentTime
  withLinearIO $
   runCore (1280, 720) Linear.do
-    -- sampler <- ( createSampler FILTER_NEAREST SAMPLER_ADDRESS_MODE_CLAMP_TO_EDGE ↑)
-    -- tex     <- ( texture "assets/planet_gradient.png" sampler ↑)
+    sampler <- ( createSampler FILTER_NEAREST SAMPLER_ADDRESS_MODE_CLAMP_TO_EDGE ↑)
+    tex     <- ( texture "examples/planets-core/assets/planet_gradient.png" sampler ↑)
 
     (rp1, rp2) <- (Alias.share =<< createSimpleRenderPass ↑)
-    pipeline <- (makeRenderPipeline rp1 shaders (StaticBinding (Ur camera) :## GHNil) ↑)
-    (p1mesh, pipeline) <- newPlanetMesh pipeline defaultPlanet
-    (emptyMat, pipeline) <- (material GHNil pipeline ↑)
-    -- (pmat, pipeline)    <- newPlanetMaterial minmax tex pipeline
+    pipeline   <- (makeRenderPipeline rp1 shaders (StaticBinding (Ur camera) :## GHNil) ↑)
+    ( (pmesh, pipeline),
+      Ur minmax )    <- newPlanetMesh pipeline defaultPlanet
+    (pmat, pipeline) <- newPlanetMaterial minmax tex pipeline
 
     -- remember to provide helper function in ghengin to insert meshes with pipelines and mats, without needing to do this:
     (rq, Ur pkey)       <- pure (insertPipeline pipeline LMon.mempty)
-    (rq, Ur mkey)       <- pure (insertMaterial pkey emptyMat rq)
-    (rq, Ur mshkey)     <- pure (insertMesh mkey p1mesh rq)
+    (rq, Ur mkey)       <- pure (insertMaterial pkey pmat rq)
+    (rq, Ur mshkey)     <- pure (insertMesh mkey pmesh rq)
 
     rq <- gameLoop currTime mshkey 0 rp2 rq
 
@@ -112,8 +113,29 @@ defaultPlanet :: Planet
 defaultPlanet = Planet
   { resolution = 100
   , planetShape = PlanetShape
-      { planetRadius = 1
-      , planetNoise  = CoherentNoise (vec3 0 0 0) 1 1
+      { planetRadius = 2.50
+      , planetNoise  = AddNoiseMasked
+          [ StrengthenNoise 0.12 $ MinValueNoise
+            { minNoiseVal = 1.1
+            , baseNoise   = LayersCoherentNoise
+              { centre        = vec3 0 0 0
+              , baseRoughness = 0.71
+              , roughness     = 1.83
+              , numLayers     = 5
+              , persistence   = 0.54
+              }
+            }
+          , StrengthenNoise 2.5 $ MinValueNoise
+            { minNoiseVal = 0
+            , baseNoise   = RidgedNoise
+              { seed          = 123
+              , octaves       = 5
+              , scale         = 1
+              , frequency     = 2
+              , lacunarity    = 3
+              }
+            }
+          ]
       }
   }
 

examples/planets-core/Planet.hs

@@ -16,8 +16,6 @@ import Ghengin.Core.Type.Compatible
 import Data.List (foldl')
 import Ghengin.Core.Log
 
-import GHC.Float
-import Numeric.Noise hiding (Noise)
 import qualified Data.List.NonEmpty as NE
 import qualified Data.Vector as V
 
@@ -36,6 +34,8 @@ import qualified Math.Linear as FIR
 
 import Ghengin.Core.Shader.Data
 
+import Planet.Noise
+
 --------------------------------------------------------------------------------
 -- * Planet
 --------------------------------------------------------------------------------
@@ -63,69 +63,48 @@ data PlanetShape = PlanetShape
   }
 
 -- | Make the point on a planet for the given point on a unit sphere
-pointOnPlanet :: PlanetShape -> Vec3 -> Vec3
+--
+-- Returns the updated point and the elevation of that point
+pointOnPlanet :: PlanetShape -> Vec3 -> (Vec3, Float)
 pointOnPlanet PlanetShape{..} pointOnUnitSphere =
   let elevation = evalNoise planetNoise pointOnUnitSphere
-   in pointOnUnitSphere ^* planetRadius ^* (1+elevation)
+      finalElevation = planetRadius * (1+elevation)
+   in (pointOnUnitSphere ^* finalElevation, finalElevation)
 
+-- | Construct the planet mesh and return the minimum and maximum elevation points on the planet
 newPlanetMesh :: _ -- more constraints
               => CompatibleVertex '[Vec3, Vec3] π
               => CompatibleMesh '[Transform] π
               => RenderPipeline π bs
                ⊸ Planet
-              -> Core (PlanetMesh, RenderPipeline π bs)
+              -> Core ((PlanetMesh, RenderPipeline π bs), Ur MinMax)
 newPlanetMesh rp Planet{..} = enterD "newPlanetMesh" $ Linear.do
 
   let UnitSphere us is = newUnitSphere resolution
 
-      planetVxs = P.map (\(p :&: n) -> pointOnPlanet planetShape p :&: n) us
-
-      -- (ps', elevations) = P.unzip $ (`map` vs) \(p :& _) ->
-      --   case nss of
-      --     ns NE.:| nss' ->
-      --       let initialElevation = evalNoise ns p
-      --           mask = if enableMask then initialElevation else 1
-      --           noiseElevation = foldl' (\acc ns' -> acc + (evalNoise ns' p)*mask) initialElevation nss'
-      --           elevation = ra * (1 + noiseElevation)
-      --        in (p ^* (elevation), elevation)
-      --
-      -- ns'  = V.toList $ computeNormals (V.fromList (P.map fromIntegral is)) (V.fromList ps')
-      -- vs'' = P.zipWith3 (\a b c -> a :& b :&: c) ps' ns' (map (\(_ :& _ :&: c) -> c) vs)
+      (planetPs, elevations)
+               = P.unzip $ P.map (\(p :&: _) -> pointOnPlanet planetShape p) us
+      planetNs = V.toList $ computeNormals (V.fromList (P.map fromIntegral is)) (V.fromList planetPs)
+      planetVs = P.zipWith (:&:) planetPs planetNs
 
-      -- minmax = MinMax (P.minimum elevations) (P.maximum elevations)
+      minmax = MinMax (P.minimum elevations) (P.maximum elevations)
 
-   in (createMeshWithIxs rp (DynamicBinding (Ur mempty) :## GHNil) planetVxs is ↑)
+   in (, Ur minmax) <$> (createMeshWithIxs rp (DynamicBinding (Ur mempty) :## GHNil) planetVs is ↑)
 
 --------------------------------------------------------------------------------
 -- * Material
 --------------------------------------------------------------------------------
 
+type PlanetMaterial = Material '[MinMax, Texture2D (RGBA8 UNorm)]
+
 newPlanetMaterial :: forall π p
-                   . CompatibleMaterial '[MinMax,Texture2D] π
+                   . CompatibleMaterial '[MinMax, Texture2D (RGBA8 UNorm)] π
                   => MinMax
-                  -> Alias Texture2D
+                  -> Alias (Texture2D (RGBA8 UNorm))
                    ⊸ RenderPipeline π p
-                   ⊸ Core (Material '[MinMax,Texture2D], RenderPipeline π p)
+                   ⊸ Core (PlanetMaterial, RenderPipeline π p)
 newPlanetMaterial mm t pl = ( material @_ @π (StaticBinding (Ur mm) :## Texture2DBinding t :## GHNil) pl ↑)
 
---------------------------------------------------------------------------------
--- * Noise
---------------------------------------------------------------------------------
-
-data Noise = CoherentNoise
-      { centre    :: !Vec3
-      , roughness :: !Float
-      , strength  :: !Float
-      }
-
-evalNoise :: Noise -> Vec3 -> Float
-evalNoise CoherentNoise{..} point = double2Float
-  let seed = 123456
-      WithVec3 px py pz = point ^* roughness ^+^ centre
-      noiseValue  = coherentNoise seed (float2Double px, float2Double py, float2Double pz)
-      noiseScaled = (noiseValue + 1) * 0.5 {-from [-1 to 1] to [0 to 1] -}
-   in noiseScaled * float2Double strength
-
 --------------------------------------------------------------------------------
 
 -- non-compositional instance for "Transform", just for demo

examples/planets-core/Planet/Noise.hs

@@ -0,0 +1,92 @@
+module Planet.Noise where
+
+import Prelude
+
+import Geomancy (VectorSpace(..))
+import Geomancy.Vec3
+
+import GHC.Float
+import Numeric.Noise hiding (Noise)
+import Numeric.Noise.Ridged as Ridged
+import qualified Data.List.NonEmpty as NonEmpty
+
+--------------------------------------------------------------------------------
+-- * Noise
+--------------------------------------------------------------------------------
+
+data Noise
+  -- | Level of detail noise created by repeated application of coherent noise with
+  -- geometrically increasing roughness and decreasing amplitude.
+  --
+  -- You can have simple coherent noise by having numLayers = 1
+  = LayersCoherentNoise
+      { centre        :: !Vec3
+        -- Offset noise point
+      , baseRoughness :: !Float
+        -- ^ Roughness for the first layer
+      , numLayers     :: !Int
+        -- ^ How many layers of detail
+      , persistence   :: !Double
+        -- ^ Apply multiplier to cummulative strength per layer
+      , roughness     :: !Float
+        -- ^ Apply multiplier to cummulative roughness per layer
+      }
+  -- | Ridged multi-fractal noise
+  | RidgedNoise
+      { seed          :: !Int
+      , octaves       :: !Int
+      , scale         :: !Double
+      , frequency     :: !Double
+      , lacunarity    :: !Double
+      }
+  -- | A noise value which evaluates the base noise value and makes sure it is
+  -- at least the given min value
+  | MinValueNoise
+      { minNoiseVal :: !Float
+        -- ^ Value is increased to at least this much
+      , baseNoise   :: !Noise
+        -- ^ The base noise value
+      }
+  | StrengthenNoise
+      { strength  :: !Float
+        -- ^ Multiplies by noise val
+      , baseNoise :: !Noise
+        -- ^ To compute the noise val
+      }
+  -- | Add noise filters using the first layer to mask all following ones
+  | AddNoiseMasked
+      { noiseLayers :: ![Noise]
+      }
+  -- | Add noise filters unconditionally
+  | AddNoiseLayers
+      { noiseLayers :: ![Noise]
+      }
+
+-- | Evaluate given 'Noise' at a 3D point
+evalNoise :: Noise -> Vec3 -> Float
+evalNoise LayersCoherentNoise{..} p
+  = double2Float noiseVal
+  where
+    seed = 123456
+    frequencies = baseRoughness : map (*roughness) frequencies
+    amplitudes  = 1 : map (*persistence) amplitudes
+    layerNoise frequency amplitude =
+      let v = coherentNoise seed (vec3Point (p ^* frequency ^+^ centre))
+       in (v + 1) * 0.5 * amplitude {-from [-1 to 1] to [0 to 1], then * amplitude-}
+    noiseVal =
+      sum $ take numLayers $
+      zipWith layerNoise frequencies amplitudes
+evalNoise StrengthenNoise{..} p = evalNoise baseNoise p * strength
+evalNoise MinValueNoise{..}   p = max 0 (evalNoise baseNoise p - minNoiseVal)
+evalNoise RidgedNoise{..}     p = double2Float $
+  Ridged.noiseValue (ridged seed octaves scale frequency lacunarity) (vec3Point p)
+evalNoise AddNoiseMasked{..}  p =
+  case NonEmpty.nonEmpty noiseLayers of
+    Nothing -> 0
+    Just (firstLayer NonEmpty.:| otherLayers) ->
+      let firstLayerVal = evalNoise firstLayer p
+       in firstLayerVal + sum (map ((*firstLayerVal{-mask-}) . (`evalNoise` p)) otherLayers)
+evalNoise AddNoiseLayers{..}  p = sum (map (`evalNoise` p) noiseLayers)
+
+vec3Point :: Vec3 -> Point
+vec3Point (WithVec3 px py pz) = (float2Double px, float2Double py, float2Double pz)