geomancy-0.2.2.3: src/Geomancy/Vec4.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}

-- | Specialized and inlined @V4 Float@.

module Geomancy.Vec4
  ( Vec4
  , vec4
  , withVec4
  , pattern WithVec4
  , fromVec2
  , fromVec22
  , fromVec3
  , fromTuple

  , (^*)
  , (^/)
  , lerp

  , dot
  , normalize
  ) where

import Control.DeepSeq (NFData(rnf))
import Data.Coerce (Coercible, coerce)
import Foreign (Storable(..), castPtr)

import Geomancy.Vec2 (Vec2, withVec2)
import Geomancy.Vec3 (Vec3, withVec3)

data Vec4 = Vec4
  {-# UNPACK #-} !Float
  {-# UNPACK #-} !Float
  {-# UNPACK #-} !Float
  {-# UNPACK #-} !Float
  deriving (Eq, Ord, Show)

{-# INLINE vec4 #-}
vec4 :: Float -> Float -> Float -> Float -> Vec4
vec4 = Vec4

{-# INLINE withVec4 #-}
withVec4
  :: Vec4
  -> (Float -> Float -> Float -> Float -> r)
  -> r
withVec4 (Vec4 a b c d) f = f a b c d

pattern WithVec4 :: Float -> Float -> Float -> Float -> Vec4
pattern WithVec4 a b c d <- ((`withVec4` (,,,)) -> (a, b, c, d))
{-# COMPLETE WithVec4 #-}

{-# INLINE fromVec2 #-}
fromVec2 :: Vec2 -> Float -> Float -> Vec4
fromVec2 xy z w =
  withVec2 xy \x y ->
    vec4 x y z w

{-# INLINE fromVec22 #-}
fromVec22 :: Vec2 -> Vec2 -> Vec4
fromVec22 xy zw =
  withVec2 xy \x y ->
  withVec2 zw \z w ->
    vec4 x y z w

{-# INLINE fromVec3 #-}
fromVec3 :: Coercible a Vec3 => a -> Float -> Vec4
fromVec3 xyz w =
  withVec3 (coerce xyz) \x y z ->
    vec4 x y z w

{-# INLINE fromTuple #-}
fromTuple :: (Float, Float, Float, Float) -> Vec4
fromTuple (x, y, z, w) = vec4 x y z w

instance NFData Vec4 where
  rnf Vec4{} = ()

instance Num Vec4 where
  {-# INLINE (+) #-}
  Vec4 l1 l2 l3 l4 + Vec4 r1 r2 r3 r4 =
    Vec4
      (l1 + r1)
      (l2 + r2)
      (l3 + r3)
      (l4 + r4)

  {-# INLINE (-) #-}
  Vec4 l1 l2 l3 l4 - Vec4 r1 r2 r3 r4 =
    Vec4
      (l1 - r1)
      (l2 - r2)
      (l3 - r3)
      (l4 - r4)

  {-# INLINE (*) #-}
  Vec4 l1 l2 l3 l4 * Vec4 r1 r2 r3 r4 =
    Vec4
      (l1 * r1)
      (l2 * r2)
      (l3 * r3)
      (l4 * r4)

  {-# INLINE abs #-}
  abs (Vec4 a b c d) =
    Vec4 (abs a) (abs b) (abs c) (abs d)

  {-# INLINE signum #-}
  signum (Vec4 a b c d) =
    Vec4 (signum a) (signum b) (signum c) (signum d)

  {-# INLINE fromInteger #-}
  fromInteger x = Vec4 x' x' x' x'
    where
      x' = fromInteger x

instance Fractional Vec4 where
  {-# INLINE (/) #-}
  Vec4 l1 l2 l3 l4 / Vec4 r1 r2 r3 r4 =
    Vec4 (l1 / r1) (l2 / r2) (l3 / r3) (l4 / r4)

  {-# INLINE recip #-}
  recip (Vec4 a b c d) =
    Vec4 (recip a) (recip b) (recip c) (recip d)

  {-# INLINE fromRational #-}
  fromRational x = Vec4 x' x' x' x'
    where
      x' = fromRational x

instance Storable Vec4 where
  {-# INLINE sizeOf #-}
  sizeOf _ = 16

  {-# INLINE alignment #-}
  alignment _ = 16

  {-# INLINE poke #-}
  poke ptr v4 =
    withVec4 v4 \a b c d -> do
      poke ptr' a
      pokeElemOff ptr' 1 b
      pokeElemOff ptr' 2 c
      pokeElemOff ptr' 3 d
    where
      ptr' = castPtr ptr

  {-# INLINE peek #-}
  peek ptr = vec4
    <$> peek ptr'
    <*> peekElemOff ptr' 1
    <*> peekElemOff ptr' 2
    <*> peekElemOff ptr' 3
    where
      ptr' = castPtr ptr

{-# INLINE (^*) #-}
(^*) :: Vec4 -> Float -> Vec4
Vec4 a b c d ^* x =
  Vec4
    (a * x)
    (b * x)
    (c * x)
    (d * x)

{-# INLINE (^/) #-}
(^/) :: Vec4 -> Float -> Vec4
Vec4 a b c d ^/ x =
  Vec4
    (a / x)
    (b / x)
    (c / x)
    (d / x)

{-# INLINE lerp #-}
lerp :: Float -> Vec4 -> Vec4 -> Vec4
lerp alpha u v = u ^* alpha + v ^* (1 - alpha)

{-# INLINE dot #-}
dot :: Vec4 -> Vec4 -> Float
dot (Vec4 l1 l2 l3 l4) (Vec4 r1 r2 r3 r4) =
  l1 * r1 +
  l2 * r2 +
  l3 * r3 +
  l4 * r4

{-# INLINE normalize #-}
normalize :: Vec4 -> Vec4
normalize v =
  if nearZero q || nearZero (1-q) then
    v
  else
    let
      Vec4 x y z w = v
    in
      Vec4 (x / l) (y / l) (z / l) (w / l)

  where
    q = dot v v
    l = sqrt q

    nearZero a = abs a <= 1e-6