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

- Mesh welding
- Better texture support and CompatiblePixel
- Planet demo now uses a texture generated at runtime

Fixes #27

Author: alt-romes

examples/ghengin-games.cabal

@@ -141,7 +141,7 @@ executable planets-core
     main-is:        Main.hs
     other-modules:  Planet, Planet.Noise, Planet.UI, Shaders
     hs-source-dirs: planets-core
-    build-depends:  ghengin:dear-imgui
+    build-depends:  ghengin:dear-imgui, JuicyPixels
 
 -- Load and render teapot.obj with blinn-phong
 executable teapot-obj

examples/oscilloscope/Main.hs

@@ -70,7 +70,7 @@ main = do
 
     rp1 <- clearImages rp1
 
-    pipeline      <- (makeRenderPipelineWith GPS{cullMode=CullBack, blendMode=BlendAdd} rp1 shaderPipelineSimple (DynamicBinding (Ur (InStruct 0)) :## GHNil) ↑)
+    pipeline      <- (makeRenderPipelineWith defaultGraphicsPipelineSettings{cullMode=CullBack, blendMode=BlendAdd} rp1 shaderPipelineSimple (DynamicBinding (Ur (InStruct 0)) :## GHNil) ↑)
     (rq, Ur pkey) <- pure (insertPipeline pipeline LMon.mempty)
 
     rq <- gameLoop pkey rp2 rq

examples/planets-core/Main.hs

@@ -43,6 +43,7 @@ import Ghengin.Core.Render.Pipeline
 import Ghengin.Core.Render.Property
 import Ghengin.Vulkan.Renderer.Sampler
 import Ghengin.Core.Render.Queue
+import Ghengin.Core.Input
 import Ghengin.Core.Shader (StructVec3(..), StructMat4(..))
 import Vulkan.Core10.FundamentalTypes (Extent2D(..))
 import qualified Data.Monoid.Linear as LMon
@@ -53,6 +54,7 @@ import qualified Data.Linear.Alias as Alias
 
 import Ghengin.Camera
 import Ghengin.Core.Type.Compatible
+import Ghengin.Core.Type.Compatible.Pixel
 import qualified Ghengin.DearImGui.Vulkan as ImGui
 import qualified Ghengin.DearImGui.UI as ImGui
 
@@ -63,26 +65,50 @@ import Planet.Noise
 import Planet.UI
 
 gameLoop :: Compatible '[Vec3, Vec3] '[Transform] '[MinMax, Texture2D (RGBA8 UNorm)] '[Camera "view_matrix" "proj_matrix"] π
-         => UTCTime
+         => CharStream
          -> _
-         -- -> MeshKey π _ _ _ _
          -> MeshKey π '[Camera "view_matrix" "proj_matrix"] '[MinMax, Texture2D (RGBA8 UNorm)] '[Vec3, Vec3] '[Transform]
-         -> _
-         -> Alias RenderPass ⊸ RenderQueue () ⊸ Core (RenderQueue ())
-gameLoop currentTime planet mkey rot rp rq = Linear.do
+         -> Alias RenderPass
+          ⊸ RenderQueue ()
+          ⊸ Core (RenderQueue ())
+gameLoop charStream planet mkey rp rq = Linear.do
  logT "New frame" 
  should_close <- (shouldCloseWindow ↑)
  if should_close then (Alias.forget rp ↑) >> return rq else Linear.do
   (pollWindowEvents ↑)
 
-  Ur (newPlanet, changed) <- preparePlanetUI planet
-
-  Ur newTime <- liftSystemIOU getCurrentTime
-
-  -- Fix Your Timestep: A Very Hard Thing To Get Right. For now, the simplest approach:
-  -- let frameTime = diffUTCTime newTime currentTime
-  --     deltaTime = Prelude.min MAX_FRAME_TIME $ realToFrac frameTime
+  -- Update planet mesh according to UI
+  Ur (newPlanet, changedShape, changedColor) <- preparePlanetUI planet -- must happen before the first render
+  rq <-
+    if changedShape then
+      (editAtMeshesKey mkey rq (\pipeline mat [(msh, x)] -> Linear.do
+            ( (pmesh, pipeline),
+              Ur minmax ) <- newPlanetMesh pipeline newPlanet 
+            mat <- propertyAt @0 @MinMax (\(Ur _) -> pure (Ur minmax)) mat
+            freeMesh msh
+            return (pipeline, (mat, [(pmesh, x)]))
+          ) ↑)
+    else if changedColor then
+      -- TODO: EditAtMaterialKey (materialKeyOfMeshKey)
+      (editAtMeshesKey mkey rq (\pipeline mat [(msh, x)] -> Linear.do
+            mat <- propertyAt @1 @_ (\tex -> Alias.forget tex >> planetTexture (planetColor newPlanet)) mat
+            return (pipeline, (mat, [(msh, x)]))
+          ) ↑)
+    else
+      pure rq
 
+  Ur mb_in <- readCharInput charStream
+  rq <- case mb_in of
+    Just ch -> Linear.do
+      let doRotate 'd' = rotateY 0.01
+          doRotate 'a' = rotateY (-0.01)
+          doRotate 'w' = rotateX (0.01)
+          doRotate 's' = rotateX (-0.01)
+          doRotate _   = mempty
+      (editMeshes mkey rq (traverse' $ propertyAt @0 (\(Ur tr) -> pure $ Ur $ doRotate ch <> tr)) ↑)
+    Nothing -> pure rq
+
+  -- Render!
   (rp, rq) <- renderWith $ Linear.do
 
     (rp1, rp2) <- lift (Alias.share rp)
@@ -97,32 +123,20 @@ gameLoop currentTime planet mkey rot rp rq = Linear.do
 
       return (rp2, rq)
 
-
-  rq <-
-    if changed then
-      (editAtMeshesKey mkey rq (\pipeline mat [(msh, x)] -> Linear.do
-            ( (pmesh, pipeline),
-              Ur minmax ) <- newPlanetMesh pipeline newPlanet 
-            mat' <- propertyAt @0 @MinMax (\(Ur _) -> pure (Ur minmax)) mat
-            freeMesh msh
-            return (pipeline, (mat', [(pmesh, x)]))
-          ) ↑)
-    else
-      pure rq
-
-  -- rq <- (editMeshes mkey rq (traverse' $ propertyAt @0 (\(Ur tr) -> pure $ Ur $
-  --   rotateY rot <> rotateX (-rot))) ↑)
-
   -- Loop!
-  gameLoop newTime newPlanet mkey (rot+(0.01::Float)) rp rq
+  gameLoop charStream newPlanet mkey rp rq
+
+dimensions :: Num a => (a, a)
+dimensions = (1920, 1080)
 
 main :: Prelude.IO ()
 main = do
- currTime <- getCurrentTime
  withLinearIO $
-  runCore (1280, 720) Linear.do
-    sampler <- ( createSampler FILTER_NEAREST SAMPLER_ADDRESS_MODE_CLAMP_TO_EDGE ↑)
-    tex     <- ( texture "examples/planets-core/assets/planet_gradient.png" sampler ↑)
+  runCore dimensions Linear.do
+    Ur charStream <- registerCharStream
+
+    -- 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 ↑)
 
@@ -133,50 +147,66 @@ main = do
     -- todo: minmax should be per-mesh
     ( (pmesh, pipeline),
       Ur minmax )    <- (newPlanetMesh pipeline defaultPlanet ↑)
-    (pmat, pipeline) <- (newPlanetMaterial minmax tex pipeline ↑)
+    (pmat, pipeline) <- (newPlanetMaterial minmax pipeline defaultPlanet ↑)
 
     -- 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 pmat rq)
     (rq, Ur mshkey)  <- pure (insertMesh mkey pmesh rq)
 
-    rq <- gameLoop currTime defaultPlanet mshkey 0 rp2 rq
+    rq <- gameLoop charStream defaultPlanet mshkey rp2 rq
 
     (freeRenderQueue rq ↑)
     (ImGui.destroyImCtx imctx ↑)
 
     return (Ur ())
 
 camera :: Camera "view_matrix" "proj_matrix"
-camera = cameraLookAt (vec3 0 0 (-5){- move camera "back"-}) (vec3 0 0 0) (1280, 720)
+camera = cameraLookAt (vec3 0 0 (-5){- move camera "back"-}) (vec3 0 0 0) dimensions
 
 defaultPlanet :: Planet
 defaultPlanet = Planet
-  { resolution = 10
+  { resolution = 100
   , planetShape = PlanetShape
-      { planetRadius = 2.50
-      , planetNoise  = AddNoiseMasked
-          [ StrengthenNoise 0.12 $ MinValueNoise
-            { minNoiseVal = 1.1
+      { planetRadius = 3
+      , planetNoise  = ImGui.Collapsible $ AddNoiseMasked
+          [ StrengthenNoise 0.110 $ MinValueNoise
+            { minNoiseVal = 0.930
             , baseNoise   = LayersCoherentNoise
-              { centre        = ImGui.Color $ vec3 0 0 0
-              , baseRoughness = 0.71
-              , roughness     = 1.83
-              , numLayers     = 5
-              , persistence   = 0.54
+              -- { centre        = ImGui.WithTooltip $ ImGui.Color $ vec3 0 0 0
+              { centre        = ImGui.WithTooltip $ ImGui.Color $ vec3 255 147 0
+              , baseRoughness = 1.5
+              , roughness     = 2.5
+              , numLayers     = 20
+              , persistence   = 0.4
               }
             }
-          , StrengthenNoise 2.5 $ MinValueNoise
-            { minNoiseVal = 0
+          , StrengthenNoise 5 $ MinValueNoise
+            { minNoiseVal = 0.120
             , baseNoise   = RidgedNoise
-              { seed          = 123
-              , octaves       = 5
-              , scale         = 1
+              { seed          = 25
+              , octaves       = 10
+              , scale         = 0.59
               , frequency     = 2
-              , lacunarity    = 3
+              , lacunarity    = 5.2
               }
             }
           ]
       }
+  , planetColor = PlanetColor
+    { planetColors =
+      Prelude.map
+        (\(bnd, WithVec3 rn gn bn) -> (ImGui.InRange bnd, ImGui.Color (vec3 (rn/255) (gn/255) (bn/255))))
+        [ (1, vec3 0 83 255)
+        , (2, vec3 255 218 0)
+        , (5, vec3 255 120 0)
+        , (10, vec3 60 255 0)
+        , (20, vec3 27 183 0)
+        , (30, vec3 10 163 0)
+        , (40, vec3 158 37 0)
+        , (85, vec3 108 13 0)
+        , (100, vec3 231 231 231)
+        ]
+    }
   }
 

examples/planets-core/Planet.hs

@@ -34,17 +34,23 @@ import qualified Math.Linear as FIR
 import Ghengin.DearImGui.UI
 
 import Ghengin.Core.Shader.Data
+import Ghengin.Vulkan.Renderer.Sampler
+import Ghengin.Vulkan.Renderer.Texture
 
 import Generics.SOP
+-- JuicyPixels
+import Codec.Picture
+import Codec.Picture.Types (promotePixel)
 
 import Planet.Noise
 
 --------------------------------------------------------------------------------
 -- * Planet
 --------------------------------------------------------------------------------
 
-data Planet = Planet { resolution  :: !(InRange 1 300 Int)
+data Planet = Planet { resolution  :: !(InRange 2 512 Int)
                      , planetShape :: !PlanetShape
+                     , planetColor :: !PlanetColor
                      }
                      deriving Eq
                      deriving GHC.Generic
@@ -71,7 +77,7 @@ type PlanetMesh = Mesh '[Vec3, Vec3] '[Transform]
 
 data PlanetShape = PlanetShape
   { planetRadius :: !(InRange 0 100 Float)
-  , planetNoise  :: !Noise
+  , planetNoise  :: !(Collapsible "Noise section" Noise)
   }
   deriving Eq
   deriving GHC.Generic
@@ -85,7 +91,7 @@ data PlanetShape = PlanetShape
 -- Returns the updated point and the elevation of that point
 pointOnPlanet :: PlanetShape -> Vec3 -> (Vec3, Float)
 pointOnPlanet PlanetShape{..} pointOnUnitSphere =
-  let elevation = evalNoise planetNoise pointOnUnitSphere
+  let elevation = evalNoise (unCollapsible planetNoise) pointOnUnitSphere
       finalElevation = inRangeVal planetRadius * (1+elevation)
    in (pointOnUnitSphere ^* finalElevation, finalElevation)
 
@@ -98,16 +104,17 @@ newPlanetMesh :: _ -- more constraints
               -> Renderer ((PlanetMesh, RenderPipeline π bs), Ur MinMax)
 newPlanetMesh rp Planet{..} = Linear.do
 
-  let UnitSphere us is = newUnitSphereFace False (inRangeVal resolution)
+  let UnitSphere us is0 = newUnitSphere (inRangeVal resolution)
 
       (planetPs, elevations)
                = V.unzip $ V.map (\(p :&: _) -> pointOnPlanet planetShape p) (V.convert us)
       planetNs = computeNormals (SV.map fromIntegral is) planetPs
       planetVs = V.zipWith (:&:) (planetPs) planetNs
+      is       = weldVertices planetPs (SV.map fromIntegral is0)
 
       minmax = MinMax (P.minimum elevations) (P.maximum elevations)
 
-   in (, Ur minmax) <$> createMeshWithIxsSV rp (DynamicBinding (Ur mempty) :## GHNil) (V.convert planetVs) is
+   in (, Ur minmax) <$> createMeshWithIxsSV rp (DynamicBinding (Ur mempty) :## GHNil) (V.convert planetVs) (SV.map fromIntegral is)
 
 --------------------------------------------------------------------------------
 -- * Material
@@ -116,13 +123,38 @@ newPlanetMesh rp Planet{..} = Linear.do
 type PlanetMaterialAttrs = '[MinMax, Texture2D (RGBA8 UNorm)]
 type PlanetMaterial = Material PlanetMaterialAttrs
 
+data PlanetColor = PlanetColor
+  { planetColors :: [(InRange 0 100 Float, Color)]
+  -- ^ A list of a percentage value and the color to use up to that percentage
+  }
+  deriving Eq
+  deriving GHC.Generic
+  deriving anyclass Generic
+  deriving anyclass HasDatatypeInfo
+  deriving anyclass Widget
+  deriving anyclass Default
+
 newPlanetMaterial :: forall π p
                    . CompatibleMaterial '[MinMax, Texture2D (RGBA8 UNorm)] π
                   => MinMax
-                  -> Alias (Texture2D (RGBA8 UNorm))
-                   ⊸ RenderPipeline π p
-                   ⊸ Renderer (PlanetMaterial, RenderPipeline π p)
-newPlanetMaterial mm t pl = material @_ @π (StaticBinding (Ur mm) :## Texture2DBinding t :## GHNil) pl
+                  -> RenderPipeline π p
+                   ⊸ Planet
+                  -> Renderer (PlanetMaterial, RenderPipeline π p)
+newPlanetMaterial mm pl planet = Linear.do
+  tex <- planetTexture (planetColor planet)
+  material @_ @π (StaticBinding (Ur mm) :## Texture2DBinding tex :## GHNil) pl
+
+-- | Make a Texture from the planet color
+planetTexture :: PlanetColor -> Renderer (Alias (Texture2D (RGBA8 UNorm)))
+planetTexture PlanetColor{planetColors} = Linear.do
+  sampler <- createSampler FILTER_NEAREST SAMPLER_ADDRESS_MODE_CLAMP_TO_EDGE
+  -- Generate a gradient image. Single pixel height, one pixel of a color per percent.
+  let gradientImg = generateImage pixelPaint 100{-width=100%-} 100{-height=1 pixel-}
+      pixelPaint x _ = case find (\(InRange limit, _) -> x < round limit) planetColors of
+        Nothing -> PixelRGBA8 255 255 255 255
+        Just (_, Color (WithVec3 r g b)) -> PixelRGBA8 (round (r*255)) (round (g*255)) (round (b*255)) 255
+  liftSystemIO $ savePngImage "my_generated_gradient_texture.png" (ImageRGBA8 gradientImg)
+  newTexture gradientImg sampler
 
 --------------------------------------------------------------------------------
 

examples/planets-core/Planet/Noise.hs

@@ -25,7 +25,7 @@ data Noise
   --
   -- You can have simple coherent noise by having numLayers = 1
   = LayersCoherentNoise
-      { centre        :: !Color
+      { centre        :: !(WithTooltip "A seed" Color)
         -- Offset noise point
       , baseRoughness :: !Float
         -- ^ Roughness for the first layer
@@ -39,7 +39,7 @@ data Noise
   -- | Ridged multi-fractal noise
   | RidgedNoise
       { seed          :: !Int
-      , octaves       :: !Int
+      , octaves       :: !(InRange 0 64 Int)
       , scale         :: !Double
       , frequency     :: !Double
       , lacunarity    :: !Double
@@ -82,15 +82,15 @@ evalNoise LayersCoherentNoise{..} p
     frequencies = baseRoughness : map (*roughness) frequencies
     amplitudes  = 1 : map (*persistence) amplitudes
     layerNoise frequency amplitude =
-      let v = coherentNoise seed (vec3Point (p ^* frequency ^+^ colorVec centre))
+      let v = coherentNoise seed (vec3Point (p ^* frequency ^+^ (colorVec (unTooltip centre))))
        in (v + 1) * 0.5 * amplitude {-from [-1 to 1] to [0 to 1], then * amplitude-}
     noiseVal =
       sum $ take (inRangeVal 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)
+  Ridged.noiseValue (ridged seed (inRangeVal octaves) scale frequency lacunarity) (vec3Point p)
 evalNoise AddNoiseMasked{..}  p =
   case NonEmpty.nonEmpty noiseLayers of
     Nothing -> 0