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