keid-core 0.1.5.1 → 0.1.6.0

raw patch · 13 files changed

+374/−113 lines, 13 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• ChangeLog.md +5/−0
• keid-core.cabal +6/−2
• src/Engine/Camera.hs +119/−38
• src/Engine/Camera/Controls.hs +126/−0
• src/Engine/Camera/Event/Handler.hs +49/−0
• src/Engine/Camera/Event/Type.hs +16/−0
• src/Engine/Events/CursorPos.hs +20/−2
• src/Engine/Frame.hs +1/−1
• src/Engine/Setup.hs +1/−9
• src/Engine/Types.hs +4/−4
• src/Engine/UI/Layout.hs +3/−7
• src/Engine/Vulkan/Swapchain.hs +9/−12
• src/Engine/Worker.hs +15/−38

@@ -1,5 +1,10 @@ # Changelog for keid-core +## 0.1.6.0++- Added `Engine.Camera` with projection and view controls.+- Worker `Cell` changed into an input-annotated `Merge`.+ ## 0.1.5.1  - Fixed `VMA.AllocatorCreateInfo` for `vulkan-3.15` and newer.

@@ -5,12 +5,13 @@ -- see: https://github.com/sol/hpack  name:           keid-core-version:        0.1.5.1+version:        0.1.6.0 synopsis:       Core parts of Keid engine. category:       Game Engine+homepage:       https://keid.haskell-game.dev author:         IC Rainbow maintainer:     keid@aenor.ru-copyright:      2021 IC Rainbow+copyright:      2022 IC Rainbow license:        BSD3 license-file:   LICENSE build-type:     Simple@@ -26,6 +27,9 @@   exposed-modules:       Engine.App       Engine.Camera+      Engine.Camera.Controls+      Engine.Camera.Event.Handler+      Engine.Camera.Event.Type       Engine.DataRecycler       Engine.Events       Engine.Events.CursorPos

