diff --git a/examples/common/Common/Shader.hs b/examples/common/Common/Shader.hs index 9104fa3..d35931d 100644 --- a/examples/common/Common/Shader.hs +++ b/examples/common/Common/Shader.hs @@ -133,6 +133,14 @@ color2 t (Vec3 1 1 1) (Vec3 0 0.33 0.67) +color3 :: Code Float -> Code (V 3 Float) +color3 t + = palette t + (Vec3 0.5 0.5 0.5) + (Vec3 0.5 0.5 0.5) + (Vec3 1 1 0.5) + (Vec3 0.8 0.9 0.3) + -------------------------------------------------------------------------------- -- * Utils -------------------------------------------------------------------------------- diff --git a/examples/domain-warping/Main.hs b/examples/domain-warping/Main.hs index 2b65194..352c40b 100644 --- a/examples/domain-warping/Main.hs +++ b/examples/domain-warping/Main.hs @@ -28,12 +28,16 @@ import Ghengin.Core.Render.Pipeline import Ghengin.Core.Render.Property import Ghengin.Core.Render.Queue import Ghengin.Vulkan.Renderer.Sampler -import Ghengin.Core.Shader (StructVec2(..), StructVec3(..), StructMat4(..)) +import Ghengin.Core.Shader (StructVec2(..), StructVec3(..), StructMat4(..), StructFloat(..)) import Vulkan.Core10.FundamentalTypes (Extent2D(..)) import qualified Data.Monoid.Linear as LMon import qualified FIR +import FIR.Generics import qualified Math.Linear as FIR import qualified Prelude +import qualified Generics.SOP as SOP +import qualified GHC.Generics as GHC +import Data.Time.Clock.POSIX import Shaders @@ -44,6 +48,10 @@ newtype MousePos = MousePos Vec2 deriving Storable deriving FIR.Syntactic via (StructVec2 "mousePos") +newtype Time = Time Float + deriving Storable + deriving FIR.Syntactic via (StructFloat "val") + viewportVertices :: [ Vertex '[Vec3] ] viewportVertices = [ Sin ( vec3 (-1) (-1) 0 ) @@ -59,17 +67,20 @@ viewportIndices ] -- | we should be getting the window size dynamically (in ghengin utils we can even pass it automatically) --- pattern WINDOW_SIZE = (2560, 1600) +pattern WINDOW_SIZE = (2560, 1600) -- pattern WINDOW_SIZE = (1920, 1200) -pattern WINDOW_SIZE = (640, 480) +-- pattern WINDOW_SIZE = (640, 480) + +type PipelineProps = [MousePos, Time] -makeMainPipeline :: Renderer (RenderPipeline _ '[MousePos]) +makeMainPipeline :: Renderer (RenderPipeline _ PipelineProps) makeMainPipeline = makeRenderPipeline (shaderPipeline WINDOW_SIZE) ( DynamicBinding (Ur (MousePos $ vec2 0 0)) + :## DynamicBinding (Ur (Time 0)) :## GHNil ) -gameLoop :: forall (_s :: FIR.PipelineInfo). Vec2 -> PipelineKey _s '[MousePos] -> RenderQueue () ⊸ Core (RenderQueue ()) +gameLoop :: forall (_s :: FIR.PipelineInfo). Vec2 -> PipelineKey _s PipelineProps -> RenderQueue () ⊸ Core (RenderQueue ()) gameLoop (WithVec2 previousPosX previousPosY) pkey rq = Linear.do should_close <- (shouldCloseWindow ↑) if should_close then return rq else Linear.do @@ -80,9 +91,13 @@ gameLoop (WithVec2 previousPosX previousPosY) pkey rq = Linear.do let pos = vec2 (0.5 * (previousPosX + newPosX)) (0.5 * (previousPosY + newPosY)) - rq' <- (editPipeline pkey rq (propertyAt @0 (\(Ur _) -> pure $ Ur $ MousePos pos)) ↑) + rq' <- (editPipeline pkey rq (propertyAt @1 (\(Ur (Time time)) -> pure $ Ur $ Time ((time+0.1))) <=< propertyAt @0 (\(Ur _) -> pure $ Ur $ MousePos pos)) ↑) + Ur prev <- liftSystemIOU getCurrentTime rq'' <- render rq' + Ur post <- liftSystemIOU getCurrentTime + liftSystemIO $ + print ("Frame time " ++ show (diffUTCTime post prev)) gameLoop (vec2 newPosX newPosY) pkey rq'' diff --git a/examples/domain-warping/Shaders.hs b/examples/domain-warping/Shaders.hs index fa7589e..7a5229b 100644 --- a/examples/domain-warping/Shaders.hs +++ b/examples/domain-warping/Shaders.hs @@ -71,35 +71,45 @@ vertex = shader do type FragmentDefs = '[ "ubo" ':-> Uniform '[ DescriptorSet 0, Binding 0 ] ( Struct '[ "mousePos" ':-> V 2 Float ] ) + , "time" ':-> Uniform '[ DescriptorSet 0, Binding 1 ] (Struct '[ "val" ':-> Float ]) ] pattern2, pattern2', pattern2'' :: Code (V 2 Float) -> Program _s _s (Code Float) pattern2 p = do - return $ fbm p + fbm p pattern2' p = do - q <- let' $ fbm p - return $ fbm (p ^+^ Vec2 q q) + q <- fbm p + fbm (p ^+^ Vec2 q q) pattern2'' p = do - q <- let' $ fbm p - r <- let' $ fbm (p ^+^ Vec2 q q) - return $ fbm (p ^+^ Vec2 r r) - -fbm = fbm2 16 (1/2) + q <- fbm p + r <- fbm (p ^+^ Vec2 q q) + fbm (p ^+^ Vec2 r r) +pattern2''' p = do + q <- fbm p + r <- fbm (p ^+^ Vec2 q q) + n <- fbm (p^+^Vec2 r r) + u <- fbm (p ^+^ Vec2 q q ^+^ Vec2 n n) + fbm (p^+^Vec2 q q ^+^ Vec2 r r ^+^ Vec2 u u) + +fbm :: Code (V 2 Float) -> Program _s _s (Code Float) +fbm p = let' $ fbm2 4 (1/2) (p^+^Vec2 100 100) +{-# NOINLINE fbm #-} fragment :: (Float, Float) -> G.FragmentShaderModule FragmentDefs _ fragment (width,height) = shader do ~( Vec4 x y _ _ ) <- #gl_FragCoord ~(Vec2 mx my) <- use @(Name "ubo" :.: Name "mousePos") + t <- use @(Name "time" :.: Name "val") let uv = Vec2 (x-Lit width) (y-Lit height) ^/ Lit height - mp = Vec2 (mx-Lit width) (my-Lit height) ^/ Lit height + mp = (25 *^ Vec2 (mx-Lit width) (my-Lit height)) ^/ Lit height - p <- pattern2'' (uv ^+^ mp) + p <- pattern2''' (uv ^+^ mp ^+^ Vec2 t t) - let Vec3 r g b = color (p*0.5 + 0.5) + let Vec3 r g b = color3 p - #out_colour .= Vec4 r g b 1 + #out_colour .= Vec4 p p p 1 ------------------------------------------------ -- pipeline diff --git a/examples/ghengin-games.cabal b/examples/ghengin-games.cabal index 483c451..2b7b556 100644 --- a/examples/ghengin-games.cabal +++ b/examples/ghengin-games.cabal @@ -26,6 +26,7 @@ flag dev -- Enable with -f+dev common common-flags + build-depends: generics-sop if flag(dev) ghc-options: -Wall -O0 @@ -40,12 +41,11 @@ common common-flags cpp-options: -DDEBUG -DDEBUG_TRACE -DTHINGS_ARE_GOING_THAT_BAD + -- ghc-options: -g2 -rtsopts -debug else ghc-options: -Wall -O2 cc-options: -O2 - ghc-options: -dcmm-lint -dstg-lint -dasm-lint -g2 -rtsopts -debug -Wno-partial-type-signatures - cpp-options: -DDEBUG ghc-options: -Wno-partial-type-signatures default-extensions: UnicodeSyntax, diff --git a/ghengin-core-indep/ghengin-core-indep/Ghengin/Core/Log.hs b/ghengin-core-indep/ghengin-core-indep/Ghengin/Core/Log.hs index 1099a69..a8ef660 100644 --- a/ghengin-core-indep/ghengin-core-indep/Ghengin/Core/Log.hs +++ b/ghengin-core-indep/ghengin-core-indep/Ghengin/Core/Log.hs @@ -78,7 +78,7 @@ enterD msg ma = G.do () <- log "Done." pure a #else -enterD _ = pure () +enterD _ x = x #endif -- | Log if trace level (@-DDEBUG_TRACE@) is set diff --git a/ghengin-core-indep/ghengin-core-indep/Ghengin/Core/Shader.hs b/ghengin-core-indep/ghengin-core-indep/Ghengin/Core/Shader.hs index d1a14fa..b38d5a1 100644 --- a/ghengin-core-indep/ghengin-core-indep/Ghengin/Core/Shader.hs +++ b/ghengin-core-indep/ghengin-core-indep/Ghengin/Core/Shader.hs @@ -20,10 +20,11 @@ import qualified FIR.Prim.Image as FIR import qualified SPIRV.Image as SPIRV import qualified SPIRV.ScalarTy -import Ghengin.Core.Prelude (GHList(..)) +import Ghengin.Core.Prelude (GHList(..), Float, undefined) import Math.Linear import qualified FIR +import qualified FIR.AST as FIR import qualified Data.Type.Map as M type VertexShaderModule defs @@ -56,6 +57,9 @@ type FragmentShaderModule defs -- -- @ +type StructFloat :: Symbol -> Type +newtype StructFloat name = StructFloat Float + type StructVec2 :: Symbol -> Type newtype StructVec2 name = StructVec2 Vec2 @@ -66,6 +70,7 @@ type StructMat4 :: Symbol -> Type newtype StructMat4 name = StructMat4 Mat4 -- Temporary? See ticket in fir +-- NO! Plain wrong, we need to completely move away from Syntactic for our use case instance FIR.Syntactic FIR.Float where type Internal FIR.Float = FIR.Val FIR.Float toAST = FIR.Lit @@ -145,3 +150,11 @@ instance KnownSymbol name => FIR.Syntactic (StructMat4 name) where m03 m13 m23 m33 ) +instance KnownSymbol name => FIR.Syntactic (StructFloat name) where + type Internal (StructFloat name) = FIR.Val (FIR.Struct '[ name 'FIR.:-> FIR.Float ]) + -- we don't call these methods, they are needed by FIR only; our + -- serialization is currently done by Storable (though it should really be + -- through gl-block) + toAST (StructFloat f) = FIR.Struct (FIR.Lit f FIR.:& FIR.End) + fromAST = undefined -- bad!, we don't want syntactic really, this cannot be implemented correctly + diff --git a/ghengin-vulkan/ghengin-vulkan/Ghengin/Vulkan/Renderer.hs b/ghengin-vulkan/ghengin-vulkan/Ghengin/Vulkan/Renderer.hs index d1a04b6..bc618ee 100644 --- a/ghengin-vulkan/ghengin-vulkan/Ghengin/Vulkan/Renderer.hs +++ b/ghengin-vulkan/ghengin-vulkan/Ghengin/Vulkan/Renderer.hs @@ -115,7 +115,7 @@ runRenderer dimensions r = Linear.do -- Terminate ------------ - liftSystemIO $ logger._log "[Start] Clean up\n" + liftSystemIO $ logger._log "[Start] Vulkan clean up\n" (vunit, device) <- runStateT (Data.Linear.mapM (\f -> StateT (fmap ((),) . destroyVulkanFrameData f)) frames') device pure $ consumeUnits vunit @@ -130,7 +130,7 @@ runRenderer dimensions r = Linear.do terminateGLFW glfwtoken - liftSystemIO $ logger._log "[Done] Clean up\n" + liftSystemIO $ logger._log "[Done] Vulkan clean up\n" cleanupLogger