Mandlebrot Set basic render

examples/ghengin-games.cabal

@@ -168,3 +168,48 @@ executable fir-juliaset
                                , Ghengin.Core.Renderer as Ghengin.Vulkan.Renderer
                                )
     default-language: GHC2021
+
+executable mandlebrot-set
+    import:        common-flags
+    main-is:       Main.hs
+    other-modules: Shaders
+    default-extensions: UnicodeSyntax
+    build-depends:
+        base >=4.19.0.0,
+        -- 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
+
+    ghc-options: -dcmm-lint -dstg-lint -dasm-lint -g2 -rtsopts -debug -Wno-partial-type-signatures
+    cpp-options: -DDEBUG
+
+    hs-source-dirs:   mandlebrot-set
+    mixins:           ghengin-core
+                      requires ( Ghengin.Core.Renderer.Kernel as Ghengin.Vulkan.Renderer.Kernel
+                               , Ghengin.Core.Renderer.DescriptorSet as Ghengin.Vulkan.Renderer.DescriptorSet
+                               , Ghengin.Core.Renderer.Buffer as Ghengin.Vulkan.Renderer.Buffer
+                               , Ghengin.Core.Renderer.Pipeline as Ghengin.Vulkan.Renderer.Pipeline
+                               , Ghengin.Core.Renderer.RenderPass as Ghengin.Vulkan.Renderer.RenderPass
+                               , Ghengin.Core.Renderer.Texture as Ghengin.Vulkan.Renderer.Texture
+                               , Ghengin.Core.Renderer.Sampler as Ghengin.Vulkan.Renderer.Sampler
+                               , Ghengin.Core.Renderer.Command as Ghengin.Vulkan.Renderer.Command
+                               , Ghengin.Core.Renderer as Ghengin.Vulkan.Renderer
+                               )
+    -- We need to instance ghengin-geometry too...
+    -- That's quite awful: TODO: OPEN A TICKET
+    mixins:           ghengin-geometry
+                      requires ( Ghengin.Core.Renderer.Kernel as Ghengin.Vulkan.Renderer.Kernel
+                               , Ghengin.Core.Renderer.DescriptorSet as Ghengin.Vulkan.Renderer.DescriptorSet
+                               , Ghengin.Core.Renderer.Buffer as Ghengin.Vulkan.Renderer.Buffer
+                               , Ghengin.Core.Renderer.Pipeline as Ghengin.Vulkan.Renderer.Pipeline
+                               , Ghengin.Core.Renderer.RenderPass as Ghengin.Vulkan.Renderer.RenderPass
+                               , Ghengin.Core.Renderer.Texture as Ghengin.Vulkan.Renderer.Texture
+                               , Ghengin.Core.Renderer.Sampler as Ghengin.Vulkan.Renderer.Sampler
+                               , Ghengin.Core.Renderer.Command as Ghengin.Vulkan.Renderer.Command
+                               , Ghengin.Core.Renderer as Ghengin.Vulkan.Renderer
+                               )
+    default-language: GHC2021

examples/mandlebrot-set/Main.hs

