Vector.hs

{-# LANGUAGE ImpredicativeTypes #-}

-- | Vector operations in orthonormal Euclidean spaces
module Mini.Linear.Vector (
  -- * Class
  Vector (
    axes
  ),

  -- * Construction
  basis,
  e,
  zero,

  -- * Operations
  (^+^),
  (^-^),
  (~*^),
  cross,
  dot,
  hat,
  norm,
  onto,

  -- * Interpolation
  lerp,
) where

import Control.Applicative (
  liftA2,
 )
import Mini.Linear.Space (
  V0 (V0),
  V1 (V1),
  V2 (V2),
  V3 (V3),
  V4 (V4),
  w,
  x,
  y,
  yzx,
  z,
  zxy,
 )
import Mini.Optics.Lens (
  Lens,
  set,
  view,
 )
import Prelude (
  Applicative,
  Floating,
  Foldable,
  Fractional,
  Num,
  fmap,
  pure,
  recip,
  sqrt,
  sum,
  ($),
  (*),
  (+),
  (-),
  (/),
 )

-- Class

-- | The class of vectors
class (Applicative v, Foldable v) => Vector v where
  -- | Basis vector lenses
  axes :: v (Lens (v a) (v a) a a)

instance Vector V0 where
  axes = V0

instance Vector V1 where
  axes = V1 x

instance Vector V2 where
  axes = V2 x y

instance Vector V3 where
  axes = V3 x y z

instance Vector V4 where
  axes = V4 x y z w

-- Construction

-- | Standard basis
basis :: (Vector v, Num a) => v (v a)
basis = fmap e axes

-- | Make a basis vector from a basis vector lens
e :: (Vector v, Num a) => Lens (v a) (v a) a a -> v a
e o = set o 1 zero

-- | Additive identity vector
zero :: (Vector v, Num a) => v a
zero = pure 0

-- Operations

infixl 6 ^+^

-- | Vector-vector addition
(^+^) :: (Vector v, Num a) => v a -> v a -> v a
(^+^) = liftA2 (+)

infixl 6 ^-^

-- | Vector-vector subtraction
(^-^) :: (Vector v, Num a) => v a -> v a -> v a
(^-^) = liftA2 (-)

infixl 7 ~*^

-- | Scalar-vector multiplication
(~*^) :: (Vector v, Num a) => a -> v a -> v a
s ~*^ v = fmap (s *) v

-- | Cross product
cross :: (Num a) => V3 a -> V3 a -> V3 a
cross u v =
  (^-^)
    (liftA2 (*) (view yzx u) (view zxy v))
    (liftA2 (*) (view zxy u) (view yzx v))

-- | Dot product
dot :: (Vector v, Num a) => v a -> v a -> a
dot u v = sum $ liftA2 (*) u v

-- | Adapt a vector /v/ to have unit norm (assumes @not $ v ~= zero@)
hat :: (Vector v, Floating a) => v a -> v a
hat u = recip (norm u) ~*^ u

-- | Norm of a vector
norm :: (Vector v, Floating a) => v a -> a
norm u = sqrt $ u `dot` u

-- | Project a vector onto a vector /v/ (assumes @not $ v ~= zero@)
onto :: (Vector v, Fractional a) => v a -> v a -> v a
onto u v = (u `dot` v) / (v `dot` v) ~*^ v

-- Interpolation

-- | Linear interpolation s.t. @lerp u v 0 == u && lerp u v 1 == v@
lerp :: (Vector v, Num a) => v a -> v a -> a -> v a
lerp u v t = (1 - t) ~*^ u ^+^ t ~*^ v