module Render.Lit.Textured.Model
( Model
, VertexAttrs(..)
, vkVertexAttrs
, InstanceAttrs(..)
, InstanceBuffers(..)
, TextureParams(..)
, vkInstanceTexture
, allocateInstancesWith
, Transform
) where
import RIO
import Foreign (Storable(..))
import Geomancy (Transform, Vec2, Vec4)
import Geomancy.Vec3 qualified as Vec3
import RIO.Vector.Storable qualified as VectorS
import UnliftIO.Resource (MonadResource, ReleaseKey, allocate)
import Vulkan.Core10 qualified as Vk
import Vulkan.Zero (Zero(..))
import Resource.Buffer qualified as Buffer
import Resource.Model qualified as Model
type Model buf = Model.Indexed buf Vec3.Packed VertexAttrs
data VertexAttrs = VertexAttrs
{ VertexAttrs -> Vec2
vaTexCoord :: Vec2
, VertexAttrs -> Packed
vaNormal :: Vec3.Packed
}
deriving (VertexAttrs -> VertexAttrs -> Bool
(VertexAttrs -> VertexAttrs -> Bool)
-> (VertexAttrs -> VertexAttrs -> Bool) -> Eq VertexAttrs
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: VertexAttrs -> VertexAttrs -> Bool
$c/= :: VertexAttrs -> VertexAttrs -> Bool
== :: VertexAttrs -> VertexAttrs -> Bool
$c== :: VertexAttrs -> VertexAttrs -> Bool
Eq, Eq VertexAttrs
Eq VertexAttrs
-> (VertexAttrs -> VertexAttrs -> Ordering)
-> (VertexAttrs -> VertexAttrs -> Bool)
-> (VertexAttrs -> VertexAttrs -> Bool)
-> (VertexAttrs -> VertexAttrs -> Bool)
-> (VertexAttrs -> VertexAttrs -> Bool)
-> (VertexAttrs -> VertexAttrs -> VertexAttrs)
-> (VertexAttrs -> VertexAttrs -> VertexAttrs)
-> Ord VertexAttrs
VertexAttrs -> VertexAttrs -> Bool
VertexAttrs -> VertexAttrs -> Ordering
VertexAttrs -> VertexAttrs -> VertexAttrs
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: VertexAttrs -> VertexAttrs -> VertexAttrs
$cmin :: VertexAttrs -> VertexAttrs -> VertexAttrs
max :: VertexAttrs -> VertexAttrs -> VertexAttrs
$cmax :: VertexAttrs -> VertexAttrs -> VertexAttrs
>= :: VertexAttrs -> VertexAttrs -> Bool
$c>= :: VertexAttrs -> VertexAttrs -> Bool
> :: VertexAttrs -> VertexAttrs -> Bool
$c> :: VertexAttrs -> VertexAttrs -> Bool
<= :: VertexAttrs -> VertexAttrs -> Bool
$c<= :: VertexAttrs -> VertexAttrs -> Bool
< :: VertexAttrs -> VertexAttrs -> Bool
$c< :: VertexAttrs -> VertexAttrs -> Bool
compare :: VertexAttrs -> VertexAttrs -> Ordering
$ccompare :: VertexAttrs -> VertexAttrs -> Ordering
$cp1Ord :: Eq VertexAttrs
Ord, Int -> VertexAttrs -> ShowS
[VertexAttrs] -> ShowS
VertexAttrs -> String
(Int -> VertexAttrs -> ShowS)
-> (VertexAttrs -> String)
-> ([VertexAttrs] -> ShowS)
-> Show VertexAttrs
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [VertexAttrs] -> ShowS
$cshowList :: [VertexAttrs] -> ShowS
show :: VertexAttrs -> String
$cshow :: VertexAttrs -> String
showsPrec :: Int -> VertexAttrs -> ShowS
$cshowsPrec :: Int -> VertexAttrs -> ShowS
Show, (forall x. VertexAttrs -> Rep VertexAttrs x)
-> (forall x. Rep VertexAttrs x -> VertexAttrs)
-> Generic VertexAttrs
forall x. Rep VertexAttrs x -> VertexAttrs
forall x. VertexAttrs -> Rep VertexAttrs x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep VertexAttrs x -> VertexAttrs
$cfrom :: forall x. VertexAttrs -> Rep VertexAttrs x
Generic)
instance Storable VertexAttrs where
alignment :: VertexAttrs -> Int
alignment ~VertexAttrs
_ = Int
4
sizeOf :: VertexAttrs -> Int
sizeOf ~VertexAttrs
_ = Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
12
peek :: Ptr VertexAttrs -> IO VertexAttrs
peek Ptr VertexAttrs
ptr = do
Vec2
vaTexCoord <- Ptr VertexAttrs -> Int -> IO Vec2
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr VertexAttrs
ptr Int
0
Packed
vaNormal <- Ptr VertexAttrs -> Int -> IO Packed
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr VertexAttrs
ptr Int
8
pure VertexAttrs :: Vec2 -> Packed -> VertexAttrs
VertexAttrs{Vec2
Packed
vaNormal :: Packed
vaTexCoord :: Vec2
$sel:vaNormal:VertexAttrs :: Packed
$sel:vaTexCoord:VertexAttrs :: Vec2
..}
poke :: Ptr VertexAttrs -> VertexAttrs -> IO ()
poke Ptr VertexAttrs
ptr VertexAttrs{Vec2
Packed
vaNormal :: Packed
vaTexCoord :: Vec2
$sel:vaNormal:VertexAttrs :: VertexAttrs -> Packed
$sel:vaTexCoord:VertexAttrs :: VertexAttrs -> Vec2
..} = do
Ptr VertexAttrs -> Int -> Vec2 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr VertexAttrs
ptr Int
0 Vec2
vaTexCoord
Ptr VertexAttrs -> Int -> Packed -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr VertexAttrs
ptr Int
8 Packed
vaNormal
vkVertexAttrs :: [Vk.Format]
vkVertexAttrs :: [Format]
vkVertexAttrs =
[ Format
Vk.FORMAT_R32G32_SFLOAT
, Format
Vk.FORMAT_R32G32B32_SFLOAT
]
data InstanceAttrs = InstanceAttrs
{ InstanceAttrs -> TextureParams
textureParams :: TextureParams
, InstanceAttrs -> Transform
transformMat4 :: Transform
}
instance Zero InstanceAttrs where
zero :: InstanceAttrs
zero = InstanceAttrs :: TextureParams -> Transform -> InstanceAttrs
InstanceAttrs
{ $sel:textureParams:InstanceAttrs :: TextureParams
textureParams = TextureParams
forall a. Zero a => a
zero
, $sel:transformMat4:InstanceAttrs :: Transform
transformMat4 = Transform
forall a. Monoid a => a
mempty
}
data InstanceBuffers textureStage transformStage = InstanceBuffers
{ InstanceBuffers textureStage transformStage
-> InstanceTexture textureStage
ibTexture :: InstanceTexture textureStage
, InstanceBuffers textureStage transformStage
-> InstanceTransform transformStage
ibTransform :: InstanceTransform transformStage
}
type InstanceTexture stage = Buffer.Allocated stage TextureParams
type InstanceTransform stage = Buffer.Allocated stage Transform
instance Model.HasVertexBuffers (InstanceBuffers textureStage transformStage) where
type VertexBuffersOf (InstanceBuffers textureStage transformStage) = InstanceAttrs
{-# INLINE getVertexBuffers #-}
getVertexBuffers :: InstanceBuffers textureStage transformStage -> [Buffer]
getVertexBuffers InstanceBuffers{InstanceTexture textureStage
InstanceTransform transformStage
ibTransform :: InstanceTransform transformStage
ibTexture :: InstanceTexture textureStage
$sel:ibTransform:InstanceBuffers :: forall (textureStage :: Store) (transformStage :: Store).
InstanceBuffers textureStage transformStage
-> InstanceTransform transformStage
$sel:ibTexture:InstanceBuffers :: forall (textureStage :: Store) (transformStage :: Store).
InstanceBuffers textureStage transformStage
-> InstanceTexture textureStage
..} =
[ InstanceTexture textureStage -> Buffer
forall (s :: Store) a. Allocated s a -> Buffer
Buffer.aBuffer InstanceTexture textureStage
ibTexture
, InstanceTransform transformStage -> Buffer
forall (s :: Store) a. Allocated s a -> Buffer
Buffer.aBuffer InstanceTransform transformStage
ibTransform
]
{-# INLINE getInstanceCount #-}
getInstanceCount :: InstanceBuffers textureStage transformStage -> Word32
getInstanceCount InstanceBuffers{InstanceTexture textureStage
InstanceTransform transformStage
ibTransform :: InstanceTransform transformStage
ibTexture :: InstanceTexture textureStage
$sel:ibTransform:InstanceBuffers :: forall (textureStage :: Store) (transformStage :: Store).
InstanceBuffers textureStage transformStage
-> InstanceTransform transformStage
$sel:ibTexture:InstanceBuffers :: forall (textureStage :: Store) (transformStage :: Store).
InstanceBuffers textureStage transformStage
-> InstanceTexture textureStage
..} =
Word32 -> Word32 -> Word32
forall a. Ord a => a -> a -> a
min
(InstanceTexture textureStage -> Word32
forall (s :: Store) a. Allocated s a -> Word32
Buffer.aUsed InstanceTexture textureStage
ibTexture)
(InstanceTransform transformStage -> Word32
forall (s :: Store) a. Allocated s a -> Word32
Buffer.aUsed InstanceTransform transformStage
ibTransform)
data TextureParams = TextureParams
{ TextureParams -> Vec2
tpScale :: Vec2
, TextureParams -> Vec2
tpOffset :: Vec2
, TextureParams -> Vec4
tpGamma :: Vec4
, TextureParams -> Int32
tpSamplerId :: Int32
, TextureParams -> Int32
tpTextureId :: Int32
}
deriving (Int -> TextureParams -> ShowS
[TextureParams] -> ShowS
TextureParams -> String
(Int -> TextureParams -> ShowS)
-> (TextureParams -> String)
-> ([TextureParams] -> ShowS)
-> Show TextureParams
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TextureParams] -> ShowS
$cshowList :: [TextureParams] -> ShowS
show :: TextureParams -> String
$cshow :: TextureParams -> String
showsPrec :: Int -> TextureParams -> ShowS
$cshowsPrec :: Int -> TextureParams -> ShowS
Show)
instance Zero TextureParams where
zero :: TextureParams
zero = TextureParams :: Vec2 -> Vec2 -> Vec4 -> Int32 -> Int32 -> TextureParams
TextureParams
{ $sel:tpScale:TextureParams :: Vec2
tpScale = Vec2
1
, $sel:tpOffset:TextureParams :: Vec2
tpOffset = Vec2
0
, $sel:tpGamma:TextureParams :: Vec4
tpGamma = Vec4
1.0
, $sel:tpSamplerId:TextureParams :: Int32
tpSamplerId = Int32
forall a. Bounded a => a
minBound
, $sel:tpTextureId:TextureParams :: Int32
tpTextureId = Int32
forall a. Bounded a => a
minBound
}
instance Storable TextureParams where
alignment :: TextureParams -> Int
alignment ~TextureParams
_ = Int
8
sizeOf :: TextureParams -> Int
sizeOf ~TextureParams
_ = Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
16 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4
poke :: Ptr TextureParams -> TextureParams -> IO ()
poke Ptr TextureParams
ptr TextureParams{Int32
Vec2
Vec4
tpTextureId :: Int32
tpSamplerId :: Int32
tpGamma :: Vec4
tpOffset :: Vec2
tpScale :: Vec2
$sel:tpTextureId:TextureParams :: TextureParams -> Int32
$sel:tpSamplerId:TextureParams :: TextureParams -> Int32
$sel:tpGamma:TextureParams :: TextureParams -> Vec4
$sel:tpOffset:TextureParams :: TextureParams -> Vec2
$sel:tpScale:TextureParams :: TextureParams -> Vec2
..} = do
Ptr TextureParams -> Int -> Vec2 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr TextureParams
ptr Int
0 Vec2
tpScale
Ptr TextureParams -> Int -> Vec2 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr TextureParams
ptr Int
8 Vec2
tpOffset
Ptr TextureParams -> Int -> Vec4 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr TextureParams
ptr Int
16 Vec4
tpGamma
Ptr TextureParams -> Int -> Int32 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr TextureParams
ptr Int
32 Int32
tpSamplerId
Ptr TextureParams -> Int -> Int32 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr TextureParams
ptr Int
36 Int32
tpTextureId
peek :: Ptr TextureParams -> IO TextureParams
peek Ptr TextureParams
ptr = do
Vec2
tpScale <- Ptr TextureParams -> Int -> IO Vec2
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr TextureParams
ptr Int
0
Vec2
tpOffset <- Ptr TextureParams -> Int -> IO Vec2
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr TextureParams
ptr Int
8
Vec4
tpGamma <- Ptr TextureParams -> Int -> IO Vec4
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr TextureParams
ptr Int
16
Int32
tpSamplerId <- Ptr TextureParams -> Int -> IO Int32
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr TextureParams
ptr Int
32
Int32
tpTextureId <- Ptr TextureParams -> Int -> IO Int32
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr TextureParams
ptr Int
36
pure TextureParams :: Vec2 -> Vec2 -> Vec4 -> Int32 -> Int32 -> TextureParams
TextureParams{Int32
Vec2
Vec4
tpTextureId :: Int32
tpSamplerId :: Int32
tpGamma :: Vec4
tpOffset :: Vec2
tpScale :: Vec2
$sel:tpTextureId:TextureParams :: Int32
$sel:tpSamplerId:TextureParams :: Int32
$sel:tpGamma:TextureParams :: Vec4
$sel:tpOffset:TextureParams :: Vec2
$sel:tpScale:TextureParams :: Vec2
..}
vkInstanceTexture :: [Vk.Format]
vkInstanceTexture :: [Format]
vkInstanceTexture =
[ Format
Vk.FORMAT_R32G32B32A32_SFLOAT
, Format
Vk.FORMAT_R32G32B32A32_SFLOAT
, Format
Vk.FORMAT_R32G32_SINT
]
allocateInstancesWith
:: ( MonadResource m
, MonadUnliftIO m
)
=> (Vk.BufferUsageFlagBits -> Int -> VectorS.Vector TextureParams -> m (InstanceTexture texture))
-> (Vk.BufferUsageFlagBits -> Int -> VectorS.Vector Transform -> m (InstanceTransform transform))
-> (forall stage a . Buffer.Allocated stage a -> m ())
-> [InstanceAttrs]
-> m (ReleaseKey, InstanceBuffers texture transform)
allocateInstancesWith :: (BufferUsageFlagBits
-> Int -> Vector TextureParams -> m (InstanceTexture texture))
-> (BufferUsageFlagBits
-> Int -> Vector Transform -> m (InstanceTransform transform))
-> (forall (stage :: Store) a. Allocated stage a -> m ())
-> [InstanceAttrs]
-> m (ReleaseKey, InstanceBuffers texture transform)
allocateInstancesWith BufferUsageFlagBits
-> Int -> Vector TextureParams -> m (InstanceTexture texture)
createTextures BufferUsageFlagBits
-> Int -> Vector Transform -> m (InstanceTransform transform)
createTransforms forall (stage :: Store) a. Allocated stage a -> m ()
bufferDestroy [InstanceAttrs]
instances = do
UnliftIO m
ul <- m (UnliftIO m)
forall (m :: * -> *). MonadUnliftIO m => m (UnliftIO m)
askUnliftIO
IO (InstanceBuffers texture transform)
-> (InstanceBuffers texture transform -> IO ())
-> m (ReleaseKey, InstanceBuffers texture transform)
forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
allocate (UnliftIO m -> IO (InstanceBuffers texture transform)
create UnliftIO m
ul) (UnliftIO m -> InstanceBuffers texture transform -> IO ()
destroy UnliftIO m
ul)
where
textures :: Vector TextureParams
textures = [TextureParams] -> Vector TextureParams
forall a. Storable a => [a] -> Vector a
VectorS.fromList ([TextureParams] -> Vector TextureParams)
-> [TextureParams] -> Vector TextureParams
forall a b. (a -> b) -> a -> b
$ (InstanceAttrs -> TextureParams)
-> [InstanceAttrs] -> [TextureParams]
forall a b. (a -> b) -> [a] -> [b]
map InstanceAttrs -> TextureParams
textureParams [InstanceAttrs]
instances
transforms :: Vector Transform
transforms = [Transform] -> Vector Transform
forall a. Storable a => [a] -> Vector a
VectorS.fromList ([Transform] -> Vector Transform)
-> [Transform] -> Vector Transform
forall a b. (a -> b) -> a -> b
$ (InstanceAttrs -> Transform) -> [InstanceAttrs] -> [Transform]
forall a b. (a -> b) -> [a] -> [b]
map InstanceAttrs -> Transform
transformMat4 [InstanceAttrs]
instances
numInstances :: Int
numInstances = Vector TextureParams -> Int
forall a. Storable a => Vector a -> Int
VectorS.length Vector TextureParams
textures
create :: UnliftIO m -> IO (InstanceBuffers texture transform)
create (UnliftIO forall a. m a -> IO a
ul) = m (InstanceBuffers texture transform)
-> IO (InstanceBuffers texture transform)
forall a. m a -> IO a
ul do
InstanceTexture texture
ibTexture <- BufferUsageFlagBits
-> Int -> Vector TextureParams -> m (InstanceTexture texture)
createTextures BufferUsageFlagBits
Vk.BUFFER_USAGE_VERTEX_BUFFER_BIT Int
numInstances Vector TextureParams
textures
InstanceTransform transform
ibTransform <- BufferUsageFlagBits
-> Int -> Vector Transform -> m (InstanceTransform transform)
createTransforms BufferUsageFlagBits
Vk.BUFFER_USAGE_VERTEX_BUFFER_BIT Int
numInstances Vector Transform
transforms
pure InstanceBuffers :: forall (textureStage :: Store) (transformStage :: Store).
InstanceTexture textureStage
-> InstanceTransform transformStage
-> InstanceBuffers textureStage transformStage
InstanceBuffers{InstanceTexture texture
InstanceTransform transform
ibTransform :: InstanceTransform transform
ibTexture :: InstanceTexture texture
$sel:ibTransform:InstanceBuffers :: InstanceTransform transform
$sel:ibTexture:InstanceBuffers :: InstanceTexture texture
..}
destroy :: UnliftIO m -> InstanceBuffers texture transform -> IO ()
destroy (UnliftIO forall a. m a -> IO a
ul) InstanceBuffers{InstanceTexture texture
InstanceTransform transform
ibTransform :: InstanceTransform transform
ibTexture :: InstanceTexture texture
$sel:ibTransform:InstanceBuffers :: forall (textureStage :: Store) (transformStage :: Store).
InstanceBuffers textureStage transformStage
-> InstanceTransform transformStage
$sel:ibTexture:InstanceBuffers :: forall (textureStage :: Store) (transformStage :: Store).
InstanceBuffers textureStage transformStage
-> InstanceTexture textureStage
..} = m () -> IO ()
forall a. m a -> IO a
ul do
InstanceTexture texture -> m ()
forall (stage :: Store) a. Allocated stage a -> m ()
bufferDestroy InstanceTexture texture
ibTexture
InstanceTransform transform -> m ()
forall (stage :: Store) a. Allocated stage a -> m ()
bufferDestroy InstanceTransform transform
ibTransform