@@ -0,0 +1,111 @@
+{-# 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 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(..))
+import Vulkan.Core10.FundamentalTypes (Extent2D(..))
+import qualified Data.Monoid.Linear as LMon
+import qualified FIR
+import qualified Math.Linear as FIR
+import qualified Prelude
+
+import Shaders
+
+pattern MAX_FRAME_TIME :: Float
+pattern MAX_FRAME_TIME = 0.5
+
+newtype MousePos = MousePos Vec2
+  deriving Storable
+  deriving FIR.Syntactic via (StructVec2 "mousePos")
+
+viewportVertices :: [ Vertex '[Vec3] ]
+viewportVertices =
+  [ Sin ( vec3 (-1) (-1) 0 )
+  , Sin ( vec3 (-1)   1  0 )
+  , Sin ( vec3   1 (-1)  0 )
+  , Sin ( vec3   1   1   0 )
+  ]
+
+viewportIndices :: [ Int ]
+viewportIndices
+  = [ 0, 1, 2
+    , 2, 1, 3
+    ]
+
+-- pattern WINDOW_SIZE = (2560, 1600)
+pattern WINDOW_SIZE = (1920, 1200)
+
+makeMainPipeline :: Renderer (RenderPipeline _ '[MousePos])
+makeMainPipeline = makeRenderPipeline (shaderPipeline WINDOW_SIZE)
+  ( DynamicBinding (Ur (MousePos $ vec2 0 0))
+  :## GHNil
+  )
+
+gameLoop :: forall (_s :: FIR.PipelineInfo). Vec2 -> PipelineKey _s '[MousePos] -> RenderQueue () ⊸ Core (RenderQueue ())
+gameLoop (WithVec2 previousPosX previousPosY) pkey rq = Linear.do
+ should_close <- (shouldCloseWindow ↑)
+ if should_close then return rq else Linear.do
+  (pollWindowEvents ↑)
+
+  Ur (double2Float -> newPosX, double2Float -> newPosY) <- (getMousePos ↑)
+  liftSystemIO $ print (newPosX, newPosY)
+
+  let pos = vec2 (0.5 * (previousPosX + newPosX)) (0.5 * (previousPosY + newPosY))
+
+  rq'  <- (editPipeline pkey rq (propertyAt @0 (\(Ur _) -> pure $ Ur $ MousePos pos)) ↑)
+
+  rq'' <- render rq'
+
+  gameLoop (vec2 newPosX newPosY) pkey rq''
+
+main :: Prelude.IO ()
+main = do
+ withLinearIO $
+  runCore WINDOW_SIZE Linear.do
+    pipeline             <- (makeMainPipeline ↑)
+    -- perhaps we should allow a way to bind meshes without materials? no! they
+    -- have to be compatible, and it turns out in this shader pipeline every
+    -- empty material is compatible. this explicitness is good...
+    (emptyMat, pipeline) <- (material GHNil pipeline ↑)
+    (mesh, pipeline)     <- (createMeshWithIxs pipeline GHNil viewportVertices viewportIndices ↑)
+    (rq, Ur pkey)        <- pure (insertPipeline pipeline LMon.mempty)
+    (rq, Ur mkey)        <- pure (insertMaterial pkey emptyMat rq)
+    (rq, Ur mshkey)      <- pure (insertMesh mkey mesh rq)
+
+    Ur (x,y) <- (getMousePos ↑)
+    rq <- gameLoop (vec2 (double2Float x) (double2Float y)) pkey rq
+
+    (freeRenderQueue rq ↑)
+
+    -- This is all done in the freeRenderQueue!
+    -- In fact, freeing these again is a type error. Woho!
+    -- (destroyRenderPipeline pipeline ↑)
+
+    return (Ur ())
+

examples/mandlebrot-set/Shaders.hs

@@ -0,0 +1,120 @@
+{-# 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
+
+------------------------------------------------
+-- pipeline input
+
+type VertexInput
+  = '[ Slot 0 0 ':-> V 3 Float ]
+
+-------------------------------------
+-- vertex shader
+
+type VertexDefs =
+  '[ "in_position"  ':-> Input      '[ Location 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 ] )
+   ]
+
+#define N 64
+#define B  4
+
+fragment :: (Float, Float) -> G.FragmentShaderModule FragmentDefs _
+fragment (width,height) = shader do
+
+  ~( Vec4 x y _ _ ) <- #gl_FragCoord
+
+  let uv = (2 *^ (Vec2 x y) ^-^ (Vec2 (Lit width) (Lit height)) ^-^ Vec2 1 1) ^/ (Lit height)
+
+  i <- iterate (CodeComplex uv)
+
+  let r = if i == N then 1 else i / N
+
+  #out_colour .= Vec4 r r r 1
+
+iterate :: _ => CodeComplex Float -> Program _s _s (Code Float)
+iterate c = locally do
+  #z     #= (Vec2 0 0 :: Code (V 2 Float))
+  #depth #= (0 :: Code Float) -- float incremented as an integer
+
+  loop do
+    zv@(CodeComplex -> z) <- #z
+    depth <- #depth
+    if dot zv zv > B*B || depth >= N
+    then break @1
+    else do
+      #z     .= codeComplex (z * z + c)
+      #depth .= depth + 1
+
+  depth <- #depth
+  return depth
+
+-- iterate' :: Code Float -> CodeComplex Float -> CodeComplex Float -> Code Float
+-- iterate' !i z c = do
+--   let z' = z * z + c
+--   if dot (codeComplex z') (codeComplex z') > B*B
+--     then i
+--     else iterate' (i+1) z' c
+
+------------------------------------------------
+-- pipeline
+
+shaderPipeline :: (Word32, Word32) -> G.ShaderPipeline _
+shaderPipeline (fromIntegral -> x, fromIntegral -> y)
+  = G.ShaderPipeline (StructInput @VertexInput @(Triangle List))
+  G.:>-> vertex
+  G.:>-> fragment (x,y)