U64Vec2.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.U64Vec2
  ( U64Vec2
  , u64vec2
  , withU64Vec2
  , pattern WithU64Vec2
  , convert
  , fromTuple
  , dot
  ) where

import Control.DeepSeq (NFData(rnf))
import Data.Coerce (Coercible, coerce)
import Data.MonoTraversable (Element, MonoFunctor(..), MonoPointed(..))
import Data.Word (Word64)
import Foreign (Storable(..))
import Foreign.Ptr.Diff (peekDiffOff, pokeDiffOff)
import GHC.Ix (Ix(..))
import GHC.Records (HasField(..))

#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(..))

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

{-# INLINE u64vec2 #-}
u64vec2 :: Word64 -> Word64 -> U64Vec2
u64vec2 = U64Vec2

{-# INLINE withU64Vec2 #-}
withU64Vec2
  :: U64Vec2
  -> (Word64 -> Word64 -> r)
  -> r
withU64Vec2 (U64Vec2 a b) f = f a b

pattern WithU64Vec2 :: Word64 -> Word64 -> U64Vec2
pattern WithU64Vec2 a b <- ((`withU64Vec2` (,)) -> (a, b))
{-# COMPLETE WithU64Vec2 #-}

instance HasField "x" U64Vec2 Word64 where
  {-# INLINE getField #-}
  getField v = withU64Vec2 v \x _ -> x

instance HasField "y" U64Vec2 Word64 where
  {-# INLINE getField #-}
  getField v = withU64Vec2 v \_ y -> y

{-# INLINE convert #-}
convert :: Coercible v U64Vec2 => (Word64 -> a) -> (a -> a -> r) -> v -> r
convert f t v =
  withU64Vec2 (coerce v) \a b ->
    t (f a) (f b)

{-# INLINE fromTuple #-}
fromTuple :: (Word64, Word64) -> U64Vec2
fromTuple (x, y) = u64vec2 x y

instance NFData U64Vec2 where
  rnf U64Vec2{} = ()

type instance Element U64Vec2 = Word64

instance MonoFunctor U64Vec2 where
  {-# INLINE omap #-}
  omap f v =
    withU64Vec2 v \x y ->
      u64vec2 (f x) (f y)

instance MonoPointed U64Vec2 where
  {-# INLINE opoint #-}
  opoint x = u64vec2 x x

instance Elementwise U64Vec2 where
  {-# INLINE emap2 #-}
  emap2 f p0 p1 =
    withU64Vec2 p0 \x0 y0 ->
    withU64Vec2 p1 \x1 y1 ->
      u64vec2
        (f x0 x1)
        (f y0 y1)

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

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

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

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

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

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

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

  {-# INLINE signum #-}
  signum v2 = withU64Vec2 v2 \a b ->
    u64vec2 (signum a) (signum b)

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

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

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

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

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

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

instance Block U64Vec2 where
  type PackedSize U64Vec2 = 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 #-}

instance Ix U64Vec2 where
  {-# INLINE range #-}
  range (l, u) =
    withU64Vec2 l \l1 l2 ->
      withU64Vec2 u \u1 u2 ->
        u64vec2
          <$> range (l1, u1)
          <*> range (l2, u2)

  {-# INLINE unsafeIndex #-}
  unsafeIndex (l, u) i =
    withU64Vec2 l \l1 l2 ->
      withU64Vec2 u \u1 u2 ->
        withU64Vec2 i \i1 i2 ->
          unsafeIndex (l2, u2) i2 + unsafeRangeSize (l2, u2) *
          unsafeIndex (l1, u1) i1

  {-# INLINE inRange #-}
  inRange (l, u) i =
    withU64Vec2 l \l1 l2 ->
      withU64Vec2 u \u1 u2 ->
        withU64Vec2 i \i1 i2 ->
          inRange (l1, u1) i1 &&
          inRange (l2, u2) i2

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