{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE BlockArguments, LambdaCase, TupleSections #-}
{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeApplications #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures, TypeOperators #-}
{-# LANGUAGE MultiParamTypeClasses, AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-}
{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}

module Gpu.Vulkan.Memory.ImageBuffer (

	-- * IMAGE BUFFER

	ImageBuffer(..), ImageBufferBinded(..), ImageBufferArg(..),

	-- * GET REQUIREMENTS LIST

	getRequirementsList, getRequirementsListBinded,

	-- * ADJUST OFFSET AND GET SIZE

	adjustOffsetSize, adjustOffsetSizeBinded,

	-- * FOR BIND

	Alignments(..),

	-- * FOR READ AND WRITE

	ObjectLength(..)

	) where

import Prelude hiding (map, read)
import GHC.TypeLits
import Data.Kind
import Data.TypeLevel.Tuple.Uncurry
import Gpu.Vulkan.Object qualified as VObj
import Data.HeteroParList qualified as HeteroParList
import Data.HeteroParList (pattern (:**))

import qualified Gpu.Vulkan.Image.Type as Image
import qualified Gpu.Vulkan.Buffer.Type as Buffer

import qualified Gpu.Vulkan.TypeEnum as T

import qualified Gpu.Vulkan.Device.Type as Device
import qualified Gpu.Vulkan.Device.Middle as Device.M

import qualified Gpu.Vulkan.Image.Middle as Image.M
import qualified Gpu.Vulkan.Buffer.Middle as Buffer.M
import qualified Gpu.Vulkan.Memory.Middle as Memory.M

-- IMAGE BUFFER

data ImageBuffer s (ibarg :: ImageBufferArg) where
	Image :: Image.I si nm fmt -> ImageBuffer si ('ImageArg nm fmt)
	Buffer :: Buffer.B sb nm objs -> ImageBuffer sb ('BufferArg nm objs)

deriving instance Show (HeteroParList.PL VObj.Length objs) =>
	Show (ImageBuffer sib ('BufferArg nm objs))

data ImageBufferBinded sm sib (ibarg :: ImageBufferArg) where
	ImageBinded :: Image.Binded sm si nm fmt ->
		ImageBufferBinded sm si ('ImageArg nm fmt)
	BufferBinded :: Buffer.Binded sm sb nm objs ->
		ImageBufferBinded sm sb ('BufferArg nm objs)

deriving instance Show (HeteroParList.PL VObj.Length objs) =>
	Show (ImageBufferBinded sm sib ('BufferArg nm objs))

data ImageBufferArg = ImageArg Symbol T.Format | BufferArg Symbol [VObj.O]

-- GET REQUIREMENTS LIST

getRequirementsList :: Device.D sd ->
	HeteroParList.PL (U2 ImageBuffer) ibargs -> IO [Memory.M.Requirements]
getRequirementsList :: forall sd (ibargs :: [(*, ImageBufferArg)]).
D sd -> PL (U2 ImageBuffer) ibargs -> IO [Requirements]
getRequirementsList D sd
dv =
	(forall (s :: (*, ImageBufferArg)).
 U2 ImageBuffer s -> IO Requirements)
-> PL (U2 ImageBuffer) ibargs -> IO [Requirements]
forall (m :: * -> *) k (t :: k -> *) a (ss :: [k]).
Applicative m =>
(forall (s :: k). t s -> m a) -> PL t ss -> m [a]
HeteroParList.toListM \(U2 ImageBuffer s1 s2
bi) -> D sd -> ImageBuffer s1 s2 -> IO Requirements
forall sd sib (fos :: ImageBufferArg).
D sd -> ImageBuffer sib fos -> IO Requirements
getMemoryRequirements D sd
dv ImageBuffer s1 s2
bi

getRequirementsListBinded ::
	Device.D sd -> HeteroParList.PL (U2 (ImageBufferBinded sm)) ibargs ->
	IO [Memory.M.Requirements]
getRequirementsListBinded :: forall sd sm (ibargs :: [(*, ImageBufferArg)]).
D sd -> PL (U2 (ImageBufferBinded sm)) ibargs -> IO [Requirements]
getRequirementsListBinded D sd
dv =
	(forall (s :: (*, ImageBufferArg)).
 U2 (ImageBufferBinded sm) s -> IO Requirements)
-> PL (U2 (ImageBufferBinded sm)) ibargs -> IO [Requirements]
forall (m :: * -> *) k (t :: k -> *) a (ss :: [k]).
Applicative m =>
(forall (s :: k). t s -> m a) -> PL t ss -> m [a]
HeteroParList.toListM \(U2 ImageBufferBinded sm s1 s2
bi) -> D sd -> ImageBufferBinded sm s1 s2 -> IO Requirements
forall sd sm sib (fos :: ImageBufferArg).
D sd -> ImageBufferBinded sm sib fos -> IO Requirements
getMemoryRequirementsBinded D sd
dv ImageBufferBinded sm s1 s2
bi

getMemoryRequirements ::
	Device.D sd -> ImageBuffer sib fos -> IO Memory.M.Requirements
getMemoryRequirements :: forall sd sib (fos :: ImageBufferArg).
D sd -> ImageBuffer sib fos -> IO Requirements
getMemoryRequirements (Device.D D
dv) = \case
	Buffer (Buffer.B PL Length objs
_ B
b) -> D -> B -> IO Requirements
Buffer.M.getMemoryRequirements D
dv B
b
	Image (Image.I I
i) -> D -> I -> IO Requirements
Image.M.getMemoryRequirements D
dv I
i

getMemoryRequirementsBinded ::
	Device.D sd -> ImageBufferBinded sm sib fos -> IO Memory.M.Requirements
getMemoryRequirementsBinded :: forall sd sm sib (fos :: ImageBufferArg).
D sd -> ImageBufferBinded sm sib fos -> IO Requirements
getMemoryRequirementsBinded (Device.D D
dv) = \case
	BufferBinded (Buffer.Binded PL Length objs
_ B
b) -> D -> B -> IO Requirements
Buffer.M.getMemoryRequirements D
dv B
b
	ImageBinded (Image.Binded I
i) -> D -> I -> IO Requirements
Image.M.getMemoryRequirements D
dv I
i

-- ADJUST OFFSET AND GET SIZE

adjustOffsetSize :: Device.D sd -> ImageBuffer sib ibarg -> Device.M.Size ->
	IO (Device.M.Size, Device.M.Size)
adjustOffsetSize :: forall sd sib (ibarg :: ImageBufferArg).
D sd -> ImageBuffer sib ibarg -> Size -> IO (Size, Size)
adjustOffsetSize D sd
dv ImageBuffer sib ibarg
ib Size
ost = ((Requirements -> (Size, Size))
-> IO Requirements -> IO (Size, Size)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> D sd -> ImageBuffer sib ibarg -> IO Requirements
forall sd sib (fos :: ImageBufferArg).
D sd -> ImageBuffer sib fos -> IO Requirements
getMemoryRequirements D sd
dv ImageBuffer sib ibarg
ib) \Requirements
rs -> (
	Size -> Size -> Size
adjust (Requirements -> Size
Memory.M.requirementsAlignment Requirements
rs) Size
ost,
	Requirements -> Size
Memory.M.requirementsSize Requirements
rs )

adjustOffsetSizeBinded :: Device.D sd -> ImageBufferBinded sm sib ibarg ->
	Device.M.Size -> IO (Device.M.Size, Device.M.Size)
adjustOffsetSizeBinded :: forall sd sm sib (ibarg :: ImageBufferArg).
D sd -> ImageBufferBinded sm sib ibarg -> Size -> IO (Size, Size)
adjustOffsetSizeBinded D sd
dv ImageBufferBinded sm sib ibarg
ib Size
ost =
	((Requirements -> (Size, Size))
-> IO Requirements -> IO (Size, Size)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> D sd -> ImageBufferBinded sm sib ibarg -> IO Requirements
forall sd sm sib (fos :: ImageBufferArg).
D sd -> ImageBufferBinded sm sib fos -> IO Requirements
getMemoryRequirementsBinded D sd
dv ImageBufferBinded sm sib ibarg
ib) \Requirements
rs -> (
		Size -> Size -> Size
adjust (Requirements -> Size
Memory.M.requirementsAlignment Requirements
rs) Size
ost,
		Requirements -> Size
Memory.M.requirementsSize Requirements
rs )

adjust :: Device.M.Size -> Device.M.Size -> Device.M.Size
adjust :: Size -> Size -> Size
adjust Size
algn Size
ost = ((Size
ost Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
1) Size -> Size -> Size
forall a. Integral a => a -> a -> a
`div` Size
algn Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
1) Size -> Size -> Size
forall a. Num a => a -> a -> a
* Size
algn

-- ALIGNMENTS

class Alignments (ibs :: [(Type, ImageBufferArg)]) where
	alignments :: [Maybe Device.M.Size]

instance Alignments '[] where alignments :: [Maybe Size]
alignments = []

instance Alignments ibs => Alignments ('(_s, 'ImageArg _nm _fmt) ': ibs) where
	alignments :: [Maybe Size]
alignments = Maybe Size
forall a. Maybe a
Nothing Maybe Size -> [Maybe Size] -> [Maybe Size]
forall a. a -> [a] -> [a]
: forall (ibs :: [(*, ImageBufferArg)]).
Alignments ibs =>
[Maybe Size]
alignments @ibs

instance (VObj.WholeAlign objs, Alignments ibs) =>
	Alignments ('(_s, 'BufferArg _nm objs) ': ibs) where
	alignments :: [Maybe Size]
alignments = Size -> Maybe Size
forall a. a -> Maybe a
Just (forall (objs :: [O]). WholeAlign objs => Size
VObj.wholeAlign @objs) Maybe Size -> [Maybe Size] -> [Maybe Size]
forall a. a -> [a] -> [a]
: forall (ibs :: [(*, ImageBufferArg)]).
Alignments ibs =>
[Maybe Size]
alignments @ibs

-- OBJECT LENGTH

class ObjectLength (nm :: Symbol) (obj :: VObj.O) ibargs where
	objectLength' :: HeteroParList.PL (U2 ImageBuffer) ibargs ->
		VObj.Length obj

instance VObj.LengthOf obj objs =>
	ObjectLength nm obj ('(sib, 'BufferArg nm objs) ': ibargs) where
	objectLength' :: PL (U2 ImageBuffer) ('(sib, 'BufferArg nm objs) : ibargs)
-> Length obj
objectLength' (U2 (Buffer (Buffer.B PL Length objs
lns B
_)) :** PL (U2 ImageBuffer) ss1
_) =
		forall (obj :: O) (objs :: [O]).
LengthOf obj objs =>
PL Length objs -> Length obj
VObj.lengthOf @obj PL Length objs
lns

instance {-# OVERLAPPABLE #-} ObjectLength nm obj ibargs =>
	ObjectLength nm obj (ibarg ': ibargs) where
	objectLength' :: PL (U2 ImageBuffer) (ibarg : ibargs) -> Length obj
objectLength' (U2 ImageBuffer s
_ :** PL (U2 ImageBuffer) ss1
lns) = forall (nm :: Symbol) (obj :: O) (ibargs :: [(*, ImageBufferArg)]).
ObjectLength nm obj ibargs =>
PL (U2 ImageBuffer) ibargs -> Length obj
objectLength' @nm @obj PL (U2 ImageBuffer) ss1
lns