Add time

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
 --------------------------------------------------------------------------------

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''
 

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

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,

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

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
+

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