UVec3.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

-- | Specialized and inlined @V2 Word32@.

module Geomancy.UVec3
  ( UVec3
  , uvec3
  , withUVec3
  , pattern WithUVec3
  , 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 (Word32)
import Foreign (Storable(..))
import Foreign.Ptr.Diff (peekDiffOff, pokeDiffOff)
import GHC.Ix (Ix(..))
import GHC.OverloadedLabels (IsLabel(..))
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 UVec3 = UVec3
  {-# UNPACK #-} !Word32
  {-# UNPACK #-} !Word32
  {-# UNPACK #-} !Word32
  deriving (Eq, Ord, Show)
#ifdef TH_LIFT
  deriving Lift
#endif

{-# INLINE uvec3 #-}
uvec3 :: Word32 -> Word32 -> Word32 -> UVec3
uvec3 = UVec3

{-# INLINE withUVec3 #-}
withUVec3
  :: UVec3
  -> (Word32 -> Word32 -> Word32 -> r)
  -> r
withUVec3 (UVec3 a b c) f = f a b c

pattern WithUVec3 :: Word32 -> Word32 -> Word32 -> UVec3
pattern WithUVec3 a b c <- ((`withUVec3` (,,)) -> (a, b, c))
{-# COMPLETE WithUVec3 #-}

{-# INLINE convert #-}
convert :: Coercible v UVec3 => (Word32 -> a) -> (a -> a -> a -> r) -> v -> r
convert f t v =
  withUVec3 (coerce v) \a b c ->
    t (f a) (f b) (f c)

{-# INLINE fromTuple #-}
fromTuple :: (Word32, Word32, Word32) -> UVec3
fromTuple (a, b, c) = uvec3 a b c

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

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

instance NFData UVec3 where
  rnf UVec3{} = ()

type instance Element UVec3 = Word32

instance MonoFunctor UVec3 where
  {-# INLINE omap #-}
  omap f v =
    withUVec3 v \x y z ->
      uvec3 (f x) (f y) (f z)

instance MonoPointed UVec3 where
  {-# INLINE opoint #-}
  opoint x = uvec3 x x x

instance Elementwise UVec3 where
  {-# INLINE emap2 #-}
  emap2 f p0 p1 =
    withUVec3 p0 \x0 y0 z0 ->
    withUVec3 p1 \x1 y1 z1 ->
      uvec3
        (f x0 x1)
        (f y0 y1)
        (f z0 z1)

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

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

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

-- XXX: That's another nasty instance...
instance Num UVec3 where
  {-# INLINE (+) #-}
  UVec3 l1 l2 l3 + UVec3 r1 r2 r3 =
    UVec3
      (l1 + r1)
      (l2 + r2)
      (l3 + r3)

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

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

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

  {-# INLINE signum #-}
  signum v3 = withUVec3 v3 \a b c ->
    uvec3 (signum a) (signum b) (signum c)

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

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

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

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

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

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

{-# INLINE packed #-}
packed :: Word32 -> Word32 -> Word32 -> Packed
packed a b c = Packed (uvec3 a b c)

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

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

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

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

instance Block UVec3 where
  type PackedSize UVec3 = 12
  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 Block Packed where
  type PackedSize Packed = 12
  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 UVec3 where
  {-# INLINE range #-}
  range (l, u) =
    withUVec3 l \l1 l2 l3 ->
      withUVec3 u \u1 u2 u3 ->
        uvec3
          <$> range (l1, u1)
          <*> range (l2, u2)
          <*> range (l3, u3)

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

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