U64Vec3.hs

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

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


module Geomancy.U64Vec3
  ( U64Vec3
  , u64vec3
  , withU64Vec3
  , pattern WithU64Vec3
  , convert
  , fromTuple
  , dot

  , Packed(..)
  , packed
  ) 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.OverloadedLabels (IsLabel(..))
import GHC.Records (HasField(..))
import WebColor.Labels (IsWebColor(..))

#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 U64Vec3 = U64Vec3
  {-# UNPACK #-} !Word64
  {-# UNPACK #-} !Word64
  {-# UNPACK #-} !Word64
  deriving (Eq, Ord, Show)
#ifdef TH_LIFT
  deriving Lift
#endif

{-# INLINE u64vec3 #-}
u64vec3 :: Word64 -> Word64 -> Word64 -> U64Vec3
u64vec3 = U64Vec3

{-# INLINE withU64Vec3 #-}
withU64Vec3
  :: U64Vec3
  -> (Word64 -> Word64 -> Word64 -> r)
  -> r
withU64Vec3 (U64Vec3 a b c) f = f a b c

pattern WithU64Vec3 :: Word64 -> Word64 -> Word64 -> U64Vec3
pattern WithU64Vec3 a b c <- ((`withU64Vec3` (,,)) -> (a, b, c))
{-# COMPLETE WithU64Vec3 #-}

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

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

instance HasField "z" U64Vec3 Word64 where
  {-# INLINE getField #-}
  getField v = withU64Vec3 v \_ _ z -> z

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

{-# INLINE fromTuple #-}
fromTuple :: (Word64, Word64, Word64) -> U64Vec3
fromTuple (a, b, c) = u64vec3 a b c

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

instance IsWebColor s => IsLabel s U64Vec3 where
  {-# INLINE fromLabel #-}
  fromLabel =
    webColor @s \r g b ->
      u64vec3 (fromIntegral r) (fromIntegral g) (fromIntegral b)

instance NFData U64Vec3 where
  rnf U64Vec3{} = ()

type instance Element U64Vec3 = Word64

instance MonoFunctor U64Vec3 where
  {-# INLINE omap #-}
  omap f v =
    withU64Vec3 v \x y z ->
      u64vec3 (f x) (f y) (f z)

instance MonoPointed U64Vec3 where
  {-# INLINE opoint #-}
  opoint x = u64vec3 x x x

instance Elementwise U64Vec3 where
  {-# INLINE emap2 #-}
  emap2 f p0 p1 =
    withU64Vec3 p0 \x0 y0 z0 ->
    withU64Vec3 p1 \x1 y1 z1 ->
      u64vec3
        (f x0 x1)
        (f y0 y1)
        (f z0 z1)

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

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

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

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

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

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

  {-# INLINE abs #-}
  abs x = x

  {-# INLINE signum #-}
  signum v3 = withU64Vec3 v3 \a b c ->
    u64vec3 (signum a) (signum b) (signum c)

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

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

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

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

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

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

{-# INLINE packed #-}
packed :: Word64 -> Word64 -> Word64 -> Packed
packed a b c = Packed (u64vec3 a b c)

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

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

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

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

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

  {-# INLINE poke #-}
  poke ptr (Packed v3) =
    withU64Vec3 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 U64Vec3 where
  type PackedSize U64Vec3 = 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 U64Vec3 where
  {-# INLINE range #-}
  range (l, u) =
    withU64Vec3 l \l1 l2 l3 ->
      withU64Vec3 u \u1 u2 u3 ->
        u64vec3
          <$> range (l1, u1)
          <*> range (l2, u2)
          <*> range (l3, u3)

  {-# INLINE unsafeIndex #-}
  unsafeIndex (l, u) i =
    withU64Vec3 l \l1 l2 l3 ->
      withU64Vec3 u \u1 u2 u3 ->
        withU64Vec3 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 =
    withU64Vec3 l \l1 l2 l3 ->
      withU64Vec3 u \u1 u2 u3 ->
        withU64Vec3 i \i1 i2 i3 ->
          inRange (l1, u1) i1 &&
          inRange (l2, u2) i2 &&
          inRange (l3, u3) i3

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