diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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. diff --git a/keid-core.cabal b/keid-core.cabal --- a/keid-core.cabal +++ b/keid-core.cabal @@ -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 diff --git a/src/Engine/Camera.hs b/src/Engine/Camera.hs --- a/src/Engine/Camera.hs +++ b/src/Engine/Camera.hs @@ -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 diff --git a/src/Engine/Camera/Controls.hs b/src/Engine/Camera/Controls.hs new file mode 100644 --- /dev/null +++ b/src/Engine/Camera/Controls.hs @@ -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 diff --git a/src/Engine/Camera/Event/Handler.hs b/src/Engine/Camera/Event/Handler.hs new file mode 100644 --- /dev/null +++ b/src/Engine/Camera/Event/Handler.hs @@ -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 diff --git a/src/Engine/Camera/Event/Type.hs b/src/Engine/Camera/Event/Type.hs new file mode 100644 --- /dev/null +++ b/src/Engine/Camera/Event/Type.hs @@ -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) diff --git a/src/Engine/Events/CursorPos.hs b/src/Engine/Events/CursorPos.hs --- a/src/Engine/Events/CursorPos.hs +++ b/src/Engine/Events/CursorPos.hs @@ -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 diff --git a/src/Engine/Frame.hs b/src/Engine/Frame.hs --- a/src/Engine/Frame.hs +++ b/src/Engine/Frame.hs @@ -51,7 +51,7 @@ oldSwapchain windowSize ghSurface - ghScreenP + ghScreenVar Just old -> pure old diff --git a/src/Engine/Setup.hs b/src/Engine/Setup.hs --- a/src/Engine/Setup.hs +++ b/src/Engine/Setup.hs @@ -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 diff --git a/src/Engine/Types.hs b/src/Engine/Types.hs --- a/src/Engine/Types.hs +++ b/src/Engine/Types.hs @@ -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 diff --git a/src/Engine/UI/Layout.hs b/src/Engine/UI/Layout.hs --- a/src/Engine/UI/Layout.hs +++ b/src/Engine/UI/Layout.hs @@ -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 diff --git a/src/Engine/Vulkan/Swapchain.hs b/src/Engine/Vulkan/Swapchain.hs --- a/src/Engine/Vulkan/Swapchain.hs +++ b/src/Engine/Vulkan/Swapchain.hs @@ -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 diff --git a/src/Engine/Worker.hs b/src/Engine/Worker.hs --- a/src/Engine/Worker.hs +++ b/src/Engine/Worker.hs @@ -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