Camera.hs

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)
import Geomancy.Transform qualified as Transform
import Geomancy.Quaternion qualified as Quaternion
import Geomancy.Vec3 qualified as Vec3
import Geomancy.Vulkan.Projection qualified as Projection
import Geomancy.Vulkan.View qualified as View
import RIO.App (App)
import UnliftIO.Resource (MonadResource)
import Vulkan.Core10 qualified as Vk
import Vulkan.NamedType ((:::))

import Engine.Types qualified as Engine
import Engine.Worker qualified as Worker

-- * Projection

data ProjectionKind
  = Perspective
  | Orthographic
  deriving (Eq, Ord, Show, Enum, Bounded, Generic)

data Projection (pk :: ProjectionKind) = Projection
  { projectionTransform :: Transform
  , projectionInverse   :: ~Transform
  }
  deriving (Show, Generic)

type ProjectionProcess pk = Worker.Cell (ProjectionInput pk) (Projection pk)

data ProjectionInput (pk :: ProjectionKind) = ProjectionInput
  { projectionParams :: ProjectionParams pk
  , projectionNear   :: Float
  , projectionFar    :: Float
  }

-- XXX: undecidable
-- deriving instance (Show (ProjectionParams pk)) => Show (ProjectionInput pk)

type family ProjectionParams (pk :: ProjectionKind) where
  ProjectionParams 'Perspective = "fov-v" ::: Float
  ProjectionParams 'Orthographic = ()

spawnProjection
  :: ( MonadReader (App Engine.GlobalHandles st) m
     , MonadResource m
     , MonadUnliftIO m
     )
  => (Vk.Extent2D -> ProjectionInput pk -> Transform)
  -> ProjectionParams pk
  -> m (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

pattern PROJECTION_FAR :: (Eq a, Num a) => a
pattern PROJECTION_FAR = 16384

spawnProjectionWith
  :: ( MonadReader (App Engine.GlobalHandles st) m
     , MonadResource m
     , MonadUnliftIO m
     )
  => (Vk.Extent2D -> ProjectionInput pk -> Transform)
  -> ProjectionInput pk
  -> m (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
  :: ( MonadReader (App Engine.GlobalHandles st) m
     , MonadResource m
     , MonadUnliftIO m
     )
  => m (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
  :: ( MonadReader (App Engine.GlobalHandles st) m
     , MonadResource m
     , MonadUnliftIO m
     )
  => m (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
  { viewTransform    :: Transform
  , viewTransformInv :: Transform
  , viewPosition     :: Vec3
  , viewDirection    :: Vec3
  }
  deriving (Show)

type ViewProcess = Worker.Cell ViewOrbitalInput View

-- | Camera orbiting its target
data ViewOrbitalInput = ViewOrbitalInput
  { orbitAzimuth  :: Float
  , orbitAscent   :: Float
  , 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 orbitUp
    viewTransformInv = Transform.inverse viewTransform

    viewPosition =
      orbitTarget +
      Quaternion.rotate
        ( Quaternion.axisAngle orbitUp orbitAzimuth *
          Quaternion.axisAngle orbitRight orbitAscent
        )
        (vec3 0 0 $ orbitDistance * orbitScale)

    viewDirection = Vec3.normalize $ cameraTarget - viewPosition

{-# INLINE mkViewOrbital_ #-}
mkViewOrbital_ :: ViewOrbitalInput -> View
mkViewOrbital_ voi = mkViewOrbital (orbitTarget voi) voi

τ :: Float
τ = 2 * pi