dx9d3d-0.1: DirectX9/D3D/Device.hs
module DirectX9.D3D.Device
where
import Control.Monad ( when )
import Foreign.Marshal.Alloc ( alloca, allocaBytes )
import Foreign.Marshal.Array ( withArray, peekArray0, withArray0 )
import Foreign.Marshal.Utils ( with )
import Foreign.Ptr ( nullPtr, castPtr )
import Foreign.Storable ()
import DirectX9.Types
import DirectX9.Error
import DirectX9.D3D.Format
import DirectX9.D3D.Raw
import DirectX9.D3D.Base
type Device = ComObject IDirect3DDevice9
d3dCreateDevice :: Direct3D -> UINT -> D3DDEVTYPE -> HWND -> DWORD -> D3DPRESENT_PARAMETERS -> IO (Device, D3DPRESENT_PARAMETERS)
d3dCreateDevice d3d a at window usage present' = do
(dev, param) <- withCom d3d
$ \d3d -> alloca
$ \dev -> with present'
$ \present -> do
hrFail "IDirect3D9::CreateDevice"
$ c_IDirect3D9_CreateDevice d3d a at window usage present dev
d <- peek dev
p <- peek present
return (d,p)
when (dev==nullPtr) $ fail "IDirect3D::CreateDevice failed (object at 0)"
dev <- comMake dev
return (dev,param)
devReset :: Device -> D3DPRESENT_PARAMETERS -> IO ()
devReset dev par = withCom dev $ \dev -> with par $ \par -> do
hrFail "IDirect3DDevice9::Reset" $ c_IDirect3DDevice9_Reset dev par
return ()
devBeginScene :: Device -> IO ()
devBeginScene dev = withCom dev $ \dev -> do
hrFail "IDirect3DDevice9::BeginScene" $ c_IDirect3DDevice9_BeginScene dev
return ()
devEndScene :: Device -> IO ()
devEndScene dev = withCom dev $ \dev -> do
hrFail "IDirect3DDevice9::EndScene" $ c_IDirect3DDevice9_EndScene dev
return ()
-- version that doesn't take RECTs or RGNDATA
devPresentMinimal :: Device -> HWND -> IO ()
devPresentMinimal dev hwnd = withCom dev $ \dev -> do
hrFail "IDirect3DDevice9::Present" $ c_IDirect3DDevice9_Present
dev nullPtr nullPtr hwnd nullPtr
return ()
devClear :: Device -> [D3DRECT] -> DWORD -> D3DCOLOR -> Float -> DWORD -> IO ()
devClear dev dirty flags color z stencil =
withCom dev $
\dev -> withArray dirty $
\dirty' -> do
let
count = fromIntegral $ length dirty
prects = if count==0 then nullPtr else dirty'
hrFail "IDirect3DDevice9::Clear" $ c_IDirect3DDevice9_Clear
dev count prects flags color z stencil
return ()
devSetTransform :: Device -> D3DTRANSFORMSTATETYPE -> D3DMATRIX -> IO ()
devSetTransform dev t m = withCom dev $ \dev -> alloca $ \mat -> do
poke mat m
hrFail "IDirect3DDevice9::SetTransform" $ c_IDirect3DDevice9_SetTransform dev t mat
return ()
devMultiplyTransform :: Device -> D3DTRANSFORMSTATETYPE -> D3DMATRIX -> IO ()
devMultiplyTransform dev t m = withCom dev
$ \dev -> with m
$ \mat -> do
hrFail "IDirect3DDevice9::MultiplyTransform" $
c_IDirect3DDevice9_MultiplyTransform dev t mat
return ()
devSetRenderState :: Device -> D3DRENDERSTATETYPE -> DWORD -> IO ()
devSetRenderState dev state value = withCom dev $ \dev -> do
hrFail "IDirect3DDevice9::SetRenderState" $
c_IDirect3DDevice9_SetRenderState dev state value
return ()
devSetFVF :: Device -> DWORD -> IO ()
devSetFVF dev fvf = withCom dev $ \dev -> do
hrFail "IDirect3DDevice9::SetFVF" $ c_IDirect3DDevice9_SetFVF dev fvf
return ()
devDrawIndexedPrimitive :: Device -> D3DPRIMITIVETYPE -> Word -> Word -> Word -> Word -> Word -> IO ()
devDrawIndexedPrimitive dev t base min num start count = withCom dev $ \dev -> do
hrFail "IDirect3DDevice9::DrawIndexedPrimitive" $
c_IDirect3DDevice9_DrawIndexedPrimitive
dev t (fromIntegral base) (fromIntegral min) (fromIntegral num)
(fromIntegral start) (fromIntegral count)
return ()
devDrawPrimitiveUP :: Device -> D3DPRIMITIVETYPE -> Word -> Ptr a -> Int -> IO ()
devDrawPrimitiveUP dev t count buf stride = withCom dev $ \dev -> do
hrFail "IDirect3DDevice9::DrawPrimitiveUP" $ c_IDirect3DDevice9_DrawPrimitiveUP
dev t (fromIntegral count) (castPtr buf) (fromIntegral stride)
return ()
devDrawIndexedPrimitiveUP ::
Device -> D3DPRIMITIVETYPE -> Word -> Word -> Word -> Ptr a
-> D3DFORMAT -> Ptr b -> Word -> IO ()
devDrawIndexedPrimitiveUP dev t minv numv count vtx it idx stride =
withCom dev $ \dev -> do
hrFail "IDirect3DDevice9::DrawIndexedPrimitiveUP"
$ c_IDirect3DDevice9_DrawIndexedPrimitiveUP dev
t (fromIntegral minv) (fromIntegral numv) (fromIntegral count)
(castPtr vtx) it (castPtr idx) (fromIntegral stride)
return ()
devDrawPrimitive :: Device -> D3DPRIMITIVETYPE -> Word -> Word -> IO ()
devDrawPrimitive dev t start count = withCom dev $ \dev -> do
hrFail "IDirect3DDevice9::DrawPrimitive" $ c_IDirect3DDevice9_DrawPrimitive
dev t (fromIntegral start) (fromIntegral count)
return ()
devDrawRectPatch :: Device -> Word -> [Float] -> D3DRECTPATCH_INFO -> IO ()
devDrawRectPatch dev handle segs patch =
withCom dev $ \dev ->
withArray segs $ \segs ->
with patch $ \patch -> do
hrFail "IDirect3DDevice9::DrawRectPatch" $
c_IDirect3DDevice9_DrawRectPatch dev (fromIntegral handle) segs patch
return ()
devDrawTriPatch :: Device -> Word -> [Float] -> D3DTRIPATCH_INFO -> IO ()
devDrawTriPatch dev handle segs patch =
withCom dev $ \dev ->
withArray segs $ \segs ->
with patch $ \patch -> do
hrFail "IDirect3DDevice9::DrawTriPatch" $
c_IDirect3DDevice9_DrawTriPatch dev (fromIntegral handle) segs patch
return ()
devDeletePatch :: Device -> UINT -> IO ()
devDeletePatch dev handle = withCom dev $ \dev -> do
hrFail "IDirect3DDevice9::DeletePatch" $ c_IDirect3DDevice9_DeletePatch dev handle
return ()
devGetDeviceCaps :: Device -> IO D3DCAPS9
devGetDeviceCaps dev = withCom dev
$ \dev -> alloca
$ \buf -> do
hrFail "IDirect3DDevice9::GetDeviceCaps" $
c_IDirect3DDevice9_GetDeviceCaps dev buf
peek buf
devSetLight :: Device -> Int -> D3DLIGHT9 -> IO ()
devSetLight dev idx light = withCom dev
$ \dev -> with light
$ \light -> do
hrFail "IDirect3DDevice9::SetLight" $ c_IDirect3DDevice9_SetLight
dev (fromIntegral idx) light
return ()
devLightEnable :: Device -> Int -> Bool -> IO ()
devLightEnable dev li e = withCom dev $ \dev -> do
hrFail "IDirect3DDevice9::LightEnable" $
c_IDirect3DDevice9_LightEnable dev (fromIntegral li) e
return ()
devSetMaterial :: Device -> D3DMATERIAL9 -> IO ()
devSetMaterial dev mat = withCom dev
$ \dev -> with mat
$ \mat -> do
hrFail "IDirect3DDevice9::SetMaterial" $
c_IDirect3DDevice9_SetMaterial dev mat
return ()
devSetNPatchMode :: Device -> Float -> IO ()
devSetNPatchMode dev segs = withCom dev $ \dev -> do
hrFail "IDirect3DDevice9::SetNPatchMode"
$ c_IDirect3DDevice9_SetNPatchMode dev segs
return ()
devSetTextureStageState :: Device -> Int -> D3DTEXTURESTAGESTATETYPE -> DWORD -> IO ()
devSetTextureStageState dev stage t v = withCom dev $ \dev -> do
hrFail "IDirect3DDevice9::SetTextureStageState" $
c_IDirect3DDevice9_SetTextureStageState dev (fromIntegral stage) t v
return ()
devSetClipPlane :: Device -> Int -> (Float,Float,Float,Float) -> IO ()
devSetClipPlane dev idx (v1,v2,v3,v4) = withCom dev
$ \dev -> withArray [v1,v2,v3,v4]
$ \buf -> do
hrFail "IDirect3DDevice9::SetClipPlane" $
c_IDirect3DDevice9_SetClipPlane dev (fromIntegral idx) buf
return ()
devSetClipStatus :: Device -> D3DCLIPSTATUS9 -> IO ()
devSetClipStatus dev cs = withCom dev
$ \dev -> with cs
$ \cs -> do
hrFail "IDirect3DDevice9::SetClipStatus" $
c_IDirect3DDevice9_SetClipStatus dev cs
return ()
devValidate :: Device -> IO (Either DWORD HRESULT)
devValidate dev = withCom dev
$ \dev -> alloca
$ \passes -> do
ret <- hrSuccess success "IDirect3DDevice9::ValidateDevice" $
c_IDirect3DDevice9_ValidateDevice dev passes
if ret==d3D_OK
then peek passes >>= return.Left
else return $ Right ret
where
success =
[ d3DERR_CONFLICTINGRENDERSTATE, d3DERR_CONFLICTINGTEXTUREFILTER
, d3DERR_DEVICELOST, d3DERR_DRIVERINTERNALERROR, d3DERR_TOOMANYOPERATIONS
, d3DERR_UNSUPPORTEDALPHAARG, d3DERR_UNSUPPORTEDALPHAOPERATION
, d3DERR_UNSUPPORTEDCOLORARG, d3DERR_UNSUPPORTEDCOLOROPERATION
, d3DERR_UNSUPPORTEDFACTORVALUE, d3DERR_UNSUPPORTEDTEXTUREFILTER
, d3DERR_WRONGTEXTUREFORMAT, d3D_OK ]
devSetViewport :: Device -> Int -> Int -> Int -> Int -> Float -> Float -> IO ()
devSetViewport dev x y width height minz maxz = withCom dev
$ \dev -> with viewport
$ \vp -> do
hrFail "IDirect3DDevice9::SetViewport" $
c_IDirect3DDevice9_SetViewport dev vp
return ()
where
viewport = (D3DVIEWPORT9
(fromIntegral x) (fromIntegral y)
(fromIntegral width) (fromIntegral height)
minz maxz)
devTestCooperativeLevel :: Device -> IO HRESULT
devTestCooperativeLevel dev = withCom dev $ \dev ->
hrSuccess [d3D_OK, d3DERR_DEVICELOST, d3DERR_DEVICENOTRESET]
"IDirect3DDevice9::TestCooperativeLevel" $
c_IDirect3DDevice9_TestCooperativeLevel dev
---------------------------------------------------------------------------
-- VertexDeclaration
type VertexDeclaration = ComObject IDirect3DVertexDeclaration9
d3DDECL_END :: D3DVERTEXELEMENT9
d3DDECL_END = D3DVERTEXELEMENT9 0xFF 0 d3DDECLTYPE_UNUSED 0 0 0
devCreateVertexDeclaration :: Device -> [D3DVERTEXELEMENT9] -> IO VertexDeclaration
devCreateVertexDeclaration dev decl = withCom dev
$ \dev -> withArray0 d3DDECL_END decl
$ \decl -> alloca
$ \ret -> do
hrFail "IDirect3DDevice9::CreateVertexDeclaration" $
c_IDirect3DDevice9_CreateVertexDeclaration dev decl ret
peek ret >>= comMake
devSetVertexDeclaration :: Device -> VertexDeclaration -> IO ()
devSetVertexDeclaration dev vd = withCom dev
$ \dev -> withCom vd
$ \vd -> do
hrFail "IDirect3DDevice9::SetVertexDeclaration" $
c_IDirect3DDevice9_SetVertexDeclaration dev vd
return ()
vertexDeclGetDeclaration :: VertexDeclaration -> IO [D3DVERTEXELEMENT9]
vertexDeclGetDeclaration vd = withCom vd
$ \vd -> alloca
$ \count -> allocaBytes (1024*(sizeOf (undefined::D3DVERTEXELEMENT9)))
$ \buf -> do
poke count 1024
hrFail "IDirect3DVertexDeclaration9::GetDeclaration" $
c_IDirect3DVertexDeclaration9_GetDeclaration vd buf count
peekArray0 d3DDECL_END buf