{-# OPTIONS_GHC -fplugin Foreign.Storable.Generic.Plugin #-}

{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE OverloadedRecordDot #-}

module Render.Unlit.Textured.Model
  ( Model
  , Vertex
  , VertexAttrs

  , AttrsF(..)
  , Attrs
  , attrs

  , Stores
  , attrStores
  , stores1
  , Buffers

  , TextureParams(..)

  , ObserverCoherent
  ) where

import RIO

import Geomancy (Transform, Vec2, Vec4)
import Geomancy.Vec3 qualified as Vec3
import Graphics.Gl.Block (Block)
import Graphics.Gl.Block qualified as Block
import RIO.Vector.Storable qualified as Storable
import Vulkan.Core10 qualified as Vk
import Vulkan.NamedType ((:::))
import Vulkan.Zero (Zero(..))

import Engine.Types (HKD)
import Engine.Vulkan.Format (HasVkFormat(..))
import Engine.Vulkan.Pipeline.Graphics (HasVertexInputBindings(..), instanceFormat)
import Engine.Worker qualified as Worker
import Resource.Buffer qualified as Buffer
import Resource.Model qualified as Model
import Resource.Model.Observer qualified as Observer

type Model buf = Model.Indexed buf Vec3.Packed VertexAttrs
type Vertex = Model.Vertex3d VertexAttrs

type VertexAttrs = "uv" ::: Vec2

data AttrsF f = Attrs
  { forall (f :: * -> *). AttrsF f -> HKD f TextureParams
params     :: HKD f TextureParams
  , forall (f :: * -> *). AttrsF f -> HKD f Transform
transforms :: HKD f Transform
  }
  deriving ((forall x. AttrsF f -> Rep (AttrsF f) x)
-> (forall x. Rep (AttrsF f) x -> AttrsF f) -> Generic (AttrsF f)
forall x. Rep (AttrsF f) x -> AttrsF f
forall x. AttrsF f -> Rep (AttrsF f) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (f :: * -> *) x. Rep (AttrsF f) x -> AttrsF f
forall (f :: * -> *) x. AttrsF f -> Rep (AttrsF f) x
$cfrom :: forall (f :: * -> *) x. AttrsF f -> Rep (AttrsF f) x
from :: forall x. AttrsF f -> Rep (AttrsF f) x
$cto :: forall (f :: * -> *) x. Rep (AttrsF f) x -> AttrsF f
to :: forall x. Rep (AttrsF f) x -> AttrsF f
Generic)

type Attrs = AttrsF Identity
deriving instance Show Attrs

instance HasVertexInputBindings Attrs where
  vertexInputBindings :: [VertexInputBinding]
vertexInputBindings =
    [ forall a. HasVkFormat a => VertexInputBinding
instanceFormat @TextureParams
    , forall a. HasVkFormat a => VertexInputBinding
instanceFormat @Transform
    ]

type Stores = AttrsF Storable.Vector
deriving instance Show Stores

type Buffers = AttrsF (Buffer.Allocated 'Buffer.Coherent)
deriving instance Show Buffers
instance Observer.VertexBuffers Buffers
type ObserverCoherent = Worker.ObserverIO Buffers

instance Observer.UpdateCoherent Buffers Stores

instance Model.HasVertexBuffers Buffers where
  type VertexBuffersOf Buffers = Attrs

instance Zero Attrs where
  zero :: Attrs
zero = Attrs
    { $sel:params:Attrs :: HKD Identity TextureParams
params = HKD Identity TextureParams
TextureParams
forall a. Zero a => a
zero
    , $sel:transforms:Attrs :: HKD Identity Transform
transforms = Transform
HKD Identity Transform
forall a. Monoid a => a
mempty
    }

attrs :: Int32 -> Int32 -> [Transform] -> Attrs
attrs :: Int32 -> Int32 -> [Transform] -> Attrs
attrs Int32
samplerId Int32
textureId [Transform]
transforms = Attrs
  { $sel:params:Attrs :: HKD Identity TextureParams
params = TextureParams
forall a. Zero a => a
zero
      { $sel:tpSamplerId:TextureParams :: Int32
tpSamplerId = Int32
samplerId
      , $sel:tpTextureId:TextureParams :: Int32
tpTextureId = Int32
textureId
      }
  , $sel:transforms:Attrs :: HKD Identity Transform
transforms = [Transform] -> Transform
forall a. Monoid a => [a] -> a
mconcat [Transform]
transforms
  }

attrStores :: Foldable t => t Attrs -> Stores
attrStores :: forall (t :: * -> *). Foldable t => t Attrs -> Stores
attrStores t Attrs
source = Attrs
  { $sel:params:Attrs :: HKD Vector TextureParams
params = [TextureParams] -> Vector TextureParams
forall a. Storable a => [a] -> Vector a
Storable.fromList ([TextureParams] -> Vector TextureParams)
-> [TextureParams] -> Vector TextureParams
forall a b. (a -> b) -> a -> b
$ (Attrs -> TextureParams) -> [Attrs] -> [TextureParams]
forall a b. (a -> b) -> [a] -> [b]
map (.params) ([Attrs] -> [TextureParams]) -> [Attrs] -> [TextureParams]
forall a b. (a -> b) -> a -> b
$ t Attrs -> [Attrs]
forall a. t a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList t Attrs
source
  , $sel:transforms:Attrs :: HKD Vector Transform
transforms = [Transform] -> Vector Transform
forall a. Storable a => [a] -> Vector a
Storable.fromList ([Transform] -> Vector Transform)
-> [Transform] -> Vector Transform
forall a b. (a -> b) -> a -> b
$ (Attrs -> Transform) -> [Attrs] -> [Transform]
forall a b. (a -> b) -> [a] -> [b]
map (.transforms) ([Attrs] -> [Transform]) -> [Attrs] -> [Transform]
forall a b. (a -> b) -> a -> b
$ t Attrs -> [Attrs]
forall a. t a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList t Attrs
source
  }

stores1 :: Int32 -> Int32 -> [Transform] -> Stores
stores1 :: Int32 -> Int32 -> [Transform] -> Stores
stores1 Int32
samplerId Int32
textureId [Transform]
transforms =
  Attrs
    { $sel:params:Attrs :: HKD Vector TextureParams
params = TextureParams -> Vector TextureParams
forall a. Storable a => a -> Vector a
Storable.singleton Attrs
attrs1.params
    , $sel:transforms:Attrs :: HKD Vector Transform
transforms = Transform -> Vector Transform
forall a. Storable a => a -> Vector a
Storable.singleton Attrs
attrs1.transforms
    }
  where
    attrs1 :: Attrs
attrs1 = Int32 -> Int32 -> [Transform] -> Attrs
attrs
      Int32
samplerId
      Int32
textureId
      [Transform]
transforms

data TextureParams = TextureParams
  { TextureParams -> Vec2
tpScale     :: Vec2
  , TextureParams -> Vec2
tpOffset    :: Vec2
  , TextureParams -> Vec4
tpGamma     :: Vec4
  , TextureParams -> Int32
tpSamplerId :: Int32
  , TextureParams -> Int32
tpTextureId :: Int32
  }
  deriving ((forall x. TextureParams -> Rep TextureParams x)
-> (forall x. Rep TextureParams x -> TextureParams)
-> Generic TextureParams
forall x. Rep TextureParams x -> TextureParams
forall x. TextureParams -> Rep TextureParams x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TextureParams -> Rep TextureParams x
from :: forall x. TextureParams -> Rep TextureParams x
$cto :: forall x. Rep TextureParams x -> TextureParams
to :: forall x. Rep TextureParams x -> TextureParams
Generic, 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
$cshowsPrec :: Int -> TextureParams -> ShowS
showsPrec :: Int -> TextureParams -> ShowS
$cshow :: TextureParams -> String
show :: TextureParams -> String
$cshowList :: [TextureParams] -> ShowS
showList :: [TextureParams] -> ShowS
Show, (forall (proxy :: * -> *). proxy TextureParams -> Int)
-> (forall (proxy :: * -> *). proxy TextureParams -> Int)
-> (forall (proxy :: * -> *). proxy TextureParams -> Bool)
-> (forall (m :: * -> *) a.
    MonadIO m =>
    Ptr a -> Diff a TextureParams -> m TextureParams)
-> (forall (m :: * -> *) a.
    MonadIO m =>
    Ptr a -> Diff a TextureParams -> TextureParams -> m ())
-> (forall (proxy :: * -> *). proxy TextureParams -> Int)
-> (forall (proxy :: * -> *). proxy TextureParams -> Int)
-> (forall (m :: * -> *) a.
    MonadIO m =>
    Ptr a -> Diff a TextureParams -> m TextureParams)
-> (forall (m :: * -> *) a.
    MonadIO m =>
    Ptr a -> Diff a TextureParams -> TextureParams -> m ())
-> (forall (proxy :: * -> *). proxy TextureParams -> Int)
-> (forall (m :: * -> *) a.
    MonadIO m =>
    Ptr a -> Diff a TextureParams -> m TextureParams)
-> (forall (m :: * -> *) a.
    MonadIO m =>
    Ptr a -> Diff a TextureParams -> TextureParams -> m ())
-> Block TextureParams
forall b.
(forall (proxy :: * -> *). proxy b -> Int)
-> (forall (proxy :: * -> *). proxy b -> Int)
-> (forall (proxy :: * -> *). proxy b -> Bool)
-> (forall (m :: * -> *) a. MonadIO m => Ptr a -> Diff a b -> m b)
-> (forall (m :: * -> *) a.
    MonadIO m =>
    Ptr a -> Diff a b -> b -> m ())
-> (forall (proxy :: * -> *). proxy b -> Int)
-> (forall (proxy :: * -> *). proxy b -> Int)
-> (forall (m :: * -> *) a. MonadIO m => Ptr a -> Diff a b -> m b)
-> (forall (m :: * -> *) a.
    MonadIO m =>
    Ptr a -> Diff a b -> b -> m ())
-> (forall (proxy :: * -> *). proxy b -> Int)
-> (forall (m :: * -> *) a. MonadIO m => Ptr a -> Diff a b -> m b)
-> (forall (m :: * -> *) a.
    MonadIO m =>
    Ptr a -> Diff a b -> b -> m ())
-> Block b
forall (proxy :: * -> *). proxy TextureParams -> Bool
forall (proxy :: * -> *). proxy TextureParams -> Int
forall (m :: * -> *) a.
MonadIO m =>
Ptr a -> Diff a TextureParams -> m TextureParams
forall (m :: * -> *) a.
MonadIO m =>
Ptr a -> Diff a TextureParams -> TextureParams -> m ()
$calignment140 :: forall (proxy :: * -> *). proxy TextureParams -> Int
alignment140 :: forall (proxy :: * -> *). proxy TextureParams -> Int
$csizeOf140 :: forall (proxy :: * -> *). proxy TextureParams -> Int
sizeOf140 :: forall (proxy :: * -> *). proxy TextureParams -> Int
$cisStruct :: forall (proxy :: * -> *). proxy TextureParams -> Bool
isStruct :: forall (proxy :: * -> *). proxy TextureParams -> Bool
$cread140 :: forall (m :: * -> *) a.
MonadIO m =>
Ptr a -> Diff a TextureParams -> m TextureParams
read140 :: forall (m :: * -> *) a.
MonadIO m =>
Ptr a -> Diff a TextureParams -> m TextureParams
$cwrite140 :: forall (m :: * -> *) a.
MonadIO m =>
Ptr a -> Diff a TextureParams -> TextureParams -> m ()
write140 :: forall (m :: * -> *) a.
MonadIO m =>
Ptr a -> Diff a TextureParams -> TextureParams -> m ()
$calignment430 :: forall (proxy :: * -> *). proxy TextureParams -> Int
alignment430 :: forall (proxy :: * -> *). proxy TextureParams -> Int
$csizeOf430 :: forall (proxy :: * -> *). proxy TextureParams -> Int
sizeOf430 :: forall (proxy :: * -> *). proxy TextureParams -> Int
$cread430 :: forall (m :: * -> *) a.
MonadIO m =>
Ptr a -> Diff a TextureParams -> m TextureParams
read430 :: forall (m :: * -> *) a.
MonadIO m =>
Ptr a -> Diff a TextureParams -> m TextureParams
$cwrite430 :: forall (m :: * -> *) a.
MonadIO m =>
Ptr a -> Diff a TextureParams -> TextureParams -> m ()
write430 :: forall (m :: * -> *) a.
MonadIO m =>
Ptr a -> Diff a TextureParams -> TextureParams -> m ()
$csizeOfPacked :: forall (proxy :: * -> *). proxy TextureParams -> Int
sizeOfPacked :: forall (proxy :: * -> *). proxy TextureParams -> Int
$creadPacked :: forall (m :: * -> *) a.
MonadIO m =>
Ptr a -> Diff a TextureParams -> m TextureParams
readPacked :: forall (m :: * -> *) a.
MonadIO m =>
Ptr a -> Diff a TextureParams -> m TextureParams
$cwritePacked :: forall (m :: * -> *) a.
MonadIO m =>
Ptr a -> Diff a TextureParams -> TextureParams -> m ()
writePacked :: forall (m :: * -> *) a.
MonadIO m =>
Ptr a -> Diff a TextureParams -> TextureParams -> m ()
Block)
  deriving Ptr TextureParams -> IO TextureParams
Ptr TextureParams -> Int -> IO TextureParams
Ptr TextureParams -> Int -> TextureParams -> IO ()
Ptr TextureParams -> TextureParams -> IO ()
TextureParams -> Int
(TextureParams -> Int)
-> (TextureParams -> Int)
-> (Ptr TextureParams -> Int -> IO TextureParams)
-> (Ptr TextureParams -> Int -> TextureParams -> IO ())
-> (forall b. Ptr b -> Int -> IO TextureParams)
-> (forall b. Ptr b -> Int -> TextureParams -> IO ())
-> (Ptr TextureParams -> IO TextureParams)
-> (Ptr TextureParams -> TextureParams -> IO ())
-> Storable TextureParams
forall b. Ptr b -> Int -> IO TextureParams
forall b. Ptr b -> Int -> TextureParams -> IO ()
forall a.
(a -> Int)
-> (a -> Int)
-> (Ptr a -> Int -> IO a)
-> (Ptr a -> Int -> a -> IO ())
-> (forall b. Ptr b -> Int -> IO a)
-> (forall b. Ptr b -> Int -> a -> IO ())
-> (Ptr a -> IO a)
-> (Ptr a -> a -> IO ())
-> Storable a
$csizeOf :: TextureParams -> Int
sizeOf :: TextureParams -> Int
$calignment :: TextureParams -> Int
alignment :: TextureParams -> Int
$cpeekElemOff :: Ptr TextureParams -> Int -> IO TextureParams
peekElemOff :: Ptr TextureParams -> Int -> IO TextureParams
$cpokeElemOff :: Ptr TextureParams -> Int -> TextureParams -> IO ()
pokeElemOff :: Ptr TextureParams -> Int -> TextureParams -> IO ()
$cpeekByteOff :: forall b. Ptr b -> Int -> IO TextureParams
peekByteOff :: forall b. Ptr b -> Int -> IO TextureParams
$cpokeByteOff :: forall b. Ptr b -> Int -> TextureParams -> IO ()
pokeByteOff :: forall b. Ptr b -> Int -> TextureParams -> IO ()
$cpeek :: Ptr TextureParams -> IO TextureParams
peek :: Ptr TextureParams -> IO TextureParams
$cpoke :: Ptr TextureParams -> TextureParams -> IO ()
poke :: Ptr TextureParams -> TextureParams -> IO ()
Storable via (Block.Packed TextureParams)

instance Zero TextureParams where
  zero :: TextureParams
zero = TextureParams
    { $sel:tpScale:TextureParams :: Vec2
tpScale     = Vec2
1.0
    , $sel:tpOffset:TextureParams :: Vec2
tpOffset    = Vec2
0.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 HasVkFormat TextureParams where
  getVkFormat :: [Format]
getVkFormat =
    [ Format
Vk.FORMAT_R32G32B32A32_SFLOAT -- iTextureScaleOffset :: vec4
    , Format
Vk.FORMAT_R32G32B32A32_SFLOAT -- iTextureGamma       :: vec4
    , Format
Vk.FORMAT_R32G32_SINT         -- iTextureIds         :: ivec2
    ]