Texture.hs

{-#  LANGUAGE MultiParamTypeClasses, FlexibleContexts #-}
module DirectX9.D3D.Texture
where
import Control.Exception    ( bracket )
import Foreign.Marshal.Alloc ( alloca )
import Foreign.Marshal.Utils ( maybeWith, with )
import Foreign.Ptr  ( nullPtr )
import Foreign.Storable ()

import DirectX9.Error
import DirectX9.Types
import DirectX9.D3D.Format
import DirectX9.D3D.Raw
import DirectX9.D3D.Device


---------------------------------------------------------------------------
-- Types

withBaseTexture :: (ComCast IDirect3DBaseTexture9 a) => ComObject a -> (Ptr IDirect3DBaseTexture9 -> IO b) -> IO b
withBaseTexture = withCastedCom

type Volume = ComObject IDirect3DVolume9
instance ComCast IDirect3DResource9 IDirect3DVolume9

type Texture = ComObject IDirect3DTexture9
type CubeTexture = ComObject IDirect3DCubeTexture9
type VolumeTexture = ComObject IDirect3DVolumeTexture9


instance ComCast IDirect3DBaseTexture9 IDirect3DTexture9
instance ComCast IDirect3DBaseTexture9 IDirect3DCubeTexture9
instance ComCast IDirect3DBaseTexture9 IDirect3DVolumeTexture9

---------------------------------------------------------------------------
-- BaseTexture

texGenerateMipSubLevels :: (ComCast IDirect3DBaseTexture9 a) => ComObject a -> IO ()
texGenerateMipSubLevels bt = withBaseTexture bt c_IDirect3DBaseTexture9_GenerateMipSubLevels

texGetAutoGenFilterType :: (ComCast IDirect3DBaseTexture9 a) => ComObject a -> IO D3DTEXTUREFILTERTYPE
texGetAutoGenFilterType bt = withBaseTexture bt c_IDirect3DBaseTexture9_GetAutoGenFilterType

texGetLevelCount :: (ComCast IDirect3DBaseTexture9 a) => ComObject a -> IO DWORD
texGetLevelCount bt = withBaseTexture bt c_IDirect3DBaseTexture9_GetLevelCount

texGetLOD :: (ComCast IDirect3DBaseTexture9 a) => ComObject a -> IO DWORD
texGetLOD bt = withBaseTexture bt c_IDirect3DBaseTexture9_GetLOD

texSetAutoGenFilterType :: (ComCast IDirect3DBaseTexture9 a) => ComObject a -> D3DTEXTUREFILTERTYPE -> IO ()
texSetAutoGenFilterType bt ft = withBaseTexture bt $ \bt -> do
    hrFail "IDirect3DBaseTexture9::SetAutoGenFilterType" $
        c_IDirect3DBaseTexture9_SetAutoGenFilterType bt ft
    return ()

texSetLOD :: (ComCast IDirect3DBaseTexture9 a) => ComObject a -> DWORD -> IO DWORD
texSetLOD bt lod = withBaseTexture bt $ \bt -> c_IDirect3DBaseTexture9_SetLOD bt lod

devSetTexture :: (ComCast IDirect3DBaseTexture9 a) => Device -> Int -> ComObject a -> IO ()
devSetTexture dev sampler tex = withCom dev
    $ \dev -> withCastedCom tex
    $ \tex -> do
        hrFail "IDirect3DDevice9::SetTexture" $
            c_IDirect3DDevice9_SetTexture dev (fromIntegral sampler) tex
        return ()

---------------------------------------------------------------------------
-- Texture

devCreateTexture :: Device -> Int -> Int -> Int -> DWORD -> D3DFORMAT -> D3DPOOL -> IO Texture
devCreateTexture dev width height levels usage format pool = withCom dev
    $ \dev -> alloca
    $ \ret -> do
        hrFail "IDirect3DDevice9::CreateTexture" $
            c_IDirect3DDevice9_CreateTexture dev
                (fromIntegral width) (fromIntegral height) (fromIntegral levels)
                usage format pool ret nullPtr
        peek ret >>= comMake

withLockedTexture :: Texture -> Int -> Maybe RECT -> DWORD -> (D3DLOCKED_RECT -> IO b) -> IO b
withLockedTexture tex level rect flags act = withCom tex $ \tex -> bracket
    (maybeWith with rect
        $ \rect -> alloca
        $ \ret -> do
            hrFail "IDirect3DTexture9::LockRect" $ c_IDirect3DTexture9_LockRect
                tex (fromIntegral level) ret rect flags
            peek ret)
    (const $ hrFail "IDirect3DTexture9_UnlockRect" $
        c_IDirect3DTexture9_UnlockRect tex (fromIntegral level))
    act


textureAddDirtyRect :: Texture -> Maybe RECT ->  IO ()
textureAddDirtyRect text rect = withCom text
    $ \tex -> maybeWith with rect
    $ \rect -> do
        hrFail "IDirect3DTexture9::AddDirtyRect" $
            c_IDirect3DTexture9_AddDirtyRect tex rect
        return ()

textureGetLevelDesc :: Texture -> Int -> IO D3DSURFACE_DESC
textureGetLevelDesc tex lvl = withCom tex
    $ \tex -> alloca
    $ \ret -> do
        hrFail "IDirect3DTexture9::GetLevelDesc" $
            c_IDirect3DTexture9_GetLevelDesc tex (fromIntegral lvl) ret
        peek ret

---------------------------------------------------------------------------
-- CubeTexture

devCreateCubeTexture :: Device -> Int -> Int -> DWORD -> D3DFORMAT -> D3DPOOL -> IO CubeTexture
devCreateCubeTexture dev edge lvl usage fmt pool = withCom dev
    $ \dev -> alloca
    $ \ret -> do
        hrFail "IDirect3DDevice9::CreateCubeTexture" $ 
            c_IDirect3DDevice9_CreateCubeTexture
                dev (fromIntegral edge) (fromIntegral lvl)
                usage fmt pool ret nullPtr
        peek ret >>= comMake

withLockedCubeTexture :: CubeTexture -> D3DCUBEMAP_FACES -> Int -> Maybe RECT -> DWORD -> (D3DLOCKED_RECT -> IO b) -> IO b
withLockedCubeTexture tex faces level rect flags act = withCom tex $ \tex -> bracket
    (maybeWith with rect
        $ \rect -> alloca
        $ \ret -> do
            hrFail "IDirect3DCubeTexture9::LockRect" $ c_IDirect3DCubeTexture9_LockRect
                tex faces (fromIntegral level) ret rect flags
            peek ret)
    (const $ hrFail "IDirect3DCubeTexture9_UnlockRect" $
        c_IDirect3DCubeTexture9_UnlockRect tex faces (fromIntegral level))
    act

cubeTexAddDirtyRect :: CubeTexture -> D3DCUBEMAP_FACES -> Maybe RECT ->  IO ()
cubeTexAddDirtyRect tex face rect = withCom tex
    $ \tex -> maybeWith with rect
    $ \rect -> do
        hrFail "IDirect3DCubeTexture9::AddDirtyRect" $
            c_IDirect3DCubeTexture9_AddDirtyRect tex face rect
        return ()

cubeTexGetLevelDesc :: CubeTexture -> Int ->  IO D3DSURFACE_DESC
cubeTexGetLevelDesc tex lvl = withCom tex
    $ \tex -> alloca
    $ \ret -> do
        hrFail "IDirect3DCubeTexture9::GetLevelDesc" $
            c_IDirect3DCubeTexture9_GetLevelDesc tex (fromIntegral lvl) ret
        peek ret

---------------------------------------------------------------------------
-- Volumte

volGetDesc :: Volume -> IO D3DVOLUME_DESC
volGetDesc vol = withCom vol $ \vol -> alloca $ \ret -> do
    hrFail "IDirect3DVolume9::GetDesc" $ c_IDirect3DVolume9_GetDesc vol ret
    peek ret

withLockedVolume :: Volume -> Maybe D3DBOX -> DWORD -> (D3DLOCKED_BOX -> IO b) -> IO b
withLockedVolume vol rect flags act = withCom vol $ \vol -> bracket
    (maybeWith with rect
        $ \rect -> alloca
        $ \ret -> do
            hrFail "IDirect3DVolume9::LockBox" $ c_IDirect3DVolume9_LockBox
                vol ret rect flags
            peek ret)
    (const $ hrFail "IDirect3DVolume9::UnlockBox" $
        c_IDirect3DVolume9_UnlockBox vol)
    act

---------------------------------------------------------------------------
-- VolumeTexture

devCreateVolumeTexture :: Device -> Int -> Int -> Int -> Int -> DWORD -> D3DFORMAT -> D3DPOOL -> IO VolumeTexture
devCreateVolumeTexture dev width height depth levels usage fmt pool = 
    withCom dev $ \dev -> alloca $ \ret -> do
        hrFail "IDirect3DDevice9::CreateVolumeTexture" $
            c_IDirect3DDevice9_CreateVolumeTexture dev (fromIntegral width)
                (fromIntegral height) (fromIntegral depth) (fromIntegral levels)
                usage fmt pool ret nullPtr
        peek ret >>= comMake

volTexAddDirtyBox :: VolumeTexture -> Maybe D3DBOX -> IO ()
volTexAddDirtyBox tex box = withCom tex
    $ \tex -> maybeWith with box
    $ \box -> do
        hrFail "IDirect3DVolumeTexture9::AddDirtyBox" $
            c_IDirect3DVolumeTexture9_AddDirtyBox tex box
        return ()

volTexGetVolumeLevel :: VolumeTexture -> Int -> IO Volume
volTexGetVolumeLevel vol lvl = withCom vol $ \vol -> alloca $ \ret -> do
    hrFail "IDirect3DVolumeTexture9::GetVolumeLevel" $
        c_IDirect3DVolumeTexture9_GetVolumeLevel vol (fromIntegral lvl) ret
    peek ret >>= comMake