Free camera controller from my 3D application. Depends on `reactive-banana>=1.1` and `static-tensor>=0.2.1`

FreeCamera.hs

{-# LANGUAGE
      TypeInType
    , ExplicitForAll
    , ScopedTypeVariables
    , RecursiveDo
    , TypeApplications
    , TemplateHaskell
    , FlexibleInstances
    , MultiParamTypeClasses
    , TypeFamilies
#-}

module FreeCamera where

import Control.Monad.Fix
import Reactive.Banana
import Data.Vector.Static   (Vector, cross, norm, genVectorInstance, toHomogenous, fromHomogenous)
import Data.Tensor.Static   (add, diff, scale)
import Data.Matrix.Static   (Matrix, mult, genMatrixInstance)

$(genVectorInstance 3 ''Float)
$(genVectorInstance 4 ''Float)
$(genMatrixInstance 4 4 ''Float)

-- | Camera
data Camera = Camera 
    { _cameraPosition :: !(Vector 3 Float)  -- ^ Position of the camera.
    , _cameraTarget   :: !(Vector 3 Float)  -- ^ Camera's target point.
    , _cameraUp       :: !(Vector 3 Float)  -- ^ Up vector
    , _cameraFov      :: !Float             -- ^ Field of view.
    }

-- | Create a camera behavior from camera control events.
freeCameraB ::
    forall m.
    ( MonadMoment m
    , MonadFix m
    )
    => Camera           -- ^ Initial camera.
    -> Event Float      -- ^ Yaw rotation (left-right).
    -> Event Float      -- ^ Pitch rotation (down-up).
    -> Event Float      -- ^ Roll rotation.
    -> Event Float      -- ^ Move left-right.
    -> Event Float      -- ^ Move up-down.
    -> Event Float      -- ^ Move forward-backward.
    -> Event Float      -- ^ Changes of camera's FoV.
    -> m (Behavior Camera)
freeCameraB (Camera position0 target0 up0 fov0) yaw pitch roll leftRight upDown fwdBwd fovE = mdo
    let vLeftRight = sampleWith scale left leftRight
        vUpDown    = sampleWith scale up   upDown                 
        vFwdBwd    = sampleWith scale fwd  fwdBwd
        vPos       = unionWith add vFwdBwd (unionWith add vLeftRight vUpDown)

    position <- accumB position0 (add <$> vPos)

    let fwd0     = norm (target0 `diff` position0)
        left     = ((\u f -> norm $ cross u f) <$> up <*> fwd)
        yawMat   = sampleWith rotationMatrix up   (fmap negate yaw)
        pitchMat = sampleWith rotationMatrix left pitch
        rollMat  = sampleWith rotationMatrix fwd  roll
        rotMat   = unionWith mult rollMat (unionWith mult pitchMat yawMat)

    up  <- accumB (norm up0) (fmap (\m v -> norm $ fromHomogenous $ mult m $ toHomogenous v) rotMat)
    fwd <- accumB fwd0       (fmap (\m v -> norm $ fromHomogenous $ mult m $ toHomogenous v) rotMat)
    
    let target = add <$> position <*> fwd

    fov <- accumB fov0 (fmap (+) fovE)

    pure $ Camera <$> position <*> target <*> up <*> fov

-- | Sample value of the 'Behavior' @a@ at instances of the 'Event' @b@ and
--   put them into a tuple.
samplePair :: Behavior a -> Event b -> Event (a, b)
samplePair b e = (,) <$> b <@> e

-- | Sample value of the 'Behavior' @a@ at instances of the 'Event' @b@ and
--   apply given function to them.
sampleWith :: (a -> b -> c) -> Behavior a -> Event b -> Event c
sampleWith f b e = uncurry f <$> samplePair b e

-- | Create a rotation matrix.
rotationMatrix :: Vector 3 Float    -- ^ Axis of the rotation.
               -> Float             -- ^ Angle of the rotation.
               -> Matrix 4 4 Float
rotationMatrix axis a = undefined