DVec2.hs

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

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

module Geomancy.DVec2
  ( DVec2
  , dvec2
  , withDVec2
  , pattern WithDVec2
  , fromTuple
  , convert

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

  , dot
  , normalize

  , fromVec2
  , toVec2
  ) 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 GHC.Float (double2Float, float2Double)
import GHC.Records (HasField(..))
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.Vec2 (Vec2)
import qualified Geomancy.Vec2 as Vec2

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

{-# INLINE dvec2 #-}
dvec2 :: Double -> Double -> DVec2
dvec2 = DVec2

{-# INLINE withDVec2 #-}
withDVec2
  :: DVec2
  -> (Double -> Double -> r)
  -> r
withDVec2 (DVec2 a b) f = f a b

{-# INLINE convert #-}
convert :: Coercible v DVec2 => (Double -> a) -> (a -> a -> r) -> v -> r
convert f t v =
  withDVec2 (coerce v) \a b ->
    t (f a) (f b)

pattern WithDVec2 :: Double -> Double -> DVec2
pattern WithDVec2 a b <- ((`withDVec2` (,)) -> (a, b))
{-# COMPLETE WithDVec2 #-}

instance HasField "x" DVec2 Double where
  {-# INLINE getField #-}
  getField v = withDVec2 v \x _ -> x

instance HasField "y" DVec2 Double where
  {-# INLINE getField #-}
  getField v = withDVec2 v \_ y -> y

{-# INLINE fromTuple #-}
fromTuple :: (Double, Double) -> DVec2
fromTuple (x, y) = dvec2 x y

{-# INLINE fromVec2 #-}
fromVec2 :: Vec2 -> DVec2
fromVec2 = Vec2.convert float2Double dvec2

{-# INLINE toVec2 #-}
toVec2 :: DVec2 -> Vec2
toVec2 = convert double2Float Vec2.vec2

instance NFData DVec2 where
  rnf DVec2{} = ()

type instance Element DVec2 = Double

instance MonoFunctor DVec2 where
  {-# INLINE omap #-}
  omap f v =
    withDVec2 v \x y ->
      dvec2 (f x) (f y)

instance MonoPointed DVec2 where
  opoint x = dvec2 x x

instance Elementwise DVec2 where
  {-# INLINE emap2 #-}
  emap2 f p0 p1 =
    withDVec2 p0 \x0 y0 ->
    withDVec2 p1 \x1 y1 ->
      dvec2
        (f x0 x1)
        (f y0 y1)

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

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

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

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

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

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

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

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

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

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

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

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

instance Floating DVec2 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 (^*) #-}
(^*) :: DVec2 -> Double -> DVec2
DVec2 a b ^* x =
  DVec2
    (a * x)
    (b * x)

{-# INLINE (^/) #-}
(^/) :: DVec2 -> Double -> DVec2
DVec2 a b ^/ x =
  DVec2
    (a / x)
    (b / x)

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

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

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

  where
    q = dot v v
    l = sqrt q

    nearZero a = abs a <= 1e-12

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

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

  {-# INLINE poke #-}
  poke ptr v2 =
    withDVec2 v2 \a b -> do
      pokeByteOff ptr 0 a
      pokeByteOff ptr 8 b

  {-# INLINE peek #-}
  peek ptr = dvec2
    <$> peekByteOff ptr 0
    <*> peekByteOff ptr 8

instance Block DVec2 where
  type PackedSize DVec2 = 16
  alignment140 _  = 16
  sizeOf140 _     = 16
  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 DVec2 where
  encode v = withDVec2 v \x y ->
    Serialise.encodeListLen 2 <> encode x <> encode y
  decode =
    Serialise.decodeListLenOf 2 *> (dvec2 <$> decode <*> decode)
#endif

instance VectorSpace DVec2 Double where
  zeroVector = epoint 0

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

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

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

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

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

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

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