Vec2.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}

#ifdef TH_LIFT
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE DerivingStrategies #-}
#endif

-- | Specialized and inlined @V2 Float@.

module Geomancy.Vec2
  ( Vec2
  , vec2
  , withVec2
  , pattern WithVec2
  , fromTuple
  , convert

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

  , dot
  , normalize
  ) where

import Control.DeepSeq (NFData(rnf))
import Data.Coerce (Coercible, coerce)
import Data.MonoTraversable (Element, MonoFunctor(..), MonoPointed(..))
import Data.VectorSpace (VectorSpace)
import Foreign (Storable(..))
import Foreign.Ptr.Diff (peekDiffOff, pokeDiffOff)
import qualified Data.VectorSpace as VectorSpace

#ifdef TH_LIFT
import Language.Haskell.TH.Syntax (Lift)
#endif

#ifdef SERIALISE
import Codec.Serialise (Serialise(..))
import qualified Codec.Serialise.Encoding as Serialise
import qualified Codec.Serialise.Decoding as Serialise
#endif

import Geomancy.Elementwise (Elementwise(..))
import Graphics.Gl.Block (Block(..))
import Geomancy.Gl.Funs (GlModf(..), GlNearest)

data Vec2 = Vec2
  {-# UNPACK #-} !Float
  {-# UNPACK #-} !Float
  deriving (Eq, Ord, Show)
#ifdef TH_LIFT
  deriving Lift
#endif

{-# INLINE vec2 #-}
vec2 :: Float -> Float -> Vec2
vec2 = Vec2

{-# INLINE withVec2 #-}
withVec2
  :: Vec2
  -> (Float -> Float -> r)
  -> r
withVec2 (Vec2 a b) f = f a b

{-# INLINE convert #-}
convert :: Coercible v Vec2 => (Float -> a) -> (a -> a -> r) -> v -> r
convert f t v =
  withVec2 (coerce v) \a b ->
    t (f a) (f b)

pattern WithVec2 :: Float -> Float -> Vec2
pattern WithVec2 a b <- ((`withVec2` (,)) -> (a, b))
{-# COMPLETE WithVec2 #-}

{-# INLINE fromTuple #-}
fromTuple :: (Float, Float) -> Vec2
fromTuple (x, y) = vec2 x y

instance NFData Vec2 where
  rnf Vec2{} = ()

type instance Element Vec2 = Float

instance MonoFunctor Vec2 where
  {-# INLINE omap #-}
  omap f v =
    withVec2 v \x y ->
      vec2 (f x) (f y)

instance MonoPointed Vec2 where
  opoint x = vec2 x x

instance Elementwise Vec2 where
  {-# INLINE emap2 #-}
  emap2 f p0 p1 =
    withVec2 p0 \x0 y0 ->
    withVec2 p1 \x1 y1 ->
      vec2
        (f x0 x1)
        (f y0 y1)

  {-# INLINE emap3 #-}
  emap3 f p0 p1 p2 =
    withVec2 p0 \x0 y0 ->
    withVec2 p1 \x1 y1 ->
    withVec2 p2 \x2 y2 ->
      vec2
        (f x0 x1 x2)
        (f y0 y1 y2)

  {-# INLINE emap4 #-}
  emap4 f p0 p1 p2 p3 =
    withVec2 p0 \x0 y0 ->
    withVec2 p1 \x1 y1 ->
    withVec2 p2 \x2 y2 ->
    withVec2 p3 \x3 y3 ->
      vec2
        (f x0 x1 x2 x3)
        (f y0 y1 y2 y3)

  {-# INLINE emap5 #-}
  emap5 f p0 p1 p2 p3 p4 =
    withVec2 p0 \x0 y0 ->
    withVec2 p1 \x1 y1 ->
    withVec2 p2 \x2 y2 ->
    withVec2 p3 \x3 y3 ->
    withVec2 p4 \x4 y4 ->
      vec2
        (f x0 x1 x2 x3 x4)
        (f y0 y1 y2 y3 y4)

instance Num Vec2 where
  {-# INLINE (+) #-}
  Vec2 l1 l2 + Vec2 r1 r2 =
    Vec2
      (l1 + r1)
      (l2 + r2)

  {-# INLINE (-) #-}
  Vec2 l1 l2 - Vec2 r1 r2 =
    Vec2
      (l1 - r1)
      (l2 - r2)

  {-# INLINE (*) #-}
  Vec2 l1 l2 * Vec2 r1 r2 =
    Vec2
      (l1 * r1)
      (l2 * r2)

  {-# INLINE abs #-}
  abs (Vec2 a b) =
    Vec2 (abs a) (abs b)

  {-# INLINE signum #-}
  signum (Vec2 a b) =
    Vec2 (signum a) (signum b)

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

instance Fractional Vec2 where
  {-# INLINE (/) #-}
  Vec2 l1 l2 / Vec2 r1 r2 =
    Vec2 (l1 / r1) (l2 / r2)

  {-# INLINE recip #-}
  recip (Vec2 a b) =
    Vec2 (recip a) (recip b)

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

instance Floating Vec2 where
  pi = opoint pi

  exp = omap exp
  log = omap log
  sqrt = omap sqrt
  sin = omap sin
  cos = omap cos
  asin = omap asin
  acos = omap acos
  atan = omap atan
  sinh = omap sinh
  cosh = omap cosh
  asinh = omap asinh
  acosh = omap acosh
  atanh = omap atanh

  (**) = emap2 (**)

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

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

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

{-# INLINE dot #-}
dot :: Vec2 -> Vec2 -> Float
dot (Vec2 l1 l2) (Vec2 r1 r2) =
  l1 * r1 + l2 * r2

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

  where
    q = dot v v
    l = sqrt q

    nearZero a = abs a <= 1e-6

instance Storable Vec2 where
  {-# INLINE sizeOf #-}
  sizeOf _ = 8

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

  {-# INLINE poke #-}
  poke ptr v4 =
    withVec2 v4 \a b -> do
      pokeByteOff ptr 0 a
      pokeByteOff ptr 4 b

  {-# INLINE peek #-}
  peek ptr = vec2
    <$> peekByteOff ptr 0
    <*> peekByteOff ptr 4

instance Block Vec2 where
  type PackedSize Vec2 = 8
  alignment140 _  = 8
  sizeOf140 _     = 8
  alignment430    = alignment140
  sizeOf430       = sizeOf140
  isStruct _      = False
  read140     = peekDiffOff
  write140    = pokeDiffOff
  read430     = read140
  write430    = write140
  readPacked  = read140
  writePacked = write140
  {-# INLINE alignment140 #-}
  {-# INLINE sizeOf140 #-}
  {-# INLINE alignment430 #-}
  {-# INLINE sizeOf430 #-}
  {-# INLINE isStruct #-}
  {-# INLINE read140 #-}
  {-# INLINE write140 #-}
  {-# INLINE read430 #-}
  {-# INLINE write430 #-}
  {-# INLINE readPacked #-}
  {-# INLINE writePacked #-}

#ifdef SERIALISE
instance Serialise Vec2 where
  encode v = withVec2 v \x y ->
    Serialise.encodeListLen 2 <> encode x <> encode y
  decode =
    Serialise.decodeListLenOf 2 *> (vec2 <$> decode <*> decode)
#endif

instance VectorSpace Vec2 Float where
  zeroVector = epoint 0

  {-# INLINE (*^) #-}
  a *^ v = v Geomancy.Vec2.^* a

  {-# INLINE (^/) #-}
  v ^/ a = v Geomancy.Vec2.^/ a

  {-# INLINE (^+^) #-}
  (^+^) = emap2 (+)

  {-# INLINE (^-^) #-}
  (^-^) = emap2 (-)

  {-# INLINE negateVector #-}
  negateVector = emap negate

  {-# INLINE dot #-}
  dot = Geomancy.Vec2.dot

  {-# INLINE normalize #-}
  normalize = Geomancy.Vec2.normalize

instance GlNearest Vec2

instance GlModf Vec2 Vec2 where
  glModf v =
    withVec2 v \vx vy ->
      let
        (xi, xf) = glModf vx
        (yi, yf) = glModf vy
      in
        ( vec2 (fromInteger xi) (fromInteger yi)
        , vec2 xf yf
        )