I64Vec3.hs

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

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


module Geomancy.I64Vec3
  ( I64Vec3
  , i64vec3
  , withI64Vec3
  , pattern WithI64Vec3
  , convert
  , fromTuple
  , dot

  , Packed(..)
  , packed
  ) where

import Control.DeepSeq (NFData(rnf))
import Data.Coerce (Coercible, coerce)
import Data.Int (Int64)
import Data.MonoTraversable (Element, MonoFunctor(..), MonoPointed(..))
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 I64Vec3 = I64Vec3
  {-# UNPACK #-} !Int64
  {-# UNPACK #-} !Int64
  {-# UNPACK #-} !Int64
  deriving (Eq, Ord, Show)
#ifdef TH_LIFT
  deriving Lift
#endif

{-# INLINE i64vec3 #-}
i64vec3 :: Int64 -> Int64 -> Int64 -> I64Vec3
i64vec3 = I64Vec3

{-# INLINE withI64Vec3 #-}
withI64Vec3
  :: I64Vec3
  -> (Int64 -> Int64 -> Int64 -> r)
  -> r
withI64Vec3 (I64Vec3 a b c) f = f a b c

pattern WithI64Vec3 :: Int64 -> Int64 -> Int64 -> I64Vec3
pattern WithI64Vec3 a b c <- ((`withI64Vec3` (,,)) -> (a, b, c))
{-# COMPLETE WithI64Vec3 #-}

instance HasField "x" I64Vec3 Int64 where
  {-# INLINE getField #-}
  getField v = withI64Vec3 v \x _ _ -> x

instance HasField "y" I64Vec3 Int64 where
  {-# INLINE getField #-}
  getField v = withI64Vec3 v \_ y _ -> y

instance HasField "z" I64Vec3 Int64 where
  {-# INLINE getField #-}
  getField v = withI64Vec3 v \_ _ z -> z

{-# INLINE convert #-}
convert :: Coercible v I64Vec3 => (Int64 -> a) -> (a -> a -> a -> r) -> v -> r
convert f t v =
  withI64Vec3 (coerce v) \a b c ->
    t (f a) (f b) (f c)

{-# INLINE fromTuple #-}
fromTuple :: (Int64, Int64, Int64) -> I64Vec3
fromTuple (a, b, c) = i64vec3 a b c

{-# INLINE dot #-}
dot :: I64Vec3 -> I64Vec3 -> Int64
dot (I64Vec3 l1 l2 l3) (I64Vec3 r1 r2 r3) =
  l1 * r1 + l2 * r2 + l3 * r3

instance NFData I64Vec3 where
  rnf I64Vec3{} = ()

type instance Element I64Vec3 = Int64

instance MonoFunctor I64Vec3 where
  {-# INLINE omap #-}
  omap f v =
    withI64Vec3 v \x y z ->
      i64vec3 (f x) (f y) (f z)

instance MonoPointed I64Vec3 where
  opoint x = i64vec3 x x x

instance Elementwise I64Vec3 where
  {-# INLINE emap2 #-}
  emap2 f p0 p1 =
    withI64Vec3 p0 \x0 y0 z0 ->
    withI64Vec3 p1 \x1 y1 z1 ->
      i64vec3
        (f x0 x1)
        (f y0 y1)
        (f z0 z1)

  {-# INLINE emap3 #-}
  emap3 f p0 p1 p2 =
    withI64Vec3 p0 \x0 y0 z0 ->
    withI64Vec3 p1 \x1 y1 z1 ->
    withI64Vec3 p2 \x2 y2 z2 ->
      i64vec3
        (f x0 x1 x2)
        (f y0 y1 y2)
        (f z0 z1 z2)

  {-# INLINE emap4 #-}
  emap4 f p0 p1 p2 p3 =
    withI64Vec3 p0 \x0 y0 z0 ->
    withI64Vec3 p1 \x1 y1 z1 ->
    withI64Vec3 p2 \x2 y2 z2 ->
    withI64Vec3 p3 \x3 y3 z3 ->
      i64vec3
        (f x0 x1 x2 x3)
        (f y0 y1 y2 y3)
        (f z0 z1 z2 z3)

  {-# INLINE emap5 #-}
  emap5 f p0 p1 p2 p3 p4 =
    withI64Vec3 p0 \x0 y0 z0 ->
    withI64Vec3 p1 \x1 y1 z1 ->
    withI64Vec3 p2 \x2 y2 z2 ->
    withI64Vec3 p3 \x3 y3 z3 ->
    withI64Vec3 p4 \x4 y4 z4 ->
      i64vec3
        (f x0 x1 x2 x3 x4)
        (f y0 y1 y2 y3 y4)
        (f z0 z1 z2 z3 z4)

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

  {-# INLINE (-) #-}
  I64Vec3 l1 l2 l3 - I64Vec3 r1 r2 r3 =
    I64Vec3
      (l1 - r1)
      (l2 - r2)
      (l3 - r3)

  {-# INLINE (*) #-}
  I64Vec3 l1 l2 l3 * I64Vec3 r1 r2 r3 =
    I64Vec3
      (l1 * r1)
      (l2 * r2)
      (l3 * r3)

  {-# INLINE abs #-}
  abs v3 = withI64Vec3 v3 \a b c ->
    i64vec3 (abs a) (abs b) (abs c)

  {-# INLINE signum #-}
  signum v3 = withI64Vec3 v3 \a b c ->
    i64vec3 (signum a) (signum b) (signum c)

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

instance Storable I64Vec3 where
  {-# INLINE sizeOf #-}
  sizeOf _ = 32

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

  {-# INLINE poke #-}
  poke ptr v3 =
    withI64Vec3 v3 \a b c -> do
      pokeByteOff ptr  0 a
      pokeByteOff ptr  8 b
      pokeByteOff ptr 16 c

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

newtype Packed = Packed { unPacked :: I64Vec3 }
  deriving (Eq, Ord, Show, NFData, Num)

{-# INLINE packed #-}
packed :: Int64 -> Int64 -> Int64 -> Packed
packed a b c = Packed (i64vec3 a b c)

instance HasField "x" Packed Int64 where
  {-# INLINE getField #-}
  getField (Packed v) = withI64Vec3 v \x _ _ -> x

instance HasField "y" Packed Int64 where
  {-# INLINE getField #-}
  getField (Packed v) = withI64Vec3 v \_ y _ -> y

instance HasField "z" Packed Int64 where
  {-# INLINE getField #-}
  getField (Packed v) = withI64Vec3 v \_ _ z -> z

instance Storable Packed where
  {-# INLINE sizeOf #-}
  sizeOf _ = 24

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

  {-# INLINE poke #-}
  poke ptr (Packed v3) =
    withI64Vec3 v3 \a b c -> do
      pokeByteOff ptr 0 a
      pokeByteOff ptr 8 b
      pokeByteOff ptr 16 c

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

instance Block I64Vec3 where
  type PackedSize I64Vec3 = 24
  alignment140 _  = 32
  sizeOf140 _     = 32
  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 Block Packed where
  type PackedSize Packed = 24
  alignment140 _  = 32
  sizeOf140 _     = 24
  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 I64Vec3 where
  {-# INLINE range #-}
  range (l, u) =
    withI64Vec3 l \l1 l2 l3 ->
      withI64Vec3 u \u1 u2 u3 ->
        i64vec3
          <$> range (l1, u1)
          <*> range (l2, u2)
          <*> range (l3, u3)

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

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

#ifdef SERIALISE
instance Serialise I64Vec3 where
  encode v = withI64Vec3 v \x y z ->
    Serialise.encodeListLen 3 <> encode x <> encode y <> encode z
  decode =
    Serialise.decodeListLenOf 3 *> (i64vec3 <$> decode <*> decode <*> decode)
#endif