Re-start ocean waves demo

README.md

@@ -2,6 +2,14 @@ A work in progress game engine.
 
 ## Demos
 
+See the executables from `ghegin-games.cabal` in the `examples/` directory.
+The few work in progress/unpolished executables are:
+* `ocean-waves`
+* `planets-core`
+* `domain-warping`
+* `fir-juliaset`, a port of FIR's juliaset to `ghengin`.
+* `mandlebrot-set`
+
 ### Ocean waves
 
 Based on https://dl.acm.org/doi/abs/10.1145/15922.15894

examples/common/Common.hs

@@ -71,10 +71,10 @@ makeMainPipeline shaderPipeline = makeRenderPipeline (shaderPipeline WINDOW_SIZE
   )
 
 -- | we should be getting the window size dynamically (in ghengin utils we can even pass it automatically)
-pattern WINDOW_SIZE = (3840, 2160)
+-- pattern WINDOW_SIZE = (3840, 2160)
 -- pattern WINDOW_SIZE = (2560, 1600)
 -- pattern WINDOW_SIZE = (1920, 1200)
--- pattern WINDOW_SIZE = (640, 480)
+pattern WINDOW_SIZE = (640, 480)
 
 renderQueueWithViewport :: (Typeable w, Compatible '[Vec3] '[] '[] PipelineProps w, _) => ((Word32, Word32) -> G.ShaderPipeline w) -> Renderer (RenderQueue (), Ur (PipelineKey w PipelineProps))
 renderQueueWithViewport sp = Linear.do

examples/ghengin-games.cabal

@@ -185,3 +185,20 @@ executable domain-warping
         fir, filepath, text-short, vector-sized
 
     hs-source-dirs:   domain-warping
+
+executable ocean-waves
+    import:        common-flags
+    main-is:       Main.hs
+    other-modules: Shaders
+    build-depends:
+        base >=4.19.0.0,
+        ghengin-games,
+        -- Can't depend on this without instancing it because of backpack
+        ghengin-core,
+        ghengin-vulkan,
+        ghengin-core-indep,
+        mtl, vector, hsnoise, containers, random, linear-base,
+        derive-storable, geomancy, vulkan, time, ghengin-geometry,
+        fir, filepath, text-short, vector-sized
+
+    hs-source-dirs: ocean-waves/

examples/ocean-waves/Main.hs

@@ -0,0 +1,84 @@
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE PostfixOperators #-}
+{-# OPTIONS_GHC -Wno-name-shadowing #-}
+module Main where
+
+import GHC.Float
+import Data.Coerce
+import Data.Time
+import Data.Time.Clock.POSIX
+import Foreign.Storable
+import Geomancy.Mat4
+import Geomancy.Transform
+import Geomancy.Vec2
+import Geomancy.Vec3
+import Geomancy.Vec4
+import Geomancy.Vulkan.Projection (perspective)
+import Ghengin.Core
+import Ghengin.Core.Log
+import Ghengin.Core.Mesh
+import Ghengin.Core.Mesh.Vertex
+import Ghengin.Core.Material
+import Ghengin.Core.Prelude as Linear
+import Ghengin.Core.Render
+import Ghengin.Core.Render.Packet
+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(..), 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
+import Common
+
+gameLoop :: forall (_s :: FIR.PipelineInfo). PipelineKey _s PipelineProps -> UTCTime -> RenderQueue () ⊸ Core (RenderQueue ())
+gameLoop pkey lastTime rq = Linear.do
+ should_close <- (shouldCloseWindow ↑)
+ if should_close then return rq else Linear.do
+  (pollWindowEvents ↑)
+
+  Ur ( double2Float -> newPosX
+     , double2Float -> newPosY
+     ) <- (getMousePos ↑)
+  Ur nowTime <- liftSystemIOU getCurrentTime
+  let diffTime = diffUTCTime nowTime lastTime
+  liftSystemIO $ do
+    print ("Frame time " ++ show diffTime)
+
+  rq' <- Core $ lift $
+    editPipeline pkey rq $
+          propertyAt @1 (\(Ur (Time time)) -> pure $ Ur $ Time $ time + (realToFrac diffTime / 2))
+      <=< propertyAt @0 (\(Ur _) -> pure $ Ur $ MousePos $ vec2 newPosX newPosY)
+
+  rq'' <- render rq'
+
+  gameLoop pkey nowTime rq''
+
+main :: Prelude.IO ()
+main = do
+ withLinearIO $
+  runCore WINDOW_SIZE Linear.do
+    (rq, Ur pkey) <- (renderQueueWithViewport shaderPipeline ↑)
+    Ur now <- liftSystemIOU getCurrentTime
+
+    rq <- gameLoop pkey now rq
+
+    (freeRenderQueue rq ↑)
+
+    -- In fact, freeing these again is a type error. Woho!
+    -- (destroyRenderPipeline pipeline ↑)
+
+    return (Ur ())
+

examples/ocean-waves/Shaders.hs

@@ -0,0 +1,106 @@
+{-# OPTIONS_GHC -Wno-missing-local-signatures #-}
+
+{-# LANGUAGE CPP                   #-}
+{-# LANGUAGE BlockArguments        #-}
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE OverloadedLabels      #-}
+{-# LANGUAGE RebindableSyntax      #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE TypeApplications      #-}
+{-# LANGUAGE NamedWildCards        #-}
+{-# LANGUAGE TypeFamilies          #-}
+{-# LANGUAGE TypeOperators         #-}
+{-# LANGUAGE ViewPatterns          #-}
+
+module Shaders where
+
+-- base
+import Data.Foldable
+  ( sequence_ )
+import Data.Maybe
+  ( fromJust )
+import GHC.TypeNats
+  ( KnownNat )
+
+-- filepath
+import System.FilePath
+  ( (</>) )
+
+-- text-short
+import Data.Text.Short
+  ( ShortText )
+
+-- vector-sized
+import qualified Data.Vector.Sized as Vector
+  ( fromList )
+
+-- fir
+import FIR
+import FIR.Syntax.Labels
+import Math.Linear
+
+-- ghengin
+import qualified Ghengin.Core.Shader as G
+
+-- ghengin-games
+import Common.Shader
+
+--------------------------------------------------------------------------------
+-- * Vertex Shader
+--------------------------------------------------------------------------------
+-- The input to our vertex shader are vertices along the XY plane, which we will
+-- displace according to the ocean model. We receive the vertices in `Location 0`
+-- and they are `V 2 Float`s (points in the XY plane).
+
+type VertexDefs =
+  '[ "in_position"  ':-> Input      '[ Location 0 ] (V 3 Float)
+   ]
+
+type VertexInput
+  = '[ Slot 0 0 ':-> V 3 Float ]
+
+vertex :: G.VertexShaderModule VertexDefs _
+vertex = shader do
+    ~(Vec3 x y z) <- get @"in_position"
+    put @"gl_Position" (Vec4 x y z 1)
+
+--------------------------------------------------------------------------------
+-- * Fragment Shader
+--------------------------------------------------------------------------------
+
+type FragmentDefs =
+  '[ "ubo"         ':-> Uniform '[ DescriptorSet 0, Binding 0 ]
+                        ( Struct '[ "mousePos" ':-> V 2 Float ] )
+   , "time"        ':-> Uniform '[ DescriptorSet 0, Binding 1 ] (Struct '[ "val" ':-> Float ])
+   ]
+
+fragment :: (Float, Float) -> G.FragmentShaderModule FragmentDefs _
+fragment (width,height) = shader do
+
+  ~(Vec4 ix iy _ _) <- #gl_FragCoord
+  ~(Vec2 mx my) <- use @(Name "ubo" :.: Name "mousePos")
+  t             <- use @(Name "time" :.: Name "val")
+
+  let uv@(Vec2 x y) = Vec2 (ix-Lit width) (iy-Lit height) ^/ Lit height
+
+  let
+    omega = pi
+    k = 1
+    r = 1
+    alpha = -k*x-omega*t
+    x' = (-alpha/k) - r*sin(alpha)
+    z  = -r*cos(alpha)
+
+  #out_colour .= Vec4 x' y z 1
+
+--------------------------------------------------------------------------------
+-- * Pipeline
+--------------------------------------------------------------------------------
+
+shaderPipeline :: (Word32, Word32) -> G.ShaderPipeline _
+shaderPipeline (fromIntegral -> x, fromIntegral -> y)
+  = G.ShaderPipeline (StructInput @VertexInput @(Triangle List))
+  G.:>-> vertex
+  G.:>-> fragment (x,y)