@@ -1,5 +1,29 @@-module Engine.Camera where+module Engine.Camera+  ( ProjectionKind(..)+  , Projection(..)+  , ProjectionParams+  , ProjectionInput(..)+  , ProjectionProcess+  , spawnPerspective+  , mkTransformPerspective +  , spawnOrthoPixelsCentered+  , mkTransformOrthoPixelsCentered++  , spawnProjectionWith++  , spawnProjection+  , pattern PROJECTION_NEAR+  , pattern PROJECTION_FAR++  , View(..)+  , ViewProcess+  , ViewOrbitalInput(..)+  , initialOrbitalInput+  , mkViewOrbital+  , mkViewOrbital_+  ) where+ import RIO  import Geomancy (Transform(..), Vec3, vec3)@@ -9,49 +33,49 @@ import Geomancy.Vulkan.Projection qualified as Projection import Geomancy.Vulkan.View qualified as View import Vulkan.Core10 qualified as Vk+import Vulkan.NamedType ((:::)) +import Engine.Types qualified as Engine import Engine.Worker qualified as Worker  -- * Projection -data Projection = Projection-  { projectionPerspective :: Transform-  , projectionOrthoUI     :: Transform-  }-  deriving (Show)--instance Semigroup Projection where-  _a <> b = Projection-    { projectionPerspective = projectionPerspective b-    , projectionOrthoUI     = projectionOrthoUI     b-    }+data ProjectionKind+  = Perspective+  | Orthographic+  deriving (Eq, Ord, Show, Enum, Bounded, Generic) -instance Monoid Projection where-  mempty = Projection mempty mempty+data Projection (pk :: ProjectionKind) = Projection+  { projectionTransform :: Transform+  , projectionInverse   :: ~Transform+  }+  deriving (Show, Generic) -type ProjectionProcess = Worker.Cell ProjectionInput Projection+type ProjectionProcess pk = Worker.Cell (ProjectionInput pk) (Projection pk) -data ProjectionInput = ProjectionInput-  { projectionFovRads :: Float-  , projectionScreen  :: Vk.Extent2D+data ProjectionInput (pk :: ProjectionKind) = ProjectionInput+  { projectionParams :: ProjectionParams pk+  , projectionNear   :: Float+  , projectionFar    :: Float   }-  deriving (Show) -mkProjection :: ProjectionInput -> Projection-mkProjection ProjectionInput{..} = Projection{..}-  where-    -- BUG: infinitePerspective gives huge clipping and effective FoV is different-    -- projectionPerspective = Projection.infinitePerspective projectionFovRads width height-    projectionPerspective = Projection.perspective-      projectionFovRads-      PROJECTION_NEAR-      PROJECTION_FAR-      width-      height+-- XXX: undecidable+-- deriving instance (Show (ProjectionParams pk)) => Show (ProjectionInput pk) -    projectionOrthoUI = Projection.orthoOffCenter 0 1 width height+type family ProjectionParams (pk :: ProjectionKind) where+  ProjectionParams 'Perspective = "fov-v" ::: Float+  ProjectionParams 'Orthographic = () -    Vk.Extent2D{width, height} = projectionScreen+spawnProjection+  :: (Vk.Extent2D -> ProjectionInput pk -> Transform)+  -> ProjectionParams pk+  -> Engine.StageRIO env (ProjectionProcess pk)+spawnProjection mkTransform params =+  spawnProjectionWith mkTransform ProjectionInput+    { projectionNear    = PROJECTION_NEAR+    , projectionFar     = PROJECTION_FAR+    , projectionParams  = params+    }  pattern PROJECTION_NEAR :: (Eq a, Num a, Fractional a) => a pattern PROJECTION_NEAR = 0x0.02 -- i.e. 1/2048@@ -59,6 +83,50 @@ pattern PROJECTION_FAR :: (Eq a, Num a) => a pattern PROJECTION_FAR = 16384 +spawnProjectionWith+  :: (Vk.Extent2D -> ProjectionInput pk -> Transform)+  -> ProjectionInput pk+  -> Engine.StageRIO env (ProjectionProcess pk)+spawnProjectionWith mkTransform projectionInput = do+  screen <- Engine.askScreenVar+  input <- Worker.newVar projectionInput+  fmap (input,) $+    Worker.spawnMerge2+      (\s i ->+          let+            transform = mkTransform s i+          in+            Projection+              { projectionTransform = transform+              , projectionInverse   = Transform.inverse transform -- XXX: better provide an inverse directly+              }+      )+      screen+      input++spawnPerspective :: Engine.StageRIO env (ProjectionProcess 'Perspective)+spawnPerspective = spawnProjection mkTransformPerspective (τ / 4)++mkTransformPerspective :: Vk.Extent2D -> ProjectionInput 'Perspective -> Transform+mkTransformPerspective Vk.Extent2D{width, height} ProjectionInput{..} =+  Projection.perspective+    projectionParams+    projectionNear+    projectionFar+    width+    height++spawnOrthoPixelsCentered :: Engine.StageRIO env (ProjectionProcess 'Orthographic)+spawnOrthoPixelsCentered = spawnProjectionWith mkTransformOrthoPixelsCentered ProjectionInput+  { projectionNear   = 0+  , projectionFar    = 1+  , projectionParams = ()+  }++mkTransformOrthoPixelsCentered :: Vk.Extent2D -> ProjectionInput 'Orthographic -> Transform+mkTransformOrthoPixelsCentered Vk.Extent2D{width, height} ProjectionInput{..} =+  Projection.orthoOffCenter projectionNear projectionFar width height+ -- * View  data View = View@@ -78,28 +146,41 @@   , orbitDistance :: Float   , orbitScale    :: Float   , orbitTarget   :: Vec3+  , orbitUp       :: Vec3+  , orbitRight    :: Vec3   }   deriving (Show) +initialOrbitalInput :: ViewOrbitalInput+initialOrbitalInput = ViewOrbitalInput+  { orbitAzimuth  = 0 -- τ/8+  , orbitAscent   = τ/7+  , orbitDistance = 8.0+  , orbitScale    = 1+  , orbitTarget   = 0+  , orbitUp       = vec3 0 (-1) 0+  , orbitRight    = vec3 1 0 0+  }+ mkViewOrbital :: Vec3 -> ViewOrbitalInput -> View mkViewOrbital cameraTarget ViewOrbitalInput{..} = View{..}   where-    viewTransform = View.lookAt viewPosition cameraTarget axisUp+    viewTransform = View.lookAt viewPosition cameraTarget orbitUp     viewTransformInv = Transform.inverse viewTransform      viewPosition =       orbitTarget +       Quaternion.rotate-        ( Quaternion.axisAngle axisUp orbitAzimuth *-          Quaternion.axisAngle axisRight orbitAscent+        ( Quaternion.axisAngle orbitUp orbitAzimuth *+          Quaternion.axisAngle orbitRight orbitAscent         )         (vec3 0 0 $ orbitDistance * orbitScale)      viewDirection = Vec3.normalize $ cameraTarget - viewPosition -    axisUp    = vec3 0 (-1) 0-    axisRight = vec3 1 0 0- {-# INLINE mkViewOrbital_ #-} mkViewOrbital_ :: ViewOrbitalInput -> View mkViewOrbital_ voi = mkViewOrbital (orbitTarget voi) voi++τ :: Float+τ = 2 * pi

@@ -0,0 +1,126 @@+module Engine.Camera.Controls+  ( Camera.ProjectionProcess+  , Camera.ViewProcess+  , spawnViewOrbital++  , Controls(..)+  , ControlsProcess+  , spawnControls++  , panInstant+  ) where++import RIO++import Engine.Camera qualified as Camera+import Engine.Worker qualified as Worker+import Geomancy (Vec3, vec3)+import Geomancy.Quaternion qualified as Quaternion++spawnViewOrbital :: Camera.ViewOrbitalInput -> RIO env Camera.ViewProcess+spawnViewOrbital = Worker.spawnCell Camera.mkViewOrbital_++data Controls a = Controls+  { panHorizontal   :: a+  , panVertical     :: a+  , turnAzimuth     :: a+  , turnInclination :: a+  }+  deriving (Functor, Foldable, Traversable)++type ControlsProcess = Controls (Worker.Timed Float ())++spawnControls :: Camera.ViewProcess -> RIO env ControlsProcess+spawnControls vp =+  traverse mkUpdater Controls+    { panHorizontal   = panTargetHorizontal+    , panVertical     = panTargetVertical+    , turnAzimuth     = orbitAzimuthTurn+    , turnInclination = orbitAscentTurn+    }+  where+    vpInput = Worker.getInput vp++    dtI = 1e3+    dt = fromIntegral dtI / 1e6++    mkUpdater updater =+      Worker.spawnTimed+        True+        (Left dtI)+        (\_delta -> pure ((), 0.0))+        (\acceleration delta -> do+            when (delta /= 0) $+              Worker.pushInput vpInput $+                updater (1 + acceleration) (delta * dt)+            pure+              ( Nothing+              , if delta == 0 then+                  if acceleration < 1/128 then+                    acceleration+                  else+                    acceleration * 0.97+                else+                  acceleration + 0.01+              )+        )+        0++    panTargetHorizontal acceleration delta voi = voi+      { Camera.orbitTarget = Camera.orbitTarget voi + pan+      }+      where+        pan = Quaternion.rotate+          (Quaternion.axisAngle up azimuth)+          (vec3 (delta * acceleration) 0 0)+        up = Camera.orbitUp voi+        azimuth = Camera.orbitAzimuth voi++    panTargetVertical acceleration delta voi = voi+      { Camera.orbitTarget = Camera.orbitTarget voi + pan+      }+      where+        pan =+          Quaternion.rotate+            (Quaternion.axisAngle up azimuth)+            (vec3 0 0 (delta * acceleration))++        up = Camera.orbitUp voi+        azimuth = Camera.orbitAzimuth voi++    orbitAzimuthTurn _acceleration delta voi = voi+      { Camera.orbitAzimuth = azimuth+      }+      where+        azimuth+          | azimuth' < (-τ) = azimuth' + (2 * τ)+          | azimuth' > τ = azimuth' - (2 * τ)+          | otherwise = azimuth'++        azimuth' = Camera.orbitAzimuth voi + delta++    orbitAscentTurn _acceleration delta voi = voi+      { Camera.orbitAscent = ascent+      }+      where+        ascent =+          max (-limit) . min limit $+            Camera.orbitAscent voi + delta++        limit = τ/4 - 1/512++panInstant :: MonadIO m => Camera.ViewProcess -> Vec3 -> m ()+panInstant vp delta3 = do+  Worker.pushInput vp \voi@Camera.ViewOrbitalInput{..} ->+    let+      pan azimuth = Quaternion.rotate+        (Quaternion.axisAngle orbitUp azimuth)+        delta3 * 0.01+    in+      voi+        { Camera.orbitTarget =+            Camera.orbitTarget voi + pan orbitAzimuth+        }++τ :: Float+τ = 2 * pi

@@ -0,0 +1,49 @@+module Engine.Camera.Event.Handler+  ( handler+  ) where++import RIO++import Engine.Camera qualified as Camera+import Engine.Camera.Controls qualified as Controls+import Engine.Camera.Event.Type (Event)+import Engine.Camera.Event.Type qualified as Event+import Engine.Worker qualified as Worker++handler+  :: MonadIO m+  => m Controls.ViewProcess+  -> m Controls.ControlsProcess+  -> Event+  -> m ()+handler getViewP getCameraControls = \case+  Event.Zoom delta -> do+    cameraView <- getViewP+    Worker.pushInput cameraView \voi -> voi+      { Camera.orbitDistance =+          max 0.5 $ Camera.orbitDistance voi - delta * 0.5+      }++  Event.Pan delta -> do+    cameraView <- getViewP+    Controls.panInstant cameraView delta++  Event.PanHorizontal delta -> do+    controls <- getCameraControls+    Worker.modifyConfig (Controls.panHorizontal controls) $+      const delta++  Event.PanVertical delta -> do+    controls <- getCameraControls+    Worker.modifyConfig (Controls.panVertical controls) $+      const delta++  Event.TurnAzimuth delta -> do+    controls <- getCameraControls+    Worker.modifyConfig (Controls.turnAzimuth controls) $+      const delta++  Event.TurnInclination delta -> do+    controls <- getCameraControls+    Worker.modifyConfig (Controls.turnInclination controls) $+      const delta

@@ -0,0 +1,16 @@+module Engine.Camera.Event.Type+  ( Event(..)+  ) where++import RIO++import Geomancy (Vec3)++data Event+  = Zoom Float+  | Pan Vec3+  | PanHorizontal Float+  | PanVertical Float+  | TurnAzimuth Float+  | TurnInclination Float+  deriving (Show)

@@ -2,11 +2,13 @@  import RIO -import Geomancy (Vec2, vec2)+import Geomancy (Vec2, vec2, pattern WithVec2) import GHC.Float (double2Float) import UnliftIO.Resource (ReleaseKey)+import Vulkan.Core10 qualified as Vk+import Vulkan.NamedType ((:::)) -import Engine.Types (StageRIO)+import Engine.Types (StageRIO, askScreenVar) import Engine.Window.CursorPos qualified as CursorPos import Engine.Worker qualified as Worker @@ -33,3 +35,19 @@   -- logDebug $ "CursorPos event: " <> displayShow (windowX, windowY)   Worker.pushInput cursorVar \_old ->     vec2 (double2Float windowX) (double2Float windowY)++type Process = Worker.Cell ("window" ::: Vec2) ("centered" ::: Vec2)++spawn :: StageRIO env Process+spawn = do+  screen <- askScreenVar+  cursorWindow <- Worker.newVar 0+  fmap (cursorWindow,) $+    Worker.spawnMerge2+      (\Vk.Extent2D{width, height} (WithVec2 windowX windowY) ->+          vec2+            (windowX - fromIntegral width / 2)+            (windowY - fromIntegral height / 2)+      )+      screen+      cursorWindow

@@ -51,7 +51,7 @@         oldSwapchain         windowSize         ghSurface-        ghScreenP+        ghScreenVar     Just old ->       pure old 

@@ -21,7 +21,6 @@ import Vulkan.Dynamic qualified as VkDynamic #endif -import Engine.Camera qualified as Camera import Engine.Setup.Device (allocatePhysical, allocateLogical) import Engine.Setup.Window qualified as Window import Engine.Types (GlobalHandles(..))@@ -79,11 +78,7 @@   logDebug $ "Got command queues: " <> displayShow (fmap (unQueueFamilyIndex . fst) ghQueues)    screen <- liftIO $ Window.getExtent2D ghWindow-  (_screenKey, ghScreenP) <- Worker.registered $-    Worker.spawnCell Camera.mkProjection Camera.ProjectionInput-      { projectionFovRads = τ / 4-      , projectionScreen  = screen-      }+  ghScreenVar <- Worker.newVar screen    ghStageSwitch <- newStageSwitchVar @@ -173,6 +168,3 @@       Khr.KHR_SURFACE_EXTENSION_NAME       minBound   ]--τ :: Float-τ = 2 * pi

@@ -14,12 +14,12 @@ import Vulkan.Utils.QueueAssignment (QueueFamilyIndex(..)) import VulkanMemoryAllocator qualified as VMA -import Engine.Camera (ProjectionProcess) import Engine.Setup.Window (Window) import Engine.Types.RefCounted (RefCounted) import Engine.Vulkan.Swapchain (SwapchainResources(..)) import Engine.Vulkan.Types (HasVulkan(..)) import Engine.Vulkan.Types qualified as Vulkan+import Engine.Worker qualified as Worker  -- * App globals @@ -33,12 +33,12 @@   , ghDevice             :: Vk.Device   , ghAllocator          :: VMA.Allocator   , ghQueues             :: Vulkan.Queues (QueueFamilyIndex, Vk.Queue)-  , ghScreenP            :: ProjectionProcess+  , ghScreenVar          :: Worker.Var Vk.Extent2D   , ghStageSwitch        :: StageSwitchVar   } -getScreenP :: MonadReader (App GlobalHandles s) m => m ProjectionProcess-getScreenP = asks $ ghScreenP . appEnv+askScreenVar :: StageRIO env (Worker.Var Vk.Extent2D)+askScreenVar = asks $ ghScreenVar . appEnv  instance HasVulkan GlobalHandles where   getInstance           = ghInstance

@@ -42,11 +42,9 @@ import Geomancy (Transform, Vec2, Vec4, vec2, vec4, withVec2, pattern WithVec2, pattern WithVec4) import Geomancy.Transform qualified as Transform import Geomancy.Vec4 qualified as Vec4-import RIO.App (appEnv) import Vulkan.Core10 qualified as Vk import Vulkan.NamedType ((:::)) -import Engine.Camera qualified as Camera import Engine.Types qualified as Engine import Engine.Worker qualified as Worker @@ -98,15 +96,13 @@  trackScreen :: Engine.StageRIO st BoxProcess trackScreen = do-  projection <- asks $ Engine.ghScreenP . appEnv-  Worker.spawnMerge1 mkBox (Worker.getInput projection)+  screen <- Engine.askScreenVar+  Worker.spawnMerge1 mkBox screen   where-    mkBox Camera.ProjectionInput{projectionScreen} = Box+    mkBox Vk.Extent2D{width, height} = Box       { boxPosition = 0       , boxSize     = vec2 (fromIntegral width) (fromIntegral height)       }-      where-        Vk.Extent2D{width, height} = projectionScreen  padAbs   :: ( MonadUnliftIO m

@@ -28,7 +28,6 @@ import Vulkan.NamedType ((:::)) import Vulkan.Zero (zero) -import Engine.Camera qualified as Camera import Engine.Types.RefCounted (RefCounted, newRefCounted, releaseRefCounted) import Engine.Vulkan.Types (MonadVulkan, HasVulkan(..), HasSwapchain(..), pdiProperties) import Engine.Worker qualified as Worker@@ -38,7 +37,7 @@   , srImageViews :: Vector Vk.ImageView   , srImages     :: Vector Vk.Image   , srRelease    :: RefCounted-  , srProjection :: Camera.ProjectionProcess+  , srScreenVar  :: Worker.Var Vk.Extent2D   }  data SwapchainInfo = SwapchainInfo@@ -76,10 +75,10 @@   -> Vk.Extent2D   -- ^ If the swapchain size determines the surface size, use this size   -> Khr.SurfaceKHR-  -> Camera.ProjectionProcess+  -> Worker.Var Vk.Extent2D   -> RIO env SwapchainResources   -- -> ResourceT (RIO env) SwapchainResources-allocSwapchainResources oldSwapchain windowSize surface projectionP = do+allocSwapchainResources oldSwapchain windowSize surface screenVar = do   logDebug "Allocating swapchain resources"    device <- asks getDevice@@ -98,16 +97,14 @@     traverse_ release imageViewKeys     release siSwapchainReleaseKey -  Worker.pushInput projectionP \input -> input-    { Camera.projectionScreen = windowSize-    }+  Worker.pushInput screenVar $ const windowSize    pure SwapchainResources     { srInfo       = info     , srImageViews = imageViews     , srImages     = swapchainImages     , srRelease    = releaseResources-    , srProjection = projectionP+    , srScreenVar  = screenVar     }  recreateSwapchainResources@@ -121,10 +118,10 @@   -> RIO env SwapchainResources recreateSwapchainResources windowSize oldResources = do   sr <- allocSwapchainResources-      (siSwapchain $ srInfo oldResources)-      windowSize-      (siSurface $ srInfo oldResources)-      (srProjection oldResources)+    (siSwapchain $ srInfo oldResources)+    windowSize+    (siSurface $ srInfo oldResources)+    (srScreenVar oldResources)   releaseRefCounted (srRelease oldResources)   pure sr 

@@ -26,7 +26,7 @@   , getOutputData   , getOutputDataSTM -  , Cell(..)+  , Cell   , spawnCell    , Timed(..)@@ -139,6 +139,10 @@   type GetInput (TVar (Versioned a)) = a   getInput = id +instance HasInput (Cell i o) where+  type GetInput (Cell i o) = i+  getInput = getInput . fst+ {-# INLINEABLE pushInput #-} pushInput   :: (MonadIO m, HasInput var)@@ -214,6 +218,10 @@   type GetOutput (TVar (Versioned a)) = a   getOutput = id +instance HasOutput (Var i, Merge o) where+  type GetOutput (Var i, Merge o) = o+  getOutput = getOutput . snd+ {-# INLINEABLE pushOutput #-} pushOutput   :: (MonadIO m, HasOutput var)@@ -275,48 +283,17 @@ -- * Suppply  -- | Updatable cell for composite input or costly output.-data Cell input output = Cell-  { cWorker :: ThreadId-  , cInput  :: Var input-  , cOutput :: Var output-  }--instance HasInput (Cell i o) where-  type GetInput (Cell i o) = i-  getInput = cInput--instance HasOutput (Cell i o) where-  type GetOutput (Cell i o) = o-  getOutput = cOutput+type Cell input output = (Var input, Merge output)  spawnCell   :: MonadUnliftIO m   => (input -> output)   -> input   -> m (Cell input output)-spawnCell f initial = do-  input <- newVar initial--  output <- newVar (f initial)--  worker <- forkIO $-    forever $ atomically do-      next <- readTVar input-      old <- readTVar output--      if Unboxed.head (vVersion next) > Unboxed.head (vVersion old) then-        writeTVar output Versioned-          { vVersion = vVersion next-          , vData    = f (vData next)-          }-      else-        retrySTM--  pure Cell-    { cWorker = worker-    , cInput  = input-    , cOutput = output-    }+spawnCell f initialInput = do+  input <- newVar initialInput+  fmap (input,) $+    spawnMerge1 f input  -- | Timer-driven stateful producer. data Timed config output = Timed@@ -674,7 +651,7 @@   getWorker :: a -> ThreadId  instance HasWorker (Cell i o) where-  getWorker = cWorker+  getWorker = mWorker . snd  instance HasWorker (Timed c o) where   getWorker = tWorker