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

module Gpu.Vulkan.Object.Base (

	-- * OBJECT

	O(..), IsImage(..),

	-- ** Synonyms

	Atom, AtomNew, List, Image,
	AtomNoName, ListNoName, ImageNoName,
	AtomMaybeName, ListMaybeName, ImageMaybeName,

	-- ** Type Of Object

	TypeOf,

	-- * OBJECT LENGTH

	Length(..), renameLength,

	-- * STORE OBJECT

	Store(..),

	-- * SIZE AND ALIGNMENT

	SizeAlignment(..)

	) where

import GHC.TypeLits
import Foreign.Ptr
import Foreign.Marshal.Array
import Foreign.Storable qualified as S
import Data.Kind
import Data.Foldable
import Data.Traversable
import Data.MonoTraversable
import Data.Proxy
import Data.Default

import qualified Data.Sequences as Seq

import Gpu.Vulkan.TypeEnum qualified as T

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

-- OBJECT

data O = O Alignment (Maybe Symbol) ObjectType Type

type Alignment = Nat

data ObjectType = AtomT | ListT | ImageT deriving Int -> ObjectType -> ShowS
[ObjectType] -> ShowS
ObjectType -> String
(Int -> ObjectType -> ShowS)
-> (ObjectType -> String)
-> ([ObjectType] -> ShowS)
-> Show ObjectType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ObjectType -> ShowS
showsPrec :: Int -> ObjectType -> ShowS
$cshow :: ObjectType -> String
show :: ObjectType -> String
$cshowList :: [ObjectType] -> ShowS
showList :: [ObjectType] -> ShowS
Show

class (S.Storable (ImagePixel img), T.FormatToValue (ImageFormat img)) =>
	IsImage img where
	type ImagePixel img
	type ImageFormat img :: T.Format
	imageRow :: img -> Device.M.Size
	imageWidth :: img -> Device.M.Size
	imageHeight :: img -> Device.M.Size
	imageDepth :: img -> Device.M.Size
	imageBody :: img -> [[ImagePixel img]]
	imageMake :: Device.M.Size -> Device.M.Size -> Device.M.Size ->
		[[ImagePixel img]] -> img

-- Synonyms

