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 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
  :: (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

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
  { 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