Types.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE TypeFamilies #-}

{-| Minimal local copies of geomancy-0.3.0.1's @Vec*@/@Mat4@ 'Block' instances,
so the vec/mat cross-check needs no geomancy dependency (geomancy can't be
wired in while gl-block is the local package -- an inverted Hackage
dependency). The layouts mirror geomancy exactly, including that the default
'Vec3' writes a 4th lane (1.0) whereas 'Vec3Packed' writes only three floats.
-}
module Spec.Types
  ( Vec2 (..)
  , Vec3 (..)
  , Vec3Packed (..)
  , Vec4 (..)
  , Mat4 (..)
  ) where

import Foreign
import Foreign.Ptr.Diff (peekDiffOff, pokeDiffOff)
import Graphics.Gl.Block (Block (..))

data Vec2 = Vec2 Float Float
  deriving stock (Eq, Show)

instance Storable Vec2 where
  sizeOf _ = 8
  alignment _ = 8
  peek p = Vec2 <$> peekElemOff (castPtr p) 0 <*> peekElemOff (castPtr p) 1
  poke p (Vec2 a b) = pokeElemOff (castPtr p) 0 a >> pokeElemOff (castPtr p) 1 b

instance Block Vec2 where
  type PackedSize Vec2 = 8
  alignment140 _ = 8
  sizeOf140 _ = 8
  alignment430 = alignment140
  sizeOf430 = sizeOf140
  isStruct _ = False
  read140 = peekDiffOff
  write140 = pokeDiffOff
  read430 = read140
  write430 = write140
  readPacked = read140
  writePacked = write140

-- | geomancy's default Vec3: a 16-byte host slot whose 'poke' writes a 4th lane.
data Vec3 = Vec3 Float Float Float
  deriving stock (Eq, Show)

instance Storable Vec3 where
  sizeOf _ = 16
  alignment _ = 4
  peek p =
    Vec3
      <$> peekElemOff (castPtr p) 0
      <*> peekElemOff (castPtr p) 1
      <*> peekElemOff (castPtr p) 2
  poke p (Vec3 a b c) = do
    let p' = castPtr p
    pokeElemOff p' 0 a
    pokeElemOff p' 1 b
    pokeElemOff p' 2 c
    pokeElemOff p' 3 (1.0 :: Float)

instance Block Vec3 where
  type PackedSize Vec3 = 12
  alignment140 _ = 16
  sizeOf140 _ = 16
  alignment430 = alignment140
  sizeOf430 = sizeOf140
  isStruct _ = False
  read140 = peekDiffOff
  write140 = pokeDiffOff
  read430 = read140
  write430 = write140
  readPacked = read140
  writePacked = write140

-- | geomancy's Vec3.Packed: a 12-byte host that writes exactly three floats.
newtype Vec3Packed = Vec3Packed Vec3
  deriving stock (Eq, Show)

instance Storable Vec3Packed where
  sizeOf _ = 12
  alignment _ = 4
  peek p =
    (\a b c -> Vec3Packed (Vec3 a b c))
      <$> peekElemOff (castPtr p) 0
      <*> peekElemOff (castPtr p) 1
      <*> peekElemOff (castPtr p) 2
  poke p (Vec3Packed (Vec3 a b c)) = do
    let p' = castPtr p
    pokeElemOff p' 0 a
    pokeElemOff p' 1 b
    pokeElemOff p' 2 c

instance Block Vec3Packed where
  type PackedSize Vec3Packed = 12
  alignment140 _ = 16
  sizeOf140 _ = 16
  alignment430 = alignment140
  sizeOf430 = sizeOf140
  isStruct _ = False
  read140 = peekDiffOff
  write140 = pokeDiffOff
  read430 = read140
  write430 = write140
  readPacked = read140
  writePacked = write140

data Vec4 = Vec4 Float Float Float Float
  deriving stock (Eq, Show)

instance Storable Vec4 where
  sizeOf _ = 16
  alignment _ = 16
  peek p =
    Vec4
      <$> peekElemOff (castPtr p) 0
      <*> peekElemOff (castPtr p) 1
      <*> peekElemOff (castPtr p) 2
      <*> peekElemOff (castPtr p) 3
  poke p (Vec4 a b c d) = do
    let p' = castPtr p
    pokeElemOff p' 0 a
    pokeElemOff p' 1 b
    pokeElemOff p' 2 c
    pokeElemOff p' 3 d

instance Block Vec4 where
  type PackedSize Vec4 = 16
  alignment140 _ = 16
  sizeOf140 _ = 16
  alignment430 = alignment140
  sizeOf430 = sizeOf140
  isStruct _ = False
  read140 = peekDiffOff
  write140 = pokeDiffOff
  read430 = read140
  write430 = write140
  readPacked = read140
  writePacked = write140

-- | mat4 as four column vec4s: 64 bytes, 16-byte aligned (column-major).
newtype Mat4 = Mat4 [Float]
  deriving stock (Eq, Show)

instance Storable Mat4 where
  sizeOf _ = 64
  alignment _ = 16
  peek p = Mat4 <$> traverse (peekElemOff (castPtr p)) [0 .. 15]
  poke p (Mat4 xs) =
    sequence_ [pokeElemOff (castPtr p) i x | (i, x) <- zip [0 ..] (take 16 (xs ++ repeat 0))]

instance Block Mat4 where
  type PackedSize Mat4 = 64
  alignment140 _ = 16
  sizeOf140 _ = 64
  alignment430 = alignment140
  sizeOf430 = sizeOf140
  isStruct _ = False
  read140 = peekDiffOff
  write140 = pokeDiffOff
  read430 = read140
  write430 = write140
  readPacked = read140
  writePacked = write140