type Atom algn t mnm = AtomMaybeName algn t mnm
type AtomNew algn t nm = AtomMaybeName algn t ('Just nm)
type List algn t nm = ListMaybeName algn t ('Just nm)
type Image algn t nm = ImageMaybeName algn t ('Just nm)

type AtomNoName al t = AtomMaybeName al t 'Nothing
type ListNoName al t = ListMaybeName al t 'Nothing
type ImageNoName al t = ImageMaybeName al t 'Nothing

type AtomMaybeName al t mnm = 'O al mnm AtomT t
type ListMaybeName al t mnm = 'O al mnm ListT t
type ImageMaybeName al t mnm = 'O al mnm ImageT t

-- Type of Object

type family TypeOf obj where
	TypeOf ((Atom _algn t _nm)) = t
	TypeOf ((List _algn t _nm)) = t

-- OBJECT LENGTH

data Length (obj :: O) where
	LengthAtom :: Length (Atom algn t nm)
	LengthList :: Device.M.Size -> Length ('O algn mnm ListT t)
	LengthImage :: {
		forall (algn :: Alignment) (mnm :: Maybe Symbol) t.
Length ('O algn mnm 'ImageT t) -> Size
lengthImageRow :: Device.M.Size,
		forall (algn :: Alignment) (mnm :: Maybe Symbol) t.
Length ('O algn mnm 'ImageT t) -> Size
lengthImageWidth :: Device.M.Size,
		forall (algn :: Alignment) (mnm :: Maybe Symbol) t.
Length ('O algn mnm 'ImageT t) -> Size
lengthImageHeight :: Device.M.Size,
		forall (algn :: Alignment) (mnm :: Maybe Symbol) t.
Length ('O algn mnm 'ImageT t) -> Size
lengthImageDepth :: Device.M.Size } ->
		Length ('O algn mnm ImageT t)

deriving instance Eq (Length obj)
deriving instance Show (Length obj)

instance Default (Length (Atom algn t mnm)) where def :: Length (Atom algn t mnm)
def = Length (Atom algn t mnm)
forall (algn :: Alignment) t (mnm :: Maybe Symbol).
Length (Atom algn t mnm)
LengthAtom
instance Default (Length (List algn t nm)) where def :: Length (List algn t nm)
def = Size -> Length (List algn t nm)
forall (algn :: Alignment) (mnm :: Maybe Symbol) t.
Size -> Length ('O algn mnm 'ListT t)
LengthList Size
0
instance Default (Length (Image algn t nm)) where def :: Length (Image algn t nm)
def = Size -> Size -> Size -> Size -> Length (Image algn t nm)
forall (algn :: Alignment) (mnm :: Maybe Symbol) t.
Size -> Size -> Size -> Size -> Length ('O algn mnm 'ImageT t)
LengthImage Size
0 Size
0 Size
0 Size
0

renameLength :: Length ('O algn mnm ot t) -> Length ('O algn mnm' ot t)
renameLength :: forall (algn :: Alignment) (mnm :: Maybe Symbol) (ot :: ObjectType)
       t (mnm' :: Maybe Symbol).
Length ('O algn mnm ot t) -> Length ('O algn mnm' ot t)
renameLength Length ('O algn mnm ot t)
LengthAtom = Length ('O algn mnm' ot t)
Length (Atom algn t mnm')
forall (algn :: Alignment) t (mnm :: Maybe Symbol).
Length (Atom algn t mnm)
LengthAtom
renameLength (LengthList Size
n) = Size -> Length ('O algn mnm' 'ListT t)
forall (algn :: Alignment) (mnm :: Maybe Symbol) t.
Size -> Length ('O algn mnm 'ListT t)
LengthList Size
n
renameLength (LengthImage Size
r Size
w Size
h Size
d) = Size -> Size -> Size -> Size -> Length ('O algn mnm' 'ImageT t)
forall (algn :: Alignment) (mnm :: Maybe Symbol) t.
Size -> Size -> Size -> Size -> Length ('O algn mnm 'ImageT t)
LengthImage Size
r Size
w Size
h Size
d

-- STORE OBJECT

class SizeAlignment obj => Store v (obj :: O) where
	store :: Ptr (TypeOf obj) -> Length obj -> v -> IO ()
	load :: Ptr (TypeOf obj) -> Length obj -> IO v
	length :: v -> Length obj

instance (S.Storable t, KnownNat algn) => Store t ((Atom algn t _nm)) where
	store :: Ptr (TypeOf (Atom algn t _nm))
-> Length (Atom algn t _nm) -> t -> IO ()
store Ptr (TypeOf (Atom algn t _nm))
p (Length (Atom algn t _nm)
LengthAtom) t
x = Ptr t -> t -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
S.poke Ptr t
Ptr (TypeOf (Atom algn t _nm))
p t
x
	load :: Ptr (TypeOf (Atom algn t _nm)) -> Length (Atom algn t _nm) -> IO t
load Ptr (TypeOf (Atom algn t _nm))
p (Length (Atom algn t _nm)
LengthAtom) = Ptr t -> IO t
forall a. Storable a => Ptr a -> IO a
S.peek Ptr t
Ptr (TypeOf (Atom algn t _nm))
p
	length :: t -> Length (Atom algn t _nm)
length t
_ = Length (Atom algn t _nm)
forall (algn :: Alignment) t (mnm :: Maybe Symbol).
Length (Atom algn t mnm)
LengthAtom

instance (KnownNat algn, Seq.IsSequence v, S.Storable t, Element v ~ t) =>
	Store v ((List algn t _nm)) where
	store :: Ptr (TypeOf (List algn t _nm))
-> Length (List algn t _nm) -> v -> IO ()
store Ptr (TypeOf (List algn t _nm))
p ((LengthList (Size -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Int
n))) v
xs =
		Ptr t -> [t] -> IO ()
forall a. Storable a => Ptr a -> [a] -> IO ()
pokeArray Ptr t
Ptr (TypeOf (List algn t _nm))
p ([t] -> IO ()) -> ([t] -> [t]) -> [t] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [t] -> [t]
forall a. Int -> [a] -> [a]
take Int
n ([t] -> IO ()) -> [t] -> IO ()
forall a b. (a -> b) -> a -> b
$ v -> [Element v]
forall mono. MonoFoldable mono => mono -> [Element mono]
otoList v
xs
	load :: Ptr (TypeOf (List algn t _nm)) -> Length (List algn t _nm) -> IO v
load Ptr (TypeOf (List algn t _nm))
p (LengthList (Size -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Int
n)) = [t] -> v
[Element v] -> v
forall seq. IsSequence seq => [Element seq] -> seq
Seq.fromList ([t] -> v) -> IO [t] -> IO v
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Ptr t -> IO [t]
forall a. Storable a => Int -> Ptr a -> IO [a]
peekArray Int
n Ptr t
Ptr (TypeOf (List algn t _nm))
p
	length :: v -> Length (List algn t _nm)
length = Size -> Length (List algn t _nm)
forall (algn :: Alignment) (mnm :: Maybe Symbol) t.
Size -> Length ('O algn mnm 'ListT t)
LengthList (Size -> Length (List algn t _nm))
-> (v -> Size) -> v -> Length (List algn t _nm)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Size) -> (v -> Int) -> v -> Size
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> Int
forall mono. MonoFoldable mono => mono -> Int
olength

instance (KnownNat algn, IsImage img) =>
	Store img ((Image algn img nm)) where
	store :: Ptr (TypeOf (Image algn img nm))
-> Length (Image algn img nm) -> img -> IO ()
store Ptr (TypeOf (Image algn img nm))
p0 (LengthImage (Size -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Int
r) (Size -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Int
w) Size
_ Size
_) img
img =
		[(Ptr (TypeOf (Image algn img nm)), [ImagePixel img])]
-> ((Ptr (TypeOf (Image algn img nm)), [ImagePixel img]) -> IO ())
-> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ([Ptr (TypeOf (Image algn img nm))]
-> [[ImagePixel img]]
-> [(Ptr (TypeOf (Image algn img nm)), [ImagePixel img])]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Ptr (TypeOf (Image algn img nm))
 -> Ptr (TypeOf (Image algn img nm)))
-> Ptr (TypeOf (Image algn img nm))
-> [Ptr (TypeOf (Image algn img nm))]
forall a. (a -> a) -> a -> [a]
iterate (Ptr (TypeOf (Image algn img nm))
-> Int -> Ptr (TypeOf (Image algn img nm))
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
s) Ptr (TypeOf (Image algn img nm))
p0) ([[ImagePixel img]]
 -> [(Ptr (TypeOf (Image algn img nm)), [ImagePixel img])])
-> [[ImagePixel img]]
-> [(Ptr (TypeOf (Image algn img nm)), [ImagePixel img])]
forall a b. (a -> b) -> a -> b
$ img -> [[ImagePixel img]]
forall img. IsImage img => img -> [[ImagePixel img]]
imageBody img
img)
			\(Ptr (TypeOf (Image algn img nm))
p, Int -> [ImagePixel img] -> [ImagePixel img]
forall a. Int -> [a] -> [a]
take Int
w -> [ImagePixel img]
rw) -> Ptr (ImagePixel img) -> [ImagePixel img] -> IO ()
forall a. Storable a => Ptr a -> [a] -> IO ()
pokeArray (Ptr (TypeOf (Image algn img nm)) -> Ptr (ImagePixel img)
forall a b. Ptr a -> Ptr b
castPtr Ptr (TypeOf (Image algn img nm))
p) [ImagePixel img]
rw
		where s :: Int
s = Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
* forall a. Storable a => a -> Int
S.sizeOf @(ImagePixel img) ImagePixel img
forall a. HasCallStack => a
undefined
	load :: Ptr (TypeOf (Image algn img nm))
-> Length (Image algn img nm) -> IO img
load Ptr (TypeOf (Image algn img nm))
p0 (LengthImage (Size -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Int
r)
		w_ :: Size
w_@(Size -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Int
w) h_ :: Size
h_@(Size -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Int
h)
		d_ :: Size
d_@(Size -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Int
d)) =
		Size -> Size -> Size -> [[ImagePixel img]] -> img
forall img.
IsImage img =>
Size -> Size -> Size -> [[ImagePixel img]] -> img
imageMake Size
w_ Size
h_ Size
d_
			([[ImagePixel img]] -> img) -> IO [[ImagePixel img]] -> IO img
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Ptr (TypeOf (Image algn img nm))]
-> (Ptr (TypeOf (Image algn img nm)) -> IO [ImagePixel img])
-> IO [[ImagePixel img]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (Int
-> [Ptr (TypeOf (Image algn img nm))]
-> [Ptr (TypeOf (Image algn img nm))]
forall a. Int -> [a] -> [a]
take (Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
d) ([Ptr (TypeOf (Image algn img nm))]
 -> [Ptr (TypeOf (Image algn img nm))])
-> [Ptr (TypeOf (Image algn img nm))]
-> [Ptr (TypeOf (Image algn img nm))]
forall a b. (a -> b) -> a -> b
$ (Ptr (TypeOf (Image algn img nm))
 -> Ptr (TypeOf (Image algn img nm)))
-> Ptr (TypeOf (Image algn img nm))
-> [Ptr (TypeOf (Image algn img nm))]
forall a. (a -> a) -> a -> [a]
iterate (Ptr (TypeOf (Image algn img nm))
-> Int -> Ptr (TypeOf (Image algn img nm))
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
s) Ptr (TypeOf (Image algn img nm))
p0) \Ptr (TypeOf (Image algn img nm))
p ->
				Int -> Ptr (ImagePixel img) -> IO [ImagePixel img]
forall a. Storable a => Int -> Ptr a -> IO [a]
peekArray Int
w (Ptr (TypeOf (Image algn img nm)) -> Ptr (ImagePixel img)
forall a b. Ptr a -> Ptr b
castPtr Ptr (TypeOf (Image algn img nm))
p)
		where s :: Int
s = Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
* (forall a. Storable a => a -> Int
S.sizeOf @(ImagePixel img) ImagePixel img
forall a. HasCallStack => a
undefined)
	length :: img -> Length (Image algn img nm)
length img
img = Size -> Size -> Size -> Size -> Length (Image algn img nm)
forall (algn :: Alignment) (mnm :: Maybe Symbol) t.
Size -> Size -> Size -> Size -> Length ('O algn mnm 'ImageT t)
LengthImage
		(img -> Size
forall img. IsImage img => img -> Size
imageRow img
img) (img -> Size
forall img. IsImage img => img -> Size
imageWidth img
img) (img -> Size
forall img. IsImage img => img -> Size
imageHeight img
img)
		(img -> Size
forall img. IsImage img => img -> Size
imageDepth img
img)

-- SIZE AND ALIGNMENT

class SizeAlignment obj where
	size :: Length obj -> Device.M.Size
	alignment :: Device.M.Size

instance (KnownNat algn, S.Storable t) =>
	SizeAlignment ((AtomMaybeName algn t _nm)) where
	size :: Length (AtomMaybeName algn t _nm) -> Size
size (Length (AtomMaybeName algn t _nm)
LengthAtom) =
		Size -> Size -> Size
forall n. Integral n => n -> n -> n
applyAlign Size
algn (Size -> Size) -> (Int -> Size) -> Int -> Size
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Size) -> Int -> Size
forall a b. (a -> b) -> a -> b
$ forall a. Storable a => a -> Int
S.sizeOf @t t
forall a. HasCallStack => a
undefined
		where algn :: Size
algn = forall (obj :: O). SizeAlignment obj => Size
alignment @((AtomMaybeName algn t _nm))
	alignment :: Size
alignment = Integer -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Proxy algn -> Integer
forall (n :: Alignment) (proxy :: Alignment -> *).
KnownNat n =>
proxy n -> Integer
natVal (Proxy algn
forall {k} (t :: k). Proxy t
Proxy :: Proxy algn)) Size -> Size -> Size
forall n. Integral n => n -> n -> n
`lcm`
		Int -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Storable a => a -> Int
S.alignment @t t
forall a. HasCallStack => a
undefined)

instance (KnownNat algn, S.Storable t) => SizeAlignment (ListMaybeName algn t _nm) where
	size :: Length (ListMaybeName algn t _nm) -> Size
size (LengthList Size
n) = Size -> Size -> Size
forall n. Integral n => n -> n -> n
applyAlign Size
algn' (Size -> Size) -> Size -> Size
forall a b. (a -> b) -> a -> b
$ Size
n Size -> Size -> Size
forall a. Num a => a -> a -> a
* Size -> Size -> Size
forall n. Integral n => n -> n -> n
applyAlign Size
algn Size
sz
		where
		sz :: Size
sz = Int -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Size) -> Int -> Size
forall a b. (a -> b) -> a -> b
$ forall a. Storable a => a -> Int
S.sizeOf @t t
forall a. HasCallStack => a
undefined
		algn :: Size
algn = Int -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Size) -> Int -> Size
forall a b. (a -> b) -> a -> b
$ forall a. Storable a => a -> Int
S.alignment @t t
forall a. HasCallStack => a
undefined
		algn' :: Size
algn' = forall (obj :: O). SizeAlignment obj => Size
alignment @((ListMaybeName algn t _nm))
	alignment :: Size
alignment = Integer -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Proxy algn -> Integer
forall (n :: Alignment) (proxy :: Alignment -> *).
KnownNat n =>
proxy n -> Integer
natVal (Proxy algn
forall {k} (t :: k). Proxy t
Proxy :: Proxy algn)) Size -> Size -> Size
forall n. Integral n => n -> n -> n
`lcm`
		Int -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Storable a => a -> Int
S.alignment @t t
forall a. HasCallStack => a
undefined)

instance (KnownNat algn, S.Storable (ImagePixel img)) =>
	SizeAlignment ((ImageMaybeName algn img nm)) where
	size :: Length (ImageMaybeName algn img nm) -> Size
size (LengthImage Size
r Size
_w Size
h Size
d) = Size
r Size -> Size -> Size
forall a. Num a => a -> a -> a
* Size
h Size -> Size -> Size
forall a. Num a => a -> a -> a
* Size
d Size -> Size -> Size
forall a. Num a => a -> a -> a
* Size -> Size -> Size
forall n. Integral n => n -> n -> n
applyAlign Size
algn Size
sz
		where
		sz :: Size
sz = Int -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Size) -> Int -> Size
forall a b. (a -> b) -> a -> b
$ forall a. Storable a => a -> Int
S.sizeOf @(ImagePixel img) ImagePixel img
forall a. HasCallStack => a
undefined
		algn :: Size
algn = forall (obj :: O). SizeAlignment obj => Size
alignment @((ImageMaybeName algn img nm))
	alignment :: Size
alignment =Integer -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Proxy algn -> Integer
forall (n :: Alignment) (proxy :: Alignment -> *).
KnownNat n =>
proxy n -> Integer
natVal (Proxy algn
forall {k} (t :: k). Proxy t
Proxy :: Proxy algn)) Size -> Size -> Size
forall n. Integral n => n -> n -> n
`lcm`
		Int -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Storable a => a -> Int
S.alignment @(ImagePixel img) ImagePixel img
forall a. HasCallStack => a
undefined)

applyAlign :: Integral n => n -> n -> n
applyAlign :: forall n. Integral n => n -> n -> n
applyAlign n
algn n
ofst = ((n
ofst n -> n -> n
forall a. Num a => a -> a -> a
- n
1) n -> n -> n
forall n. Integral n => n -> n -> n
`div` n
algn n -> n -> n
forall a. Num a => a -> a -> a
+ n
1) n -> n -> n
forall a. Num a => a -> a -> a
* n
algn