From 3bd72ceb7b03554cb195164bda99d9c5b34fbff7 Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita Date: Thu, 26 Oct 2023 00:47:08 +0100 Subject: [PATCH] Successfully render Sam's Julia Set --- cabal.project | 4 +- games/ghengin-games.cabal | 122 -------------- games/planets-core/Camera.hs | 43 ----- games/planets-core/Main.hs | 138 --------------- games/planets-core/Planet.hs | 159 ------------------ games/planets-core/Shaders.hs | 150 ----------------- .../ghengin-core-indep/Ghengin/Core/Shader.hs | 16 +- ghengin-core/ghengin-core.cabal | 3 +- ghengin-core/ghengin-core/Ghengin/Core.hs | 10 +- .../Ghengin/Core/Render/Property.hs | 4 +- .../ghengin-core/Ghengin/Core/Render/Queue.hs | 23 ++- .../ghengin-core/Ghengin/Core/Renderer.hsig | 6 +- .../ghengin-vulkan/Ghengin/Vulkan/Renderer.hs | 19 ++- .../Ghengin/Vulkan/Renderer/GLFW/Window.hs | 1 + 14 files changed, 68 insertions(+), 630 deletions(-) delete mode 100644 games/ghengin-games.cabal delete mode 100644 games/planets-core/Camera.hs delete mode 100644 games/planets-core/Main.hs delete mode 100644 games/planets-core/Planet.hs delete mode 100644 games/planets-core/Shaders.hs diff --git a/cabal.project b/cabal.project index 69125d8..e94fd25 100644 --- a/cabal.project +++ b/cabal.project @@ -8,7 +8,7 @@ packages: ----------------------------- ./ghengin/ ./ghengin-camera/ - ./games/ + ./examples/ ./ghengin-geometry/ ./ghengin-vulkan/ ./ghengin-core/ @@ -26,7 +26,7 @@ package dear-imgui flags: +glfw +vulkan -sdl -opengl3 package fir - flags: +internals + flags: +internals +sop allow-newer: dear-imgui:*, diff --git a/games/ghengin-games.cabal b/games/ghengin-games.cabal deleted file mode 100644 index b2734fc..0000000 --- a/games/ghengin-games.cabal +++ /dev/null @@ -1,122 +0,0 @@ -cabal-version: 3.4 - --------------------------------------------------------------------------------- --- this file is split off from ../ghengin.cabal --- we had to split these libraries into a different package --- to fix HLS when using backpack --- when that's fixed, move the packages back together to the same cabal project file --------------------------------------------------------------------------------- - -name: ghengin-games -version: 0.1.0.0 -license: BSD-3-Clause -license-file: ../LICENSE -author: romes -maintainer: rodrigo.m.mesquita@gmail.com -category: Graphics -build-type: Simple -extra-doc-files: ../CHANGELOG.md - -flag dev - default: True - manual: True - description: This flag controls development settings and should be manually disabled when the game is being built for release. The ghengin packaging tools will take care to set this flag to false when packaging. - When enabled, vulkan validation layers are enabled. - Run `cabal build -f-dev` to build with the flag disabled. - -- Enable with -f+dev - -common common-flags - - if flag(dev) - ghc-options: -Wall -O0 - -dasm-lint - -dcmm-lint - -dstg-lint - - cc-options: -O0 -DDEBUG - cpp-options: -DDEBUG - -DDEBUG_TRACE - -DTHINGS_ARE_GOING_THAT_BAD - else - ghc-options: -Wall -O2 - cc-options: -O2 - - ghc-options: -Wno-partial-type-signatures - - default-extensions: UnicodeSyntax, - MultiParamTypeClasses, - NoStarIsType, - RankNTypes, - DataKinds, - PolyKinds, - GADTs, - ViewPatterns, - TypeApplications, - TypeFamilies, - ExplicitNamespaces, - TypeFamilyDependencies, - TypeOperators, - LambdaCase, - BlockArguments, - RecordWildCards, - UnboxedTuples, - PatternSynonyms, - DisambiguateRecordFields, - DeriveGeneric, - DerivingVia, - DerivingStrategies, - LinearTypes, - QualifiedDo, - QuantifiedConstraints, - RoleAnnotations, - PostfixOperators, - - -- Use Ghengin.Core.Prelude! - NoImplicitPrelude, - - default-language: GHC2021 - -executable planets-core - import: common-flags - main-is: Main.hs - other-modules: Camera, Planet, 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 - - ghc-options: -dcmm-lint -dstg-lint -dasm-lint -g2 -rtsopts -debug -Wno-partial-type-signatures - cpp-options: -DDEBUG - - hs-source-dirs: planets-core - 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 diff --git a/games/planets-core/Camera.hs b/games/planets-core/Camera.hs deleted file mode 100644 index 37ecfad..0000000 --- a/games/planets-core/Camera.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE OverloadedRecordDot #-} -module Camera where - -import Ghengin.Core.Prelude as Linear -import Ghengin.Core.Render - -import Geomancy.Vec3 -import Geomancy.Mat4 - --- A transform is required to calculate the view matrix (see 'makeView'). It's position determines the camera position and it's rotation determines the up in the case of LookAt and Direction -data View = ViewLookAt { _target :: {-# UNPACK #-} !Vec3 } -- ^ Ignore the camera's transform rotation (except for calculating up) and instead look at a target - | ViewDirection { _direction :: {-# UNPACK #-} !Vec3 } -- ^ Ignore the camera's transform rotation (except for calculating up) and instead look in a direction - | ViewTransform -- ^ Use solely the transform associated to the camera for the view matrix - deriving Show - -makeView :: Mat4 -> View -> Mat4 -makeView tr view = - let pos = posFromMat4 tr - up = vec3 0 (-1) 0 -- TODO: Calculate up based on camera rotation - in case view of - ViewLookAt target -> makeView tr (ViewDirection (target - pos)) - ViewDirection dir -> - let w@(WithVec3 wx wy wz) = normalize dir - u@(WithVec3 ux uy uz) = normalize $ cross w up - v@(WithVec3 vx vy vz) = cross w u - in colMajor ux uy uz (-dot u pos) - vx vy vz (-dot v pos) - wx wy wz (-dot w pos) - 0 0 0 1 - ViewTransform -> - -- Compute the inverse of the transform matrix to get the view transform - -- matrix, but do it directly because it's a homogenous rotation matrix - withColMajor tr (\ux vx wx _px uy vy wy _py uz vz wz _pz _ _ _ _ -> - let u = vec3 ux uy uz - v = vec3 vx vy vz - w = vec3 wx wy wz - in colMajor ux uy uz (-dot u pos) - vx vy vz (-dot v pos) - wx wy wz (-dot w pos) - 0 0 0 1) - -posFromMat4 :: Mat4 -> Vec3 -posFromMat4 = flip withColMajor (\_ _ _ x _ _ _ y _ _ _ z _ _ _ _ -> vec3 x y z) diff --git a/games/planets-core/Main.hs b/games/planets-core/Main.hs deleted file mode 100644 index 827899c..0000000 --- a/games/planets-core/Main.hs +++ /dev/null @@ -1,138 +0,0 @@ -{-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE PostfixOperators #-} -{-| - -The planets-core demo: - -A planet (render packet) is defined through a mesh, material, and pipeline, -which in turn are made up of multiple things, as represented in the following picture. - -┌─────────────┐┌─────────────┐┌────────────┐┌──────┐┌───────────┐ -│Position (DP)││Colormap (TP)││Min Max (SP)││Shader││Camera (DP)│ -└┬────────────┘└┬────────────┘└┬───────────┘└┬─────┘└┬──────────┘ -┌▽───┐┌─────────▽──────────────▽┐┌───────────▽───────▽┐ -│Mesh││Material ││Pipeline │ -└┬───┘└┬────────────────────────┘└┬───────────────────┘ -┌▽─────▽──────────────────────────▽┐ -│Planet (RenderPacket) │ -└──────────────────────────────────┘ - -The function `newPlanet` handles the creation of planet render packets... - --} -module Main where - -import Data.Coerce -import Data.Time -import Foreign.Storable -import Geomancy.Mat4 -import Geomancy.Transform -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.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.Vulkan.Renderer.Sampler -import Ghengin.Core.Render.Queue -import Ghengin.Core.Shader (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 -- planet shaders -import Planet - -newtype ProjectionM = ProjectionM Transform - deriving Storable -- use GlBlock instead... - deriving FIR.Syntactic via (StructMat4 "m") - -newtype ViewM = ViewM Transform - deriving Storable - deriving FIR.Syntactic via (StructMat4 "m") - -newtype CameraPos = CameraPos Vec3 - deriving Storable - deriving FIR.Syntactic via (StructVec3 "v") - -type CameraProperties = [ProjectionM, ViewM, CameraPos] - -pattern MAX_FRAME_TIME :: Float -pattern MAX_FRAME_TIME = 0.5 - --- We should use Alexander's gl-block library instead of Storable, and --- Geomancy.Transform.Tree for the node tree... - -makeMainPipeline :: Renderer (RenderPipeline _ CameraProperties) -makeMainPipeline = Linear.do - Ur extent <- getRenderExtent - - let radians d = d * (pi/180) - -- By making the extent into a static binding, when we update the extent - -- we must also explicitely update the static binding - projM = perspective @Word32 (radians 65) 0.1 100 extent.width extent.height - - makeRenderPipeline shaders - ( StaticBinding (Ur (coerce projM)) - :## DynamicBinding (Ur (coerce $ Transform identity)) - :## DynamicBinding (Ur (coerce $ vec3 0 0 0)) - :## GHNil ) - - -gameLoop :: UTCTime -> RenderQueue () ⊸ Core (RenderQueue ()) -gameLoop currentTime rq = Linear.do - logT "New frame" - should_close <- (shouldCloseWindow ↑) - if should_close then return rq else Linear.do - (pollWindowEvents ↑) - - 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 - - -- Render the rendering queue! - rq' <- render rq - - -- Loop! - gameLoop newTime rq' - - -main :: Prelude.IO () -main = do - currTime <- getCurrentTime - withLinearIO $ - runCore Linear.do - sampler <- ( createSampler FILTER_NEAREST SAMPLER_ADDRESS_MODE_CLAMP_TO_EDGE ↑) - tex <- ( texture "assets/planet_gradient.png" sampler ↑) - - pipeline <- (makeMainPipeline ↑) - ((p1mesh, pipeline), Ur minmax) <- newPlanetMesh pipeline defaultPlanetSettings - (pmat, pipeline) <- newPlanetMaterial minmax tex pipeline - (rq, Ur pkey) <- pure (insertPipeline pipeline LMon.mempty) - (rq, Ur mkey) <- pure (insertMaterial pkey pmat rq) - (rq, Ur mshkey) <- pure (insertMesh mkey p1mesh rq) - - rq <- gameLoop currTime rq - - (freeRenderQueue rq ↑) - -- This is all done in the freeRenderQueue! - -- In fact, freeing these again is a type error. Woho! - -- (freeMesh p1mesh ↑) - -- (freeMaterial pmat ↑) - -- (destroyRenderPipeline pipeline ↑) - - return (Ur ()) - diff --git a/games/planets-core/Planet.hs b/games/planets-core/Planet.hs deleted file mode 100644 index 58c8c95..0000000 --- a/games/planets-core/Planet.hs +++ /dev/null @@ -1,159 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE UndecidableInstances #-} -module Planet where - -import qualified Prelude as P -import Ghengin.Core.Prelude as Linear hiding (All, foldl') -import Ghengin.Core.Render -import Ghengin.Core.Render.Pipeline -import Ghengin.Core.Render.Property -import Ghengin.Core.Material -import Ghengin.Core.Type.Compatible -import Data.List (foldl') -import Ghengin.Core.Log - -import GHC.Float -import Numeric.Noise hiding (Noise) -import qualified Data.List.NonEmpty as NE - -import Ghengin.Core -import Ghengin.Core.Mesh -import Ghengin.Core.Shader () -- instance Syntactic Float -import Geomancy.Vec3 - -import Game.Geometry.Sphere -import Foreign.Storable.Generic - -import qualified FIR -import FIR.AST (FromGenericProduct(..)) -import qualified Math.Linear as FIR -import qualified Generics.SOP as SOP - --------------------------------------------------------------------------------- --- * Planet --------------------------------------------------------------------------------- - -data PlanetSettings = PlanetSettings { resolution :: !Int - , radius :: !Float - , color :: !Vec3 - , useFirstLayerAsMask :: !Bool - , noiseSettings :: !(NE.NonEmpty NoiseSettings) - , displayFace :: !DisplayFace - -- , gradient :: ImGradient - } - -data DisplayFace = All | FaceUp | FaceRight deriving Show - - - -data MinMax = MinMax !Float !Float - deriving (P.Eq, Generic, SOP.Generic, Show, GStorable) - deriving FIR.Syntactic via (FromGenericProduct MinMax ["min", "max"]) - --- instance FIR.Syntactic MinMax where --- type Internal MinMax = FIR.Val (FIR.Struct '[ "min" 'FIR.:-> FIR.Float, "max" 'FIR.:-> FIR.Float ]) --- toAST (MinMax x y) = FIR.Struct (FIR.Lit x FIR.:& FIR.Lit y FIR.:& FIR.End) --- fromAST struct = case (FIR.view @(FIR.Name "min") struct, FIR.view @(FIR.Name "max") struct) of --- (FIR.Lit x, FIR.Lit y) -> MinMax x y --- _ -> error "impossible" - -newPlanetMesh :: CompatibleVertex '[Vec3, Vec3, Vec3] π - => RenderPipeline π bs - ⊸ PlanetSettings -> Core ((Mesh '[Vec3, Vec3, Vec3] '[], RenderPipeline π bs), Ur MinMax) -newPlanetMesh rp (PlanetSettings re ra co enableMask nss df) = enterD "newPlanetMesh" $ Linear.do - - let (vs, is) = case df of - All -> - let UnitSphere v i = newUnitSphere re (Just co) in (v, i) - FaceUp -> - let UF v i = newUnitFace re (vec3 0 (-1) 0) - in (P.zipWith3 (\a b c -> a :& b :&: c) v (calculateSmoothNormals i v) (P.repeat co), i) - FaceRight -> - let UF v i = newUnitFace re (vec3 1 0 0) - in (P.zipWith3 (\a b c -> a :& b :&: c) v (calculateSmoothNormals i v) (P.repeat co), i) - - let (ps', elevations) = P.unzip $ (`map` vs) \(p :& _) -> - case nss of - ns NE.:| nss' -> - let initialElevation = evalNoise ns p - mask = if enableMask then initialElevation else 1 - noiseElevation = foldl' (\acc ns' -> acc + (evalNoise ns' p)*mask) initialElevation nss' - elevation = ra * (1 + noiseElevation) - in (p ^* elevation, elevation) - - let - ns' = calculateSmoothNormals is ps' - cs = P.map (\(_ :& _ :&: c) -> c) vs - vs'' = P.zipWith3 (\a b c -> a :& b :&: c) ps' ns' cs - - minmax = MinMax (P.minimum elevations) (P.maximum elevations) - in (,Ur minmax) <$> (createMeshWithIxs rp GHNil vs'' is ↑) - -newPlanetMaterial :: forall π p - . CompatibleMaterial '[MinMax,Texture2D] π - => MinMax - -> Alias Texture2D - ⊸ RenderPipeline π p - ⊸ Core (Material '[MinMax,Texture2D], RenderPipeline π p) -newPlanetMaterial mm t pl = ( material @_ @π (StaticBinding (Ur mm) :## Texture2DBinding t :## GHNil) pl ↑) - --------------------------------------------------------------------------------- --- * Noise --------------------------------------------------------------------------------- - - -data NoiseType = SimpleNoise | RigidNoise deriving Show - -data NoiseSettings = NoiseSettings { numLayers :: !Int - , strength :: !Float - , roughness :: !Float - , baseRoughness :: !Float - , persistence :: !Float - , center :: !Vec3 - , minValue :: !Float - , enabled :: !Bool - , type' :: !NoiseType - } - -evalNoise :: NoiseSettings -> Vec3 -> Float -evalNoise (NoiseSettings nl st ro br ps ce mv en nt) p = - case nt of - SimpleNoise -> evalSimpleNoise nl st ro br ps ce mv en p - RigidNoise -> evalRigidNoise nl st ro br ps ce mv en p - where - - evalSimpleNoise nlayers stren rough baseRoughness (float2Double -> persi) cent minVal enabled point = - -- Accumulator is noiseValue, frequency, and amplitude, and get updated for each layer - let (finalVal,_,_) = foldl' (\(noiseVal, freq, amplitude) _ -> - let v = noiseValue' (point ^* freq + cent) - noiseVal' = (v + 1)*0.5*amplitude + noiseVal - freq' = freq*rough -- >1 roughness will increase roughness as the layer increases - amplitude' = amplitude*persi -- <1 persistence implies amplitude decreases with each layer - in (noiseVal', freq', amplitude') - ) (0,baseRoughness,1) ([1..nlayers] :: [Int]) - in if enabled then P.max (double2Float finalVal - minVal) 0 * stren else 0 - - evalRigidNoise nlayers stren rough baseRoughness (float2Double -> persi) cent minVal enabled point = - -- Accumulator is noiseValue, frequency, amplitude, and weight, and get updated for each layer - let (finalVal,_,_,_) = foldl' (\(noiseVal, freq, amplitude, weight) _ -> - let v = 1 - abs(noiseValue' (point ^* freq + cent)) - v' = v*v*weight - noiseVal' = v'*amplitude + noiseVal - freq' = freq*rough -- >1 roughness will increase roughness as the layer increases - amplitude' = amplitude*persi -- <1 persistence implies amplitude decreases with each layer - weight' = v' -- weight starts at 1 is set to the value for each iteration - in (noiseVal', freq', amplitude', weight') - ) (0,baseRoughness,1,1) ([1..nlayers] :: [Int]) - in if enabled then P.max (double2Float finalVal - minVal) 0 * stren else 0 - - noiseValue' (WithVec3 x y z) = coherentNoise 2 (float2Double x, float2Double y, float2Double z) - -defaultPlanetSettings :: PlanetSettings -defaultPlanetSettings - = PlanetSettings 5 1 (vec3 1 0 0) False - [ NoiseSettings 1 1 1 2 0.5 (vec3 0 0 0) 0 True SimpleNoise - , NoiseSettings 1 1 1 2 0.5 (vec3 0 0 0) 0 True SimpleNoise - ] - All diff --git a/games/planets-core/Shaders.hs b/games/planets-core/Shaders.hs deleted file mode 100644 index 5751e5f..0000000 --- a/games/planets-core/Shaders.hs +++ /dev/null @@ -1,150 +0,0 @@ -{-# LANGUAGE RebindableSyntax #-} -{-# LANGUAGE PartialTypeSignatures #-} -module Shaders where - -import Ghengin.Core.Shader -import Geomancy.Vec3 hiding (dot) -import Geomancy.Mat4 -import FIR hiding ((:>->), ShaderPipeline) -- TODO: Give different names -import Math.Linear - --- Descriptor Set #0 for things bound once per pipeline (global pipeline data) --- Descriptor Set #1 for things bound once per material --- Descriptor Set #2 for things bound once per object - ----- Vertex ----- - -type VertexDefs - = '[ "out_position" ':-> Output '[ Location 0 ] (V 4 Float) - , "out_normal" ':-> Output '[ Location 1 ] (V 4 Float) - - , "proj" ':-> Uniform '[ DescriptorSet 0, Binding 0 ] (Struct '[ "m" ':-> M 4 4 Float ]) - , "view" ':-> Uniform '[ DescriptorSet 0, Binding 1 ] (Struct '[ "m" ':-> M 4 4 Float ]) - - , "in_position" ':-> Input '[ Location 0 ] (V 3 Float) - , "in_normal" ':-> Input '[ Location 1 ] (V 3 Float) - , "in_color" ':-> Input '[ Location 2 ] (V 3 Float) - ] - - -vertex :: VertexShaderModule VertexDefs _ -vertex = shader do - - ~(Vec3 x y z) <- get @"in_position" - ~(Vec3 nx ny nz) <- get @"in_normal" - - -- modelM <- use @(Name "push" :.: Name "model") - - -- Output position and normal in world coordinates - -- put @"out_position" (modelM !*^ (Vec4 x y z 1)) - -- put @"out_normal" (modelM !*^ (Vec4 nx ny nz 0)) - -- Normal is not a position so shouldn't be affected by translation (hence the 0 in the 4th component) - - -- Temporarily... - put @"out_position" (Vec4 x y z 1) - put @"out_normal" (Vec4 nx ny nz 0) - - put @"gl_Position" =<< applyMVP (Vec4 x y z 1) - ----- Fragment ----- - - -type FragmentDefs - = '[ "in_position" ':-> Input '[ Location 0 ] (V 4 Float) - , "in_normal" ':-> Input '[ Location 1 ] (V 4 Float) - - , "camera_pos" ':-> Uniform '[ DescriptorSet 0, Binding 2 ] (Struct '[ "v" ':-> V 3 Float ]) -- try changing to CameraPos, maybe Canonicalization will catch it. - - , "minmax" ':-> Uniform '[ DescriptorSet 1, Binding 0 ] - ( Struct '[ "min" ':-> Float - , "max" ':-> Float ] ) -- Careful with alignment... - , "gradient" ':-> Texture2D '[ DescriptorSet 1, Binding 1 ] (RGBA8 UNorm) - - ] - - -fragment :: FragmentShaderModule FragmentDefs _ -fragment = shader do - - ~(Vec4 px py pz _) <- get @"in_position" - - -- Color - min' <- use @(Name "minmax" :.: Name "min") - max' <- use @(Name "minmax" :.: Name "max") - - let col_frac = invLerp (norm (Vec3 px py pz)) min' max' - - ~(Vec4 cx' cy' cz' _) <- use @(ImageTexel "gradient") NilOps (Vec2 col_frac col_frac) - - ~(Vec3 colx coly colz) <- blinnPhong 16 $ Vec3 cx' cy' cz' - - put @"out_colour" (Vec4 colx coly colz 1) - ---- Pipeline ---- - --- | Data for each vertex in this shader pipeline -type VertexData = - '[ Slot 0 0 ':-> V 3 Float -- in pos - , Slot 1 0 ':-> V 3 Float -- in normal - , Slot 2 0 ':-> V 3 Float -- in color - ] - -shaders :: ShaderPipeline _ -shaders - = ShaderPipeline (StructInput @VertexData @(Triangle List)) - :>-> vertex - :>-> fragment - ------ Utils -------------------------------------------------------------------- - -blinnPhong :: ∀ π - . ( V 4 Float ~ Has "in_position" π - , V 4 Float ~ Has "in_normal" π - - , CanGet "in_position" π - , CanGet "in_normal" π - - , CanGet "camera_pos" π - - , _ -- extra constraints (wildcard at the end) - ) - => Code Float -> Code (V 3 Float) -> Program π π (Code (V 3 Float)) -blinnPhong specularity col = do - - ~(Vec4 px py pz _) <- get @"in_position" @(V 4 Float) @π - ~(Vec4 nx ny nz _) <- get @"in_normal" @(V 4 Float) @π - ~(Vec3 cx cy cz) <- use @(Name "camera_pos" :.: Name "v") - - let - - -- Light - viewDir = normalise (Vec3 cx cy cz ^-^ Vec3 px py pz) - dirToLight = normalise (Vec3 1 (-3) (-1)) - ambient = 0.05 *^ col - normal = normalise (Vec3 nx ny nz) - -- light intensity given by cosine of direction to light and the normal in world space - diffuse = (max (dot dirToLight normal) 0) *^ col - halfwayDir = normalise (dirToLight ^+^ viewDir) - specular = ((max (dot halfwayDir normal) 0) ** specularity) *^ (Vec3 0.3 0.3 0.3 {- bright light -}) - - Vec3 colx coly colz = ambient ^+^ diffuse ^+^ specular - - in - pure $ Vec3 colx coly colz - -applyMVP :: ∀ π. ( CanGet "proj" π - , CanGet "view" π - , _ -- extra constraints - ) - => (Code (V 4 Float)) -> Program π π (Code (V 4 Float)) -applyMVP vec = do - - -- modelM <- use @(Name "push" :.: Name "model" :: Optic '[] π (M 4 4 Float)) - projM <- use @(Name "proj" :.: Name "m" :: Optic '[] π (M 4 4 Float)) - viewM <- use @(Name "view" :.: Name "m" :: Optic '[] π (M 4 4 Float)) - - pure $ (projM !*! viewM) !*^ vec - -invLerp :: FIR.DivisionRing a => a -> a -> a -> a -invLerp value from to = (value FIR.- from) FIR./ (to FIR.- from) - 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 dfe1747..d1a14fa 100644 --- a/ghengin-core-indep/ghengin-core-indep/Ghengin/Core/Shader.hs +++ b/ghengin-core-indep/ghengin-core-indep/Ghengin/Core/Shader.hs @@ -12,6 +12,7 @@ import Data.Kind import GHC.TypeLits import Ghengin.Core.Shader.Canonical import Ghengin.Core.Shader.Pipeline +import Geomancy.Vec2 import Geomancy.Vec3 import Geomancy.Mat4 @@ -55,6 +56,9 @@ type FragmentShaderModule defs -- -- @ +type StructVec2 :: Symbol -> Type +newtype StructVec2 name = StructVec2 Vec2 + type StructVec3 :: Symbol -> Type newtype StructVec3 name = StructVec3 Vec3 @@ -67,15 +71,23 @@ instance FIR.Syntactic FIR.Float where toAST = FIR.Lit fromAST (FIR.Lit x) = x +instance FIR.Syntactic Vec2 where + type Internal Vec2 = FIR.Val (V 2 FIR.Float) + toAST (WithVec2 x y) = FIR.toAST (V2 x y) + fromAST (FIR.fromAST -> V2 x y) = vec2 x y + +instance KnownSymbol name => FIR.Syntactic (StructVec2 name) where + type Internal (StructVec2 name) = FIR.Val (FIR.Struct '[ name 'FIR.:-> V 2 FIR.Float ]) + toAST (StructVec2 v2) = FIR.Struct (FIR.toAST v2 FIR.:& FIR.End) + fromAST (FIR.fromAST FIR.. FIR.view @(FIR.Name name) -> v3) = StructVec2 v3 + instance FIR.Syntactic Vec3 where type Internal Vec3 = FIR.Val (V 3 FIR.Float) - toAST (WithVec3 x y z) = FIR.toAST (V3 x y z) fromAST (FIR.fromAST -> V3 x y z) = vec3 x y z instance KnownSymbol name => FIR.Syntactic (StructVec3 name) where type Internal (StructVec3 name) = FIR.Val (FIR.Struct '[ name 'FIR.:-> V 3 FIR.Float ]) - toAST (StructVec3 v3) = FIR.Struct (FIR.toAST v3 FIR.:& FIR.End) fromAST (FIR.fromAST FIR.. FIR.view @(FIR.Name name) -> v3) = StructVec3 v3 diff --git a/ghengin-core/ghengin-core.cabal b/ghengin-core/ghengin-core.cabal index be8bbf7..9d9d962 100644 --- a/ghengin-core/ghengin-core.cabal +++ b/ghengin-core/ghengin-core.cabal @@ -134,5 +134,6 @@ library gl-block, ghengin-core-indep, - linear-utils + linear-utils, + constraints diff --git a/ghengin-core/ghengin-core/Ghengin/Core.hs b/ghengin-core/ghengin-core/Ghengin/Core.hs index b991309..9f04302 100644 --- a/ghengin-core/ghengin-core/Ghengin/Core.hs +++ b/ghengin-core/ghengin-core/Ghengin/Core.hs @@ -44,9 +44,13 @@ data CoreState newtype Core α = Core (StateT CoreState Renderer α) deriving (Functor, Data.Functor, Applicative, Data.Applicative, Monad, MonadIO, HasLogger) -runCore :: Core a ⊸ IO a -runCore (Core st) - = runRenderer $ Linear.do +-- ROMES:TODO: Eventually, the base configuration of the Core engine renderer should be passed in a record "RenderConfig" + +runCore :: (Int, Int) + -- ^ Dimensions of the window the Core engine renderer will render on + -> Core a ⊸ IO a +runCore dimensions (Core st) + = runRenderer dimensions $ Linear.do (a, CoreState i) <- runStateT st (CoreState 0) () <- pure (consume i) return a diff --git a/ghengin-core/ghengin-core/Ghengin/Core/Render/Property.hs b/ghengin-core/ghengin-core/Ghengin/Core/Render/Property.hs index 029263d..c5221b4 100644 --- a/ghengin-core/ghengin-core/Ghengin/Core/Render/Property.hs +++ b/ghengin-core/ghengin-core/Ghengin/Core/Render/Property.hs @@ -12,6 +12,7 @@ module Ghengin.Core.Render.Property , GHList(..) ) where +import GHC.TypeError import Ghengin.Core.Prelude as Linear import Foreign.Storable (Storable(sizeOf)) import Ghengin.Core.Renderer.Kernel @@ -280,7 +281,8 @@ class HasPropertyAt' n m φ α β where -- propertyAt' :: Linear.Functor f => (β %p -> f (Renderer β)) %x -> (φ α ⊸ f (Renderer (φ α))) propertyAt' :: (β' ~ PBInv β) => (β' ⊸ Renderer β') %x -> (φ α ⊸ Renderer (φ α)) --- TODO: Instance with type error for "No available property with type X at position N" +instance (Unsatisfiable (Text "The requested property " :<>: ShowType α :<>: Text " does not exist in the properties list" {- :<>: ShowType α -})) => HasPropertyAt' n n' φ '[] α where + propertyAt' = unsatisfiable -- This instance should always overlap the recursive instance below because we -- want to stop when we find the binding diff --git a/ghengin-core/ghengin-core/Ghengin/Core/Render/Queue.hs b/ghengin-core/ghengin-core/Ghengin/Core/Render/Queue.hs index 48759de..0ccd3f5 100644 --- a/ghengin-core/ghengin-core/Ghengin/Core/Render/Queue.hs +++ b/ghengin-core/ghengin-core/Ghengin/Core/Render/Queue.hs @@ -1,9 +1,5 @@ -{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE QualifiedDo #-} -{-# LANGUAGE LinearTypes #-} {-| Note [Render Queue] ~~~~~~~~~~~~~~~~~~~ @@ -49,6 +45,9 @@ import Ghengin.Core.Log import Ghengin.Core.Type.Utils (Some2(..)) import Ghengin.Core.Material hiding (material) +import Data.Constraint +import Unsafe.Coerce (unsafeCoerce) + newtype RenderQueue a = RenderQueue (Map TypeRep (Some2 RenderPipeline, Map Unique (Some Material, [(Some2 Mesh, a)]))) deriving (Prelude.Functor) @@ -149,6 +148,22 @@ insertMesh (UnsafeMaterialKey (mkey, pkey)) in (RenderQueue rq, Ur $ UnsafeMeshKey (meid, mkey, pkey)) +editPipeline :: PipelineKey π p -> RenderQueue () ⊸ (RenderPipeline π p ⊸ Renderer (RenderPipeline π p)) ⊸ Renderer (RenderQueue ()) +editPipeline (UnsafePipelineKey pkey) = + -- Use withDict to avoid writing alterF with linear functor... + withDict (unsafeCoerce (Dict :: Dict (Functor Renderer)) :: Dict (Prelude.Functor Renderer)) go + where + go :: Prelude.Functor Renderer => RenderQueue () ⊸ (RenderPipeline π p ⊸ Renderer (RenderPipeline π p)) ⊸ Renderer (RenderQueue ()) + go = Unsafe.toLinear2 \(RenderQueue q) edit -> + RenderQueue Prelude.<$> + M.alterF (\case Nothing -> error "pipeline key not in rq" + Just (Some2 rp, materials) -> + -- Key guarantees the type of the pipeline at that key is the same, + -- so this is safe + (\x -> Just (Some2 x, materials)) <$> edit (unsafeCoerce rp) + ) pkey q + + freeRenderQueue :: RenderQueue () ⊸ Renderer () freeRenderQueue (RenderQueue rq) = Linear.do diff --git a/ghengin-core/ghengin-core/Ghengin/Core/Renderer.hsig b/ghengin-core/ghengin-core/Ghengin/Core/Renderer.hsig index 8f62abb..aa545d5 100644 --- a/ghengin-core/ghengin-core/Ghengin/Core/Renderer.hsig +++ b/ghengin-core/ghengin-core/Ghengin/Core/Renderer.hsig @@ -28,7 +28,9 @@ import Ghengin.Core.Renderer.Sampler import qualified Data.Linear.Alias as Alias -runRenderer :: Renderer a ⊸ Linear.IO a +runRenderer :: (Int, Int) + -- ^ Dimensions of the window to render on (width, height) + -> Renderer a ⊸ Linear.IO a -- extremely contrived? not anymore (at least no longer using the transformer thing, since we no longer mix render packets with things like the ECS system s.t. this function had to be run in ECS context)! withCurrentFramePresent :: Int -- ^ Current frame index @@ -41,4 +43,6 @@ withCurrentFramePresent :: Int -- ^ Current frame index -- A bit GLFW-centric, but passable... shouldCloseWindow :: Renderer Bool pollWindowEvents :: Renderer () +getMousePos :: Renderer (Ur (Double, Double)) + diff --git a/ghengin-vulkan/ghengin-vulkan/Ghengin/Vulkan/Renderer.hs b/ghengin-vulkan/ghengin-vulkan/Ghengin/Vulkan/Renderer.hs index 9bf9c7f..d1a04b6 100644 --- a/ghengin-vulkan/ghengin-vulkan/Ghengin/Vulkan/Renderer.hs +++ b/ghengin-vulkan/ghengin-vulkan/Ghengin/Vulkan/Renderer.hs @@ -57,6 +57,8 @@ import Vulkan.Zero (zero) import Ghengin.Core.Log +import qualified Graphics.UI.GLFW as GLFW + -- reexport import Ghengin.Vulkan.Renderer.DescriptorSet import Ghengin.Vulkan.Renderer.Buffer @@ -72,9 +74,11 @@ import Ghengin.Vulkan.Renderer.Kernel import qualified System.IO.Linear as Linear -- ROMES: Eventually thikn about bracketing again, but for linear types to work simply get rid of it --- ROMES:TODO: Make runRenderer an hsig in Ghengin.Core.Renderer -runRenderer :: Renderer a ⊸ Linear.IO a -runRenderer r = Linear.do + +runRenderer :: (Int, Int) + -- ^ Dimensions of the window to render on (width, height) + -> Renderer a ⊸ Linear.IO a +runRenderer dimensions r = Linear.do -- Initialisation ----------------- @@ -82,7 +86,7 @@ runRenderer r = Linear.do inst <- createInstance validationLayers - (win, inst) <- createVulkanWindow inst (1280, 720) "Ghengin" + (win, inst) <- createVulkanWindow inst dimensions "Ghengin" (Ur rateFunc, win) <- pure $ Unsafe.toLinear (\w -> (Ur (rateFn w._surface), w)) win @@ -306,6 +310,8 @@ rateFn surface d = do isSuitablePresent :: Int -> Prelude.IO Bool isSuitablePresent i = Vk.getPhysicalDeviceSurfaceSupportKHR pd (Prelude.fromIntegral i) sr +-- :| Windowing with GLFW |: + shouldCloseWindow :: Renderer Bool shouldCloseWindow = renderer $ Unsafe.toLinear $ \renv@(REnv{..}) -> Linear.do b <- liftSystemIO (GLFW.windowShouldClose _vulkanWindow._window) @@ -315,6 +321,11 @@ pollWindowEvents :: Renderer () pollWindowEvents = liftSystemIO $ GLFW.pollEvents +getMousePos :: Renderer (Ur (Double, Double)) +getMousePos = renderer $ Unsafe.toLinear $ \renv@(REnv{..}) -> Linear.do + p <- liftSystemIOU (GLFW.getCursorPos _vulkanWindow._window) + pure $ (p, renv) + -- :| Utils |: -- getRenderExtent :: Renderer Vk.Extent2D diff --git a/ghengin-vulkan/ghengin-vulkan/Ghengin/Vulkan/Renderer/GLFW/Window.hs b/ghengin-vulkan/ghengin-vulkan/Ghengin/Vulkan/Renderer/GLFW/Window.hs index 855b9aa..35ad294 100644 --- a/ghengin-vulkan/ghengin-vulkan/Ghengin/Vulkan/Renderer/GLFW/Window.hs +++ b/ghengin-vulkan/ghengin-vulkan/Ghengin/Vulkan/Renderer/GLFW/Window.hs @@ -112,3 +112,4 @@ initGLFW = liftSystemIO $ do terminateGLFW :: Linear.MonadIO m => GLFWToken ⊸ m () terminateGLFW GLFWToken = liftSystemIO $ GLFW.terminate +