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 :: forall env. ViewOrbitalInput -> RIO env ViewProcess
spawnViewOrbital = (ViewOrbitalInput -> View)
-> ViewOrbitalInput -> RIO env ViewProcess
forall (m :: * -> *) input output.
MonadUnliftIO m =>
(input -> output) -> input -> m (Cell input output)
Worker.spawnCell ViewOrbitalInput -> View
Camera.mkViewOrbital_

data Controls a = Controls
  { forall a. Controls a -> a
panHorizontal   :: a
  , forall a. Controls a -> a
panVertical     :: a
  , forall a. Controls a -> a
turnAzimuth     :: a
  , forall a. Controls a -> a
turnInclination :: a
  }
  deriving ((forall a b. (a -> b) -> Controls a -> Controls b)
-> (forall a b. a -> Controls b -> Controls a) -> Functor Controls
forall a b. a -> Controls b -> Controls a
forall a b. (a -> b) -> Controls a -> Controls b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Controls b -> Controls a
$c<$ :: forall a b. a -> Controls b -> Controls a
fmap :: forall a b. (a -> b) -> Controls a -> Controls b
$cfmap :: forall a b. (a -> b) -> Controls a -> Controls b
Functor, (forall m. Monoid m => Controls m -> m)
-> (forall m a. Monoid m => (a -> m) -> Controls a -> m)
-> (forall m a. Monoid m => (a -> m) -> Controls a -> m)
-> (forall a b. (a -> b -> b) -> b -> Controls a -> b)
-> (forall a b. (a -> b -> b) -> b -> Controls a -> b)
-> (forall b a. (b -> a -> b) -> b -> Controls a -> b)
-> (forall b a. (b -> a -> b) -> b -> Controls a -> b)
-> (forall a. (a -> a -> a) -> Controls a -> a)
-> (forall a. (a -> a -> a) -> Controls a -> a)
-> (forall a. Controls a -> [a])
-> (forall a. Controls a -> Bool)
-> (forall a. Controls a -> Int)
-> (forall a. Eq a => a -> Controls a -> Bool)
-> (forall a. Ord a => Controls a -> a)
-> (forall a. Ord a => Controls a -> a)
-> (forall a. Num a => Controls a -> a)
-> (forall a. Num a => Controls a -> a)
-> Foldable Controls
forall a. Eq a => a -> Controls a -> Bool
forall a. Num a => Controls a -> a
forall a. Ord a => Controls a -> a
forall m. Monoid m => Controls m -> m
forall a. Controls a -> Bool
forall a. Controls a -> Int
forall a. Controls a -> [a]
forall a. (a -> a -> a) -> Controls a -> a
forall m a. Monoid m => (a -> m) -> Controls a -> m
forall b a. (b -> a -> b) -> b -> Controls a -> b
forall a b. (a -> b -> b) -> b -> Controls a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: forall a. Num a => Controls a -> a
$cproduct :: forall a. Num a => Controls a -> a
sum :: forall a. Num a => Controls a -> a
$csum :: forall a. Num a => Controls a -> a
minimum :: forall a. Ord a => Controls a -> a
$cminimum :: forall a. Ord a => Controls a -> a
maximum :: forall a. Ord a => Controls a -> a
$cmaximum :: forall a. Ord a => Controls a -> a
elem :: forall a. Eq a => a -> Controls a -> Bool
$celem :: forall a. Eq a => a -> Controls a -> Bool
length :: forall a. Controls a -> Int
$clength :: forall a. Controls a -> Int
null :: forall a. Controls a -> Bool
$cnull :: forall a. Controls a -> Bool
toList :: forall a. Controls a -> [a]
$ctoList :: forall a. Controls a -> [a]
foldl1 :: forall a. (a -> a -> a) -> Controls a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Controls a -> a
foldr1 :: forall a. (a -> a -> a) -> Controls a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> Controls a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> Controls a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Controls a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Controls a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Controls a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Controls a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Controls a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Controls a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> Controls a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> Controls a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Controls a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Controls a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Controls a -> m
fold :: forall m. Monoid m => Controls m -> m
$cfold :: forall m. Monoid m => Controls m -> m
Foldable, Functor Controls
Foldable Controls
Functor Controls
-> Foldable Controls
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> Controls a -> f (Controls b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    Controls (f a) -> f (Controls a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> Controls a -> m (Controls b))
-> (forall (m :: * -> *) a.
    Monad m =>
    Controls (m a) -> m (Controls a))
-> Traversable Controls
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => Controls (m a) -> m (Controls a)
forall (f :: * -> *) a.
Applicative f =>
Controls (f a) -> f (Controls a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Controls a -> m (Controls b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Controls a -> f (Controls b)
sequence :: forall (m :: * -> *) a. Monad m => Controls (m a) -> m (Controls a)
$csequence :: forall (m :: * -> *) a. Monad m => Controls (m a) -> m (Controls a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Controls a -> m (Controls b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Controls a -> m (Controls b)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
Controls (f a) -> f (Controls a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
Controls (f a) -> f (Controls a)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Controls a -> f (Controls b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Controls a -> f (Controls b)
Traversable)

type ControlsProcess = Controls (Worker.Timed Float ())

spawnControls :: Camera.ViewProcess -> RIO env ControlsProcess
spawnControls :: forall env. ViewProcess -> RIO env ControlsProcess
spawnControls ViewProcess
vp =
  ((Float -> Float -> ViewOrbitalInput -> ViewOrbitalInput)
 -> RIO env (Timed Float ()))
-> Controls
     (Float -> Float -> ViewOrbitalInput -> ViewOrbitalInput)
-> RIO env ControlsProcess
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Float -> Float -> ViewOrbitalInput -> ViewOrbitalInput)
-> RIO env (Timed Float ())
mkUpdater Controls :: forall a. a -> a -> a -> a -> Controls a
Controls
    { $sel:panHorizontal:Controls :: Float -> Float -> ViewOrbitalInput -> ViewOrbitalInput
panHorizontal   = Float -> Float -> ViewOrbitalInput -> ViewOrbitalInput
panTargetHorizontal
    , $sel:panVertical:Controls :: Float -> Float -> ViewOrbitalInput -> ViewOrbitalInput
panVertical     = Float -> Float -> ViewOrbitalInput -> ViewOrbitalInput
panTargetVertical
    , $sel:turnAzimuth:Controls :: Float -> Float -> ViewOrbitalInput -> ViewOrbitalInput
turnAzimuth     = Float -> Float -> ViewOrbitalInput -> ViewOrbitalInput
forall {p}. p -> Float -> ViewOrbitalInput -> ViewOrbitalInput
orbitAzimuthTurn
    , $sel:turnInclination:Controls :: Float -> Float -> ViewOrbitalInput -> ViewOrbitalInput
turnInclination = Float -> Float -> ViewOrbitalInput -> ViewOrbitalInput
forall {p}. p -> Float -> ViewOrbitalInput -> ViewOrbitalInput
orbitAscentTurn
    }
  where
    vpInput :: Var (GetInput ViewProcess)
vpInput = ViewProcess -> Var (GetInput ViewProcess)
forall a. HasInput a => a -> Var (GetInput a)
Worker.getInput ViewProcess
vp

    dtI :: Int
dtI = Int
1e3
    dt :: Float
dt = Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
dtI Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
1e6

    mkUpdater :: (Float -> Float -> ViewOrbitalInput -> ViewOrbitalInput)
-> RIO env (Timed Float ())
mkUpdater Float -> Float -> ViewOrbitalInput -> ViewOrbitalInput
updater =
      Bool
-> Either Int (Float -> Int)
-> (Float -> RIO env ((), Float))
-> (Float -> Float -> RIO env (Maybe (), Float))
-> Float
-> RIO env (Timed Float ())
forall (m :: * -> *) config output state.
MonadUnliftIO m =>
Bool
-> Either Int (config -> Int)
-> (config -> m (output, state))
-> (state -> config -> m (Maybe output, state))
-> config
-> m (Timed config output)
Worker.spawnTimed
        Bool
True
        (Int -> Either Int (Float -> Int)
forall a b. a -> Either a b
Left Int
dtI)
        (\Float
_delta -> ((), Float) -> RIO env ((), Float)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((), Float
0.0))
        (\Float
acceleration Float
delta -> do
            Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Float
delta Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
/= Float
0) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
              Var ViewOrbitalInput
-> (GetInput (Var ViewOrbitalInput)
    -> GetInput (Var ViewOrbitalInput))
-> RIO env ()
forall (m :: * -> *) var.
(MonadIO m, HasInput var) =>
var -> (GetInput var -> GetInput var) -> m ()
Worker.pushInput Var (GetInput ViewProcess)
Var ViewOrbitalInput
vpInput ((GetInput (Var ViewOrbitalInput)
  -> GetInput (Var ViewOrbitalInput))
 -> RIO env ())
-> (GetInput (Var ViewOrbitalInput)
    -> GetInput (Var ViewOrbitalInput))
-> RIO env ()
forall a b. (a -> b) -> a -> b
$
                Float -> Float -> ViewOrbitalInput -> ViewOrbitalInput
updater (Float
1 Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
acceleration) (Float
delta Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
dt)
            pure
              ( Maybe ()
forall a. Maybe a
Nothing
              , if Float
delta Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
== Float
0 then
                  if Float
acceleration Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
< Float
1Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/Float
128 then
                    Float
acceleration
                  else
                    Float
acceleration Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
0.97
                else
                  Float
acceleration Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
0.01
              )
        )
        Float
0

    panTargetHorizontal :: Float -> Float -> ViewOrbitalInput -> ViewOrbitalInput
panTargetHorizontal Float
acceleration Float
delta ViewOrbitalInput
voi = ViewOrbitalInput
voi
      { $sel:orbitTarget:ViewOrbitalInput :: Vec3
Camera.orbitTarget = ViewOrbitalInput -> Vec3
Camera.orbitTarget ViewOrbitalInput
voi Vec3 -> Vec3 -> Vec3
forall a. Num a => a -> a -> a
+ Vec3
pan
      }
      where
        pan :: Vec3
pan = Quaternion -> Vec3 -> Vec3
Quaternion.rotate
          (Vec3 -> Float -> Quaternion
Quaternion.axisAngle Vec3
up Float
azimuth)
          (Float -> Float -> Float -> Vec3
vec3 (Float
delta Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
acceleration) Float
0 Float
0)
        up :: Vec3
up = ViewOrbitalInput -> Vec3
Camera.orbitUp ViewOrbitalInput
voi
        azimuth :: Float
azimuth = ViewOrbitalInput -> Float
Camera.orbitAzimuth ViewOrbitalInput
voi

    panTargetVertical :: Float -> Float -> ViewOrbitalInput -> ViewOrbitalInput
panTargetVertical Float
acceleration Float
delta ViewOrbitalInput
voi = ViewOrbitalInput
voi
      { $sel:orbitTarget:ViewOrbitalInput :: Vec3
Camera.orbitTarget = ViewOrbitalInput -> Vec3
Camera.orbitTarget ViewOrbitalInput
voi Vec3 -> Vec3 -> Vec3
forall a. Num a => a -> a -> a
+ Vec3
pan
      }
      where
        pan :: Vec3
pan =
          Quaternion -> Vec3 -> Vec3
Quaternion.rotate
            (Vec3 -> Float -> Quaternion
Quaternion.axisAngle Vec3
up Float
azimuth)
            (Float -> Float -> Float -> Vec3
vec3 Float
0 Float
0 (Float
delta Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
acceleration))

        up :: Vec3
up = ViewOrbitalInput -> Vec3
Camera.orbitUp ViewOrbitalInput
voi
        azimuth :: Float
azimuth = ViewOrbitalInput -> Float
Camera.orbitAzimuth ViewOrbitalInput
voi

    orbitAzimuthTurn :: p -> Float -> ViewOrbitalInput -> ViewOrbitalInput
orbitAzimuthTurn p
_acceleration Float
delta ViewOrbitalInput
voi = ViewOrbitalInput
voi
      { $sel:orbitAzimuth:ViewOrbitalInput :: Float
Camera.orbitAzimuth = Float
azimuth
      }
      where
        azimuth :: Float
azimuth
          | Float
azimuth' Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
< (-Float
τ) = Float
azimuth' Float -> Float -> Float
forall a. Num a => a -> a -> a
+ (Float
2 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
τ)
          | Float
azimuth' Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
τ = Float
azimuth' Float -> Float -> Float
forall a. Num a => a -> a -> a
- (Float
2 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
τ)
          | Bool
otherwise = Float
azimuth'

        azimuth' :: Float
azimuth' = ViewOrbitalInput -> Float
Camera.orbitAzimuth ViewOrbitalInput
voi Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
delta

    orbitAscentTurn :: p -> Float -> ViewOrbitalInput -> ViewOrbitalInput
orbitAscentTurn p
_acceleration Float
delta ViewOrbitalInput
voi = ViewOrbitalInput
voi
      { $sel:orbitAscent:ViewOrbitalInput :: Float
Camera.orbitAscent = Float
ascent
      }
      where
        ascent :: Float
ascent =
          Float -> Float -> Float
forall a. Ord a => a -> a -> a
max (-Float
limit) (Float -> Float) -> (Float -> Float) -> Float -> Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
limit (Float -> Float) -> Float -> Float
forall a b. (a -> b) -> a -> b
$
            ViewOrbitalInput -> Float
Camera.orbitAscent ViewOrbitalInput
voi Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
delta

        limit :: Float
limit = Float
τFloat -> Float -> Float
forall a. Fractional a => a -> a -> a
/Float
4 Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
1Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/Float
512

panInstant :: MonadIO m => Camera.ViewProcess -> Vec3 -> m ()
panInstant :: forall (m :: * -> *). MonadIO m => ViewProcess -> Vec3 -> m ()
panInstant ViewProcess
vp Vec3
delta3 = do
  ViewProcess
-> (GetInput ViewProcess -> GetInput ViewProcess) -> m ()
forall (m :: * -> *) var.
(MonadIO m, HasInput var) =>
var -> (GetInput var -> GetInput var) -> m ()
Worker.pushInput ViewProcess
vp \voi :: GetInput ViewProcess
voi@Camera.ViewOrbitalInput{Float
Vec3
$sel:orbitRight:ViewOrbitalInput :: ViewOrbitalInput -> Vec3
$sel:orbitScale:ViewOrbitalInput :: ViewOrbitalInput -> Float
$sel:orbitDistance:ViewOrbitalInput :: ViewOrbitalInput -> Float
orbitRight :: Vec3
orbitUp :: Vec3
orbitTarget :: Vec3
orbitScale :: Float
orbitDistance :: Float
orbitAscent :: Float
orbitAzimuth :: Float
$sel:orbitAscent:ViewOrbitalInput :: ViewOrbitalInput -> Float
$sel:orbitAzimuth:ViewOrbitalInput :: ViewOrbitalInput -> Float
$sel:orbitUp:ViewOrbitalInput :: ViewOrbitalInput -> Vec3
$sel:orbitTarget:ViewOrbitalInput :: ViewOrbitalInput -> Vec3
..} ->
    let
      pan :: Float -> Vec3
pan Float
azimuth = Quaternion -> Vec3 -> Vec3
Quaternion.rotate
        (Vec3 -> Float -> Quaternion
Quaternion.axisAngle Vec3
orbitUp Float
azimuth)
        Vec3
delta3 Vec3 -> Vec3 -> Vec3
forall a. Num a => a -> a -> a
* Vec3
0.01
    in
      GetInput ViewProcess
ViewOrbitalInput
voi
        { $sel:orbitTarget:ViewOrbitalInput :: Vec3
Camera.orbitTarget =
            ViewOrbitalInput -> Vec3
Camera.orbitTarget GetInput ViewProcess
ViewOrbitalInput
voi Vec3 -> Vec3 -> Vec3
forall a. Num a => a -> a -> a
+ Float -> Vec3
pan Float
orbitAzimuth
        }

τ :: Float
τ :: Float
τ = Float
2 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
forall a. Floating a => a
pi