DirectSound-0.0.0: Sound/Win32/DirectSound.hs
{-
(c) 2009 Balazs Komuves <bkomuves@gmail.com>
-}
-- | Partial binding to the DirectSound API.
{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls, GeneralizedNewtypeDeriving #-}
module Sound.Win32.DirectSound where
-------------------------------------------------------------------------------
import Control.Monad
import Control.Concurrent
import Control.Concurrent.MVar
import Data.Bits
import Data.Word
import Data.Maybe
import Graphics.Win32.Window (c_FindWindow)
import System.Win32.File (closeHandle)
import System.Win32.Types
import Foreign
import Foreign.C
-------------------------------------------------------------------------------
-- helper functions
-- adjustMVar :: MVar a -> (a -> a) -> IO ()
-- adjustMVar m f = takeMVar m >>= \x -> putMVar m (f x)
peekMaybe :: Storable a => Ptr a -> IO (Maybe a)
peekMaybe p =
if p == nullPtr
then return Nothing
else liftM Just $ peek p
withMaybe :: Storable a => Maybe a -> (Ptr a -> IO b) -> IO b
withMaybe Nothing action = action nullPtr
withMaybe (Just x) action = with x action
-------------------------------------------------------------------------------
type Method obj fun = Ptr obj -> fun
-- type HRESULT = UINT -- 2013: already defined by System.Win32.Types
type HWND = HANDLE
--data DSBuffer
data DSCaps
type IID = GUID
type RefIID = Ptr IID
data DSFXDesc
data DSBufferCaps = DSBufferCaps
{ dsbc_Size :: DWORD
, dsbc_Flags :: DWORD
, dsbc_BufferBytes :: DWORD
, dsbc_UnlockTransferRate :: DWORD
, dsbc_PlayCpuOverhead :: DWORD
}
instance Storable DSBufferCaps where
alignment _ = 4
sizeOf _ = 20
poke = undefined
peek p = do
sz <- peek (castPtr p )
fl <- peek (castPtr p `plusPtr` 4)
bb <- peek (castPtr p `plusPtr` 8)
tr <- peek (castPtr p `plusPtr` 12)
oh <- peek (castPtr p `plusPtr` 16)
return $ DSBufferCaps sz fl bb tr oh
-------------------------------------------------------------------------------
-- see mmreg.h
data WaveFormatTag
= WavePCM
| WaveADPCM
| WaveFloat
marshalWaveFormatTag :: WaveFormatTag -> Word16
marshalWaveFormatTag tag = case tag of
WavePCM -> 1
WaveADPCM -> 2
WaveFloat -> 3
data WaveFormatX = WaveFormatX
{ wFormatTag :: Word16
, nChannels :: Word16
, nSamplesPerSec :: Word32
, nAvgBytesPerSec :: Word32
, nBlockAlign :: Word16
, wBitsPerSample :: Word16
-- , cbSize :: Word16
}
instance Storable WaveFormatX where
alignment _ = 4
sizeOf _ = 18
peek = undefined
poke p wf = do
poke (castPtr p ) (wFormatTag wf)
poke (castPtr p `plusPtr` 2) (nChannels wf)
poke (castPtr p `plusPtr` 4) (nSamplesPerSec wf)
poke (castPtr p `plusPtr` 8) (nAvgBytesPerSec wf)
poke (castPtr p `plusPtr` 12) (nBlockAlign wf)
poke (castPtr p `plusPtr` 14) (wBitsPerSample wf)
poke (castPtr p `plusPtr` 16) (0::Word16) -- (cbSize wf)
data Channels = Mono | Stereo
data Format = SampleInt16 | SampleFloat
makeWaveFormatX
:: Int -- ^ sample rate
-> Int -- ^ number of channels
-> Format -- ^ sample format
-> WaveFormatX
makeWaveFormatX samplerate nchn fmt = wfx where
bps = case fmt of
SampleInt16 -> 16
SampleFloat -> 32
nba = (bps `div` 8) * nchn
wfx = WaveFormatX
{ wFormatTag = marshalWaveFormatTag WavePCM
, nChannels = fromIntegral nchn
, nSamplesPerSec = fromIntegral $ samplerate
, nAvgBytesPerSec = fromIntegral $ nba*samplerate
, nBlockAlign = fromIntegral $ nba
, wBitsPerSample = fromIntegral $bps
-- , cbSize = 0
}
{-
mono44khzInt16 :: WaveFormatX
mono44khzInt16 = WaveFormatX
{ wFormatTag = marshalWaveFormatTag WavePCM
, nChannels = 1
, nSamplesPerSec = 44100
, nAvgBytesPerSec = 2*44100
, nBlockAlign = 2
, wBitsPerSample = 16
-- , cbSize = 0
}
stereo44khzInt16 :: WaveFormatX
stereo44khzInt16 = mono44khzInt16
{ nChannels = 2
, nAvgBytesPerSec = 4*44100
, nBlockAlign = 4
}
stereo48khzInt16 :: WaveFormatX
stereo48khzInt16 = mono44khzInt16
{ nChannels = 2
, nSamplesPerSec = 48000
, nAvgBytesPerSec = 4*48000
, nBlockAlign = 4
}
mono44khzFloat :: WaveFormatX
mono44khzFloat = mono44khzInt16
{ nAvgBytesPerSec = 4*44100
, nBlockAlign = 4
, wBitsPerSample = 32
}
stereo44khzFloat :: WaveFormatX
stereo44khzFloat = mono44khzFloat
{ nChannels = 2
, nAvgBytesPerSec = 8*44100
, nBlockAlign = 8
}
-}
-------------------------------------------------------------------------------
dsbcaps_PrimaryBuffer = 0x00000001 :: DWORD
dsbcaps_Static = 0x00000002 :: DWORD
dsbcaps_StickyFocus = 0x00004000 :: DWORD
dsbcaps_GlobalFocus = 0x00008000 :: DWORD
dsbcaps_GetCurrentPos2 = 0x00010000 :: DWORD
dsbcaps_CtrlPositionNotify = 0x00000100 :: DWORD
data DSBufferDesc = DSBufferDesc
{ bdesc_flags :: DWORD
, bdesc_bufferBytes :: DWORD
, bdesc_waveFormatX :: Ptr WaveFormatX
, bdesc_3Dalg :: GUID
}
{-
withPrimaryDSBufferDesc :: WaveFormatX -> (Ptr DSBufferDesc -> IO a) -> IO a
withPrimaryDSBufferDesc wfx action =
with wfx $ \pwfx -> do
let flags = dsbcaps_GlobalFocus .|. dsbcaps_GetCurrentPos2 .|. dsbcaps_PrimaryBuffer .|. dsbcaps_CtrlPositionNotify
bdesc = DSBufferDesc flags 0 pwfx guidNull
with bdesc $ \p -> action p
-}
-- buffer size is given in frames, not bytes
withSecondaryDSBufferDesc :: WaveFormatX -> Int -> (Ptr DSBufferDesc -> IO a) -> IO a
withSecondaryDSBufferDesc wfx bufsize action =
with wfx $ \pwfx -> do
let flags = dsbcaps_GlobalFocus .|. dsbcaps_GetCurrentPos2 .|. dsbcaps_CtrlPositionNotify
bdesc = DSBufferDesc flags (fromIntegral bufsize * fromIntegral (nBlockAlign wfx)) pwfx guidNull
with bdesc $ \p -> action p
instance Storable DSBufferDesc where
alignment _ = 4
sizeOf _ = 16 + sizeOf (undefined :: Ptr ()) + sizeOf (undefined :: GUID)
peek = undefined
poke p bd = do
poke (castPtr p ) (fromIntegral (sizeOf (undefined :: DSBufferDesc)) :: DWORD)
poke (castPtr p `plusPtr` 4) (bdesc_flags bd)
poke (castPtr p `plusPtr` 8) (bdesc_bufferBytes bd)
poke (castPtr p `plusPtr` 12) (0::DWORD)
poke (castPtr p `plusPtr` 16) (bdesc_waveFormatX bd)
let k = sizeOf (bdesc_waveFormatX bd)
poke (castPtr p `plusPtr` (16+k)) (bdesc_3Dalg bd)
-------------------------------------------------------------------------------
type RefGUID = Ptr GUID
-- A GUID is a 128-bit integer (16 bytes) that can be used across all
-- computers and networks wherever a unique identifier is required.
data GUID = GUID
{ guid_chunk1 :: !Word64
, guid_chunk2 :: !Word64
}
deriving (Eq,Show)
guidNull :: GUID
guidNull = GUID 0 0
instance Storable GUID where
alignment _ = 4
sizeOf _ = 16
peek p = do
x <- peek (castPtr p )
y <- peek (castPtr p `plusPtr` 8)
return (GUID x y)
poke p (GUID x y) = do
poke (castPtr p) x
poke (castPtr p `plusPtr` 8) y
-------------------------------------------------------------------------------
data CooperativeLevel
= CoopNormal
| CoopPriority
| CoopExclusive
| CoopWritePrimary
marshalCooperativeLevel :: CooperativeLevel -> DWORD
marshalCooperativeLevel level = case level of
CoopNormal -> 0x00000001
CoopPriority -> 0x00000002
CoopExclusive -> 0x00000003
CoopWritePrimary -> 0x00000004
-------------------------------------------------------------------------------
{-
DECLARE_INTERFACE_(IDirectSound8, IDirectSound)
{
// IUnknown methods
STDMETHOD(QueryInterface) (THIS_ REFIID, LPVOID *) PURE;
STDMETHOD_(ULONG,AddRef) (THIS) PURE;
STDMETHOD_(ULONG,Release) (THIS) PURE;
// IDirectSound methods
STDMETHOD(CreateSoundBuffer) (THIS_ LPCDSBUFFERDESC pcDSBufferDesc, LPDIRECTSOUNDBUFFER *ppDSBuffer, LPUNKNOWN pUnkOuter) PURE;
STDMETHOD(GetCaps) (THIS_ LPDSCAPS pDSCaps) PURE;
STDMETHOD(DuplicateSoundBuffer) (THIS_ LPDIRECTSOUNDBUFFER pDSBufferOriginal, LPDIRECTSOUNDBUFFER *ppDSBufferDuplicate) PURE;
STDMETHOD(SetCooperativeLevel) (THIS_ HWND hwnd, DWORD dwLevel) PURE;
STDMETHOD(Compact) (THIS) PURE;
STDMETHOD(GetSpeakerConfig) (THIS_ LPDWORD pdwSpeakerConfig) PURE;
STDMETHOD(SetSpeakerConfig) (THIS_ DWORD dwSpeakerConfig) PURE;
STDMETHOD(Initialize) (THIS_ LPCGUID pcGuidDevice) PURE;
// IDirectSound8 methods
STDMETHOD(VerifyCertification) (THIS_ LPDWORD pdwCertified) PURE;
};
-}
type DS8Method fun = Method IDirectSound8 fun
-- IUnknown methods
type QueryInterface = RefIID -> Ptr (Ptr ()) -> IO HRESULT
type AddRef = IO ()
type Release = IO ()
-- IDirectSound methods
type CreateSoundBuffer = Ptr DSBufferDesc -> Ptr (Ptr ISoundBuffer8) -> Ptr () -> IO HRESULT
type DSGetCaps = Ptr DSCaps -> IO HRESULT
type DuplicateSoundBuffer = Ptr ISoundBuffer8 -> Ptr (Ptr ISoundBuffer8) -> IO HRESULT
type SetCooperativeLevel = HWND -> DWORD -> IO HRESULT
type Compact = IO HRESULT
type GetSpeakerConfig = Ptr DWORD -> IO HRESULT
type SetSpeakerConfig = DWORD -> IO HRESULT
type DSInitialize = Ptr GUID -> IO HRESULT
-- IDirectSound8 methods
type VerifyCertification = DWORD -> IO ()
data IDirectSound8Vtbl = IDirectSound8Vtbl
{ -- IUnknown methods
ids8_QueryInterface :: FunPtr ( Ptr IDirectSound8 -> QueryInterface )
, ids8_AddRef :: FunPtr ( Ptr IDirectSound8 -> AddRef )
, ids8_Release :: FunPtr ( Ptr IDirectSound8 -> Release )
-- IDirectSound methods
, ids8_CreateSoundBuffer :: FunPtr ( Ptr IDirectSound8 -> CreateSoundBuffer )
, ids8_GetCaps :: FunPtr ( Ptr IDirectSound8 -> DSGetCaps )
, ids8_DuplicateSoundBuffer :: FunPtr ( Ptr IDirectSound8 -> DuplicateSoundBuffer )
, ids8_SetCooperativeLevel :: FunPtr ( Ptr IDirectSound8 -> SetCooperativeLevel )
, ids8_Compact :: FunPtr ( Ptr IDirectSound8 -> Compact )
, ids8_GetSpeakerConfig :: FunPtr ( Ptr IDirectSound8 -> GetSpeakerConfig )
, ids8_SetSpeakerConfig :: FunPtr ( Ptr IDirectSound8 -> SetSpeakerConfig )
, ids8_Initialize :: FunPtr ( Ptr IDirectSound8 -> DSInitialize )
-- IDirectSound8 methods
, ids8_VerifyCertification :: FunPtr ( Ptr IDirectSound8 -> VerifyCertification )
}
newtype IDirectSound8 = IDirectSound8 { unIDirectSound8 :: Ptr IDirectSound8Vtbl } deriving Storable
-- | The Haskell version of the @DirectSound8@ object
data DirectSound = DirectSound8
{ ds_directSound8object :: Ptr IDirectSound8
, ds_windowHandle :: HWND
-- IUnknown methods
, ds_queryInterface :: QueryInterface
, ds_addRef :: AddRef
, ds_release :: Release
-- IDirectSound methods
, ds_createSoundBuffer :: CreateSoundBuffer
, ds_getCaps :: DSGetCaps
, ds_duplicateSoundBuffer :: DuplicateSoundBuffer
, ds_setCooperativeLevel :: SetCooperativeLevel
, ds_compact :: Compact
, ds_getSpeakerConfig :: GetSpeakerConfig
, ds_setSpeakerConfig :: SetSpeakerConfig
, ds_initialize :: DSInitialize
-- IDirectSound8 methods
, ds_verifyCertification :: VerifyCertification
}
instance Storable IDirectSound8Vtbl where
alignment = undefined
sizeOf = undefined
poke = undefined
peek p = do
let k = sizeOf (undefined :: FunPtr (IO ()))
q <- return p;
qif <- peek (castPtr q) ; q <- return (q `plusPtr` k)
arf <- peek (castPtr q) ; q <- return (q `plusPtr` k)
rel <- peek (castPtr q) ; q <- return (q `plusPtr` k)
csb <- peek (castPtr q) ; q <- return (q `plusPtr` k)
gcp <- peek (castPtr q) ; q <- return (q `plusPtr` k)
dsb <- peek (castPtr q) ; q <- return (q `plusPtr` k)
scl <- peek (castPtr q) ; q <- return (q `plusPtr` k)
cpt <- peek (castPtr q) ; q <- return (q `plusPtr` k)
gsc <- peek (castPtr q) ; q <- return (q `plusPtr` k)
ssc <- peek (castPtr q) ; q <- return (q `plusPtr` k)
ini <- peek (castPtr q) ; q <- return (q `plusPtr` k)
vcf <- peek (castPtr q) ; q <- return (q `plusPtr` k)
return $
IDirectSound8Vtbl
qif arf rel csb gcp dsb scl cpt gsc ssc ini vcf
mkDirectSound8 :: Ptr IDirectSound8 -> HWND -> IO DirectSound
mkDirectSound8 ids8 hwnd = do
pvtbl <- liftM unIDirectSound8 $ peek ids8
vtbl <- peek pvtbl
let qif = mkDSQueryInterfaceMethod (ids8_QueryInterface vtbl)
arf = mkDSAddRefMethod (ids8_AddRef vtbl)
rel = mkDSReleaseMethod (ids8_Release vtbl)
--
csb = mkCreateSoundBufferMethod (ids8_CreateSoundBuffer vtbl)
gcp = mkDSGetCapsMethod (ids8_GetCaps vtbl)
dsb = mkDuplicateSoundBufferMethod (ids8_DuplicateSoundBuffer vtbl)
scl = mkSetCooperativeLevelMethod (ids8_SetCooperativeLevel vtbl)
cpt = mkCompactMethod (ids8_Compact vtbl)
gsc = mkGetSpeakerConfigMethod (ids8_GetSpeakerConfig vtbl)
ssc = mkSetSpeakerConfigMethod (ids8_SetSpeakerConfig vtbl)
ini = mkDSInitializeMethod (ids8_Initialize vtbl)
--
vcf = mkVerifyCertificationMethod (ids8_VerifyCertification vtbl)
return $
DirectSound8 ids8 hwnd
(qif ids8) (arf ids8) (rel ids8) (csb ids8)
(gcp ids8) (dsb ids8) (scl ids8) (cpt ids8)
(gsc ids8) (ssc ids8) (ini ids8) (vcf ids8)
foreign import stdcall "dynamic" mkDSQueryInterfaceMethod :: FunPtr (DS8Method QueryInterface) -> DS8Method QueryInterface
foreign import stdcall "dynamic" mkDSAddRefMethod :: FunPtr (DS8Method AddRef) -> DS8Method AddRef
foreign import stdcall "dynamic" mkDSReleaseMethod :: FunPtr (DS8Method Release) -> DS8Method Release
foreign import stdcall "dynamic" mkCreateSoundBufferMethod :: FunPtr (DS8Method CreateSoundBuffer) -> DS8Method CreateSoundBuffer
foreign import stdcall "dynamic" mkDSGetCapsMethod :: FunPtr (DS8Method DSGetCaps) -> DS8Method DSGetCaps
foreign import stdcall "dynamic" mkDuplicateSoundBufferMethod :: FunPtr (DS8Method DuplicateSoundBuffer) -> DS8Method DuplicateSoundBuffer
foreign import stdcall "dynamic" mkSetCooperativeLevelMethod :: FunPtr (DS8Method SetCooperativeLevel) -> DS8Method SetCooperativeLevel
foreign import stdcall "dynamic" mkCompactMethod :: FunPtr (DS8Method Compact) -> DS8Method Compact
foreign import stdcall "dynamic" mkGetSpeakerConfigMethod :: FunPtr (DS8Method GetSpeakerConfig) -> DS8Method GetSpeakerConfig
foreign import stdcall "dynamic" mkSetSpeakerConfigMethod :: FunPtr (DS8Method SetSpeakerConfig) -> DS8Method SetSpeakerConfig
foreign import stdcall "dynamic" mkDSInitializeMethod :: FunPtr (DS8Method DSInitialize) -> DS8Method DSInitialize
foreign import stdcall "dynamic" mkVerifyCertificationMethod :: FunPtr (DS8Method VerifyCertification) -> DS8Method VerifyCertification
-------------------------------------------------------------------------------
foreign import stdcall safe "DSound.h DirectSoundCreate8" c_DirectSoundCreate8
:: Ptr GUID -> Ptr (Ptr IDirectSound8) -> Ptr () -> IO HRESULT
setCooperativeLevel :: DirectSound -> CooperativeLevel -> IO ()
setCooperativeLevel ds level = do
ds_setCooperativeLevel ds (ds_windowHandle ds) (marshalCooperativeLevel level)
return ()
directSoundCreate :: Maybe Driver -> HWND -> IO (Either String DirectSound)
directSoundCreate mdriver hwnd = do
let mguid = join $ liftM drv_guid mdriver
withMaybe mguid $ \guid ->
alloca $ \p -> do
hr <- c_DirectSoundCreate8 guid p nullPtr
if hr == 0
then do
q <- peek p
ds <- mkDirectSound8 q hwnd
setCooperativeLevel ds CoopPriority -- according to the MSDN, we should call this immediately
return (Right ds)
else return $ Left "error creating the DirectSound object"
-------------------------------------------------------------------------------
-- the default device has no GUID
data Driver = Driver
{ drv_guid :: Maybe GUID
, drv_desc :: String
, drv_module :: String
}
deriving Show
type DSEnumCallbackW a = Ptr GUID -> CWString -> CWString -> Ptr a -> IO Bool
type DSEnumCallbackA a = Ptr GUID -> CString -> CString -> Ptr a -> IO Bool
foreign import stdcall unsafe "wrapper"
mkDSEnumCallbackW :: DSEnumCallbackW () -> IO (FunPtr (DSEnumCallbackW ()))
foreign import stdcall safe "DSound.h DirectSoundEnumerateW" c_DirectSoundEnumerateW
:: FunPtr (DSEnumCallbackW a) -> Ptr a -> IO HRESULT
enumCallbackW :: DSEnumCallbackW ()
enumCallbackW pguid pdesc pdriver paccum =
do
accum <- deRefStablePtr (castPtrToStablePtr paccum) :: IO (MVar [Driver])
guid <- peekMaybe pguid
desc <- peekCWString pdesc
driver <- peekCWString pdriver
adjustMVar accum (Driver guid desc driver :)
return True
where
adjustMVar :: MVar a -> (a -> a) -> IO ()
adjustMVar m f = takeMVar m >>= \x -> putMVar m (f x)
enumerateDrivers :: IO [Driver]
enumerateDrivers = do
accum <- newMVar [] :: IO (MVar [Driver])
spaccum <- newStablePtr accum
cb <- mkDSEnumCallbackW enumCallbackW
c_DirectSoundEnumerateW cb (castStablePtrToPtr spaccum)
freeStablePtr spaccum
liftM reverse $ takeMVar accum
-------------------------------------------------------------------------------
type SB8Method fun = Method ISoundBuffer8 fun
-- IDirectSoundBuffer methods
type SBGetCaps = Ptr DSBufferCaps -> IO HRESULT
type GetCurrentPosition = Ptr DWORD -> Ptr DWORD -> IO HRESULT
type GetFormat = Ptr WaveFormatX -> DWORD -> Ptr DWORD -> IO HRESULT
type GetVolume = Ptr LONG -> IO HRESULT
type GetPan = Ptr LONG -> IO HRESULT
type GetFrequency = Ptr DWORD -> IO HRESULT
type GetStatus = Ptr DWORD -> IO HRESULT
type SBInitialize = Ptr IDirectSound8 -> Ptr DSBufferDesc -> IO HRESULT
type SBLock = DWORD -> DWORD -> Ptr (Ptr ()) -> Ptr DWORD -> Ptr (Ptr ()) -> Ptr DWORD -> DWORD -> IO HRESULT
type SBPlay = DWORD -> DWORD -> DWORD -> IO HRESULT
type SetCurrentPosition = DWORD -> IO HRESULT
type SetFormat = Ptr WaveFormatX -> IO HRESULT
type SetVolume = LONG -> IO HRESULT
type SetPan = LONG -> IO HRESULT
type SetFrequency = DWORD -> IO HRESULT
type SBStop = IO HRESULT
type SBUnlock = Ptr () -> DWORD -> Ptr () -> DWORD -> IO HRESULT
type SBRestore = IO HRESULT
-- IDirectSoundBuffer8 methods
type SetFX = DWORD -> Ptr DSFXDesc -> Ptr DWORD -> IO HRESULT
type AcquireResources = DWORD -> DWORD -> Ptr DWORD -> IO HRESULT
type GetObjectInPath = RefGUID -> DWORD -> RefGUID -> Ptr (Ptr ()) -> IO HRESULT
{-
DECLARE_INTERFACE_(IDirectSoundBuffer8, IDirectSoundBuffer)
{
// IUnknown methods
STDMETHOD(QueryInterface) (THIS_ REFIID, LPVOID *) PURE;
STDMETHOD_(ULONG,AddRef) (THIS) PURE;
STDMETHOD_(ULONG,Release) (THIS) PURE;
// IDirectSoundBuffer methods
STDMETHOD(GetCaps) (THIS_ LPDSBCAPS pDSBufferCaps) PURE;
STDMETHOD(GetCurrentPosition) (THIS_ LPDWORD pdwCurrentPlayCursor, LPDWORD pdwCurrentWriteCursor) PURE;
STDMETHOD(GetFormat) (THIS_ LPWAVEFORMATEX pwfxFormat, DWORD dwSizeAllocated, LPDWORD pdwSizeWritten) PURE;
STDMETHOD(GetVolume) (THIS_ LPLONG plVolume) PURE;
STDMETHOD(GetPan) (THIS_ LPLONG plPan) PURE;
STDMETHOD(GetFrequency) (THIS_ LPDWORD pdwFrequency) PURE;
STDMETHOD(GetStatus) (THIS_ LPDWORD pdwStatus) PURE;
STDMETHOD(Initialize) (THIS_ LPDIRECTSOUND pDirectSound, LPCDSBUFFERDESC pcDSBufferDesc) PURE;
STDMETHOD(Lock) (THIS_ DWORD dwOffset, DWORD dwBytes, LPVOID *ppvAudioPtr1, LPDWORD pdwAudioBytes1,
LPVOID *ppvAudioPtr2, LPDWORD pdwAudioBytes2, DWORD dwFlags) PURE;
STDMETHOD(Play) (THIS_ DWORD dwReserved1, DWORD dwPriority, DWORD dwFlags) PURE;
STDMETHOD(SetCurrentPosition) (THIS_ DWORD dwNewPosition) PURE;
STDMETHOD(SetFormat) (THIS_ LPCWAVEFORMATEX pcfxFormat) PURE;
STDMETHOD(SetVolume) (THIS_ LONG lVolume) PURE;
STDMETHOD(SetPan) (THIS_ LONG lPan) PURE;
STDMETHOD(SetFrequency) (THIS_ DWORD dwFrequency) PURE;
STDMETHOD(Stop) (THIS) PURE;
STDMETHOD(Unlock) (THIS_ LPVOID pvAudioPtr1, DWORD dwAudioBytes1, LPVOID pvAudioPtr2, DWORD dwAudioBytes2) PURE;
STDMETHOD(Restore) (THIS) PURE;
// IDirectSoundBuffer8 methods
STDMETHOD(SetFX) (THIS_ DWORD dwEffectsCount, LPDSEFFECTDESC pDSFXDesc, LPDWORD pdwResultCodes) PURE;
STDMETHOD(AcquireResources) (THIS_ DWORD dwFlags, DWORD dwEffectsCount, LPDWORD pdwResultCodes) PURE;
STDMETHOD(GetObjectInPath) (THIS_ REFGUID rguidObject, DWORD dwIndex, REFGUID rguidInterface, LPVOID *ppObject) PURE;
};
-}
newtype ISoundBuffer8 = ISoundBuffer8 { unISoundBuffer8 :: Ptr ISoundBuffer8Vtbl } deriving Storable
data ISoundBuffer8Vtbl = ISoundBuffer8Vtbl
{ -- IUnknown methods
isb8_QueryInterface :: FunPtr ( Ptr ISoundBuffer8 -> QueryInterface )
, isb8_AddRef :: FunPtr ( Ptr ISoundBuffer8 -> AddRef )
, isb8_Release :: FunPtr ( Ptr ISoundBuffer8 -> Release )
-- IDirectSoundBuffer methods
, isb8_GetCaps :: FunPtr ( Ptr ISoundBuffer8 -> SBGetCaps )
, isb8_GetCurrentPosition :: FunPtr ( Ptr ISoundBuffer8 -> GetCurrentPosition )
, isb8_GetFormat :: FunPtr ( Ptr ISoundBuffer8 -> GetFormat )
, isb8_GetVolume :: FunPtr ( Ptr ISoundBuffer8 -> GetVolume )
, isb8_GetPan :: FunPtr ( Ptr ISoundBuffer8 -> GetPan )
, isb8_GetFrequency :: FunPtr ( Ptr ISoundBuffer8 -> GetFrequency )
, isb8_GetStatus :: FunPtr ( Ptr ISoundBuffer8 -> GetStatus )
, isb8_Initialize :: FunPtr ( Ptr ISoundBuffer8 -> SBInitialize )
, isb8_Lock :: FunPtr ( Ptr ISoundBuffer8 -> SBLock )
, isb8_Play :: FunPtr ( Ptr ISoundBuffer8 -> SBPlay )
, isb8_SetCurrentPosition :: FunPtr ( Ptr ISoundBuffer8 -> SetCurrentPosition )
, isb8_SetFormat :: FunPtr ( Ptr ISoundBuffer8 -> SetFormat )
, isb8_SetVolume :: FunPtr ( Ptr ISoundBuffer8 -> SetVolume )
, isb8_SetPan :: FunPtr ( Ptr ISoundBuffer8 -> SetPan )
, isb8_SetFrequency :: FunPtr ( Ptr ISoundBuffer8 -> SetFrequency )
, isb8_Stop :: FunPtr ( Ptr ISoundBuffer8 -> SBStop )
, isb8_Unlock :: FunPtr ( Ptr ISoundBuffer8 -> SBUnlock )
, isb8_Restore :: FunPtr ( Ptr ISoundBuffer8 -> SBRestore )
-- IDirectSoundBuffer8 methods
, isb8_SetFX :: FunPtr ( Ptr ISoundBuffer8 -> SetFX )
, isb8_AcquireResources :: FunPtr ( Ptr ISoundBuffer8 -> AcquireResources )
, isb8_GetObjectInPath :: FunPtr ( Ptr ISoundBuffer8 -> GetObjectInPath )
}
-- "Address of a variable that receives the IDirectSoundBuffer interface of
-- the new buffer object. Use QueryInterface to obtain IDirectSoundBuffer8."
isb8_peekQueryInterface :: Ptr ISoundBuffer8 -> IO QueryInterface
isb8_peekQueryInterface pisb = do
isb <- peek pisb
pqif <- peek (castPtr $ unISoundBuffer8 isb) :: IO ( FunPtr ( Ptr ISoundBuffer8 -> QueryInterface ) )
let qif = mkSBQueryInterface pqif :: Ptr ISoundBuffer8 -> QueryInterface
return (qif pisb)
instance Storable ISoundBuffer8Vtbl where
alignment = undefined
sizeOf = undefined
poke = undefined
peek p = do
let k = sizeOf (undefined :: FunPtr (IO ()))
q <- return p;
qif <- peek (castPtr q) ; q <- return (q `plusPtr` k)
arf <- peek (castPtr q) ; q <- return (q `plusPtr` k)
rel <- peek (castPtr q) ; q <- return (q `plusPtr` k)
--
cap <- peek (castPtr q) ; q <- return (q `plusPtr` k)
gcp <- peek (castPtr q) ; q <- return (q `plusPtr` k)
gft <- peek (castPtr q) ; q <- return (q `plusPtr` k)
gvl <- peek (castPtr q) ; q <- return (q `plusPtr` k)
gpn <- peek (castPtr q) ; q <- return (q `plusPtr` k)
gfr <- peek (castPtr q) ; q <- return (q `plusPtr` k)
gst <- peek (castPtr q) ; q <- return (q `plusPtr` k)
ini <- peek (castPtr q) ; q <- return (q `plusPtr` k)
lck <- peek (castPtr q) ; q <- return (q `plusPtr` k)
ply <- peek (castPtr q) ; q <- return (q `plusPtr` k)
scp <- peek (castPtr q) ; q <- return (q `plusPtr` k)
sft <- peek (castPtr q) ; q <- return (q `plusPtr` k)
svl <- peek (castPtr q) ; q <- return (q `plusPtr` k)
spn <- peek (castPtr q) ; q <- return (q `plusPtr` k)
sfr <- peek (castPtr q) ; q <- return (q `plusPtr` k)
stp <- peek (castPtr q) ; q <- return (q `plusPtr` k)
ulk <- peek (castPtr q) ; q <- return (q `plusPtr` k)
rst <- peek (castPtr q) ; q <- return (q `plusPtr` k)
--
sfx <- peek (castPtr q) ; q <- return (q `plusPtr` k)
aqr <- peek (castPtr q) ; q <- return (q `plusPtr` k)
gop <- peek (castPtr q) ; q <- return (q `plusPtr` k)
return $
ISoundBuffer8Vtbl
qif arf rel
cap
gcp gft gvl gpn gfr gst
ini lck ply
scp sft svl spn sfr
stp ulk rst
sfx aqr gop
foreign import stdcall "dynamic" mkSBQueryInterface :: FunPtr (SB8Method QueryInterface) -> SB8Method QueryInterface
foreign import stdcall "dynamic" mkSBAddRef :: FunPtr (SB8Method AddRef) -> SB8Method AddRef
foreign import stdcall "dynamic" mkSBRelease :: FunPtr (SB8Method Release) -> SB8Method Release
foreign import stdcall "dynamic" mkSBGetCaps :: FunPtr (SB8Method SBGetCaps) -> SB8Method SBGetCaps
foreign import stdcall "dynamic" mkGetCurrentPosition :: FunPtr (SB8Method GetCurrentPosition) -> SB8Method GetCurrentPosition
foreign import stdcall "dynamic" mkGetFormat :: FunPtr (SB8Method GetFormat) -> SB8Method GetFormat
foreign import stdcall "dynamic" mkGetVolume :: FunPtr (SB8Method GetVolume) -> SB8Method GetVolume
foreign import stdcall "dynamic" mkGetPan :: FunPtr (SB8Method GetPan) -> SB8Method GetPan
foreign import stdcall "dynamic" mkGetFrequency :: FunPtr (SB8Method GetFrequency) -> SB8Method GetFrequency
foreign import stdcall "dynamic" mkGetStatus :: FunPtr (SB8Method GetStatus) -> SB8Method GetStatus
foreign import stdcall "dynamic" mkSBInitialize :: FunPtr (SB8Method SBInitialize) -> SB8Method SBInitialize
foreign import stdcall "dynamic" mkSBLock :: FunPtr (SB8Method SBLock) -> SB8Method SBLock
foreign import stdcall "dynamic" mkSBPlay :: FunPtr (SB8Method SBPlay) -> SB8Method SBPlay
foreign import stdcall "dynamic" mkSetCurrentPosition :: FunPtr (SB8Method SetCurrentPosition) -> SB8Method SetCurrentPosition
foreign import stdcall "dynamic" mkSetFormat :: FunPtr (SB8Method SetFormat) -> SB8Method SetFormat
foreign import stdcall "dynamic" mkSetVolume :: FunPtr (SB8Method SetVolume) -> SB8Method SetVolume
foreign import stdcall "dynamic" mkSetPan :: FunPtr (SB8Method SetPan) -> SB8Method SetPan
foreign import stdcall "dynamic" mkSetFrequency :: FunPtr (SB8Method SetFrequency) -> SB8Method SetFrequency
foreign import stdcall "dynamic" mkSBStop :: FunPtr (SB8Method SBStop) -> SB8Method SBStop
foreign import stdcall "dynamic" mkSBUnlock :: FunPtr (SB8Method SBUnlock) -> SB8Method SBUnlock
foreign import stdcall "dynamic" mkSBRestore :: FunPtr (SB8Method SBRestore) -> SB8Method SBRestore
foreign import stdcall "dynamic" mkSetFX :: FunPtr (SB8Method SetFX) -> SB8Method SetFX
foreign import stdcall "dynamic" mkAcquireResources :: FunPtr (SB8Method AcquireResources) -> SB8Method AcquireResources
foreign import stdcall "dynamic" mkGetObjectInPath :: FunPtr (SB8Method GetObjectInPath) -> SB8Method GetObjectInPath
-- | the Haskell version of the @IDirectSoundBuffer8@ object
data SoundBuffer = SoundBuffer8
{ sb_soundBufer8object :: Ptr ISoundBuffer8
, sb_waveFormatX :: WaveFormatX
, sb_bufSizeInFrames :: Word32
-- IUnknown methods
, sb_queryInterface :: QueryInterface
, sb_addRef :: AddRef
, sb_release :: Release
-- IDirectSoundBuffer methods
, sb_getCaps :: SBGetCaps
, sb_getCurrentPosition :: GetCurrentPosition
, sb_getFormat :: GetFormat
, sb_getVolume :: GetVolume
, sb_getPan :: GetPan
, sb_getFrequency :: GetFrequency
, sb_getStatus :: GetStatus
, sb_initialize :: SBInitialize
, sb_lock :: SBLock
, sb_play :: SBPlay
, sb_setCurrentPosition :: SetCurrentPosition
, sb_setFormat :: SetFormat
, sb_setVolume :: SetVolume
, sb_setPan :: SetPan
, sb_setFrequency :: SetFrequency
, sb_stop :: SBStop
, sb_unlock :: SBUnlock
, sb_restore :: SBRestore
-- IDirectSoundBuffer8 methods
, sb_setFX :: SetFX
, sb_acquireResources :: AcquireResources
, sb_getObjectInPath :: GetObjectInPath
}
mkSoundBuffer8 :: Ptr ISoundBuffer8 -> WaveFormatX -> Word32 -> IO SoundBuffer
mkSoundBuffer8 isb8 wfx bufsize = do
pvtbl <- liftM unISoundBuffer8 $ peek isb8
vtbl <- peek pvtbl
let qif = mkSBQueryInterface (isb8_QueryInterface vtbl)
arf = mkSBAddRef (isb8_AddRef vtbl)
rel = mkSBRelease (isb8_Release vtbl)
--
cap = mkSBGetCaps (isb8_GetCaps vtbl)
gcp = mkGetCurrentPosition (isb8_GetCurrentPosition vtbl)
gft = mkGetFormat (isb8_GetFormat vtbl)
gvl = mkGetVolume (isb8_GetVolume vtbl)
gpn = mkGetPan (isb8_GetPan vtbl)
gfr = mkGetFrequency (isb8_GetFrequency vtbl)
gst = mkGetStatus (isb8_GetStatus vtbl)
ini = mkSBInitialize (isb8_Initialize vtbl)
lck = mkSBLock (isb8_Lock vtbl)
ply = mkSBPlay (isb8_Play vtbl)
scp = mkSetCurrentPosition (isb8_SetCurrentPosition vtbl)
sft = mkSetFormat (isb8_SetFormat vtbl)
svl = mkSetVolume (isb8_SetVolume vtbl)
spn = mkSetPan (isb8_SetPan vtbl)
sfr = mkSetFrequency (isb8_SetFrequency vtbl)
stp = mkSBStop (isb8_Stop vtbl)
ulk = mkSBUnlock (isb8_Unlock vtbl)
rst = mkSBRestore (isb8_Restore vtbl)
--
sfx = mkSetFX (isb8_SetFX vtbl)
aqr = mkAcquireResources (isb8_AcquireResources vtbl)
gop = mkGetObjectInPath (isb8_GetObjectInPath vtbl)
return $
SoundBuffer8 isb8 wfx bufsize
(qif isb8) (arf isb8) (rel isb8)
(cap isb8)
(gcp isb8) (gft isb8) (gvl isb8) (gpn isb8) (gfr isb8) (gst isb8)
(ini isb8) (lck isb8) (ply isb8)
(scp isb8) (sft isb8) (svl isb8) (spn isb8) (sfr isb8)
(stp isb8) (ulk isb8) (rst isb8)
(sfx isb8) (aqr isb8) (gop isb8)
-------------------------------------------------------------------------------
type SetNotificationPositions = DWORD -> Ptr DSBPositionNotify -> IO HRESULT
newtype IDSNotify8 = IDSNotify8 { unIDSNotify8 :: Ptr IDSNotify8Vtbl } deriving Storable
data IDSNotify8Vtbl = IDSNotify8Vtbl
{ -- IUnknown methods
idsn8_QueryInterface :: FunPtr ( Ptr IDSNotify8 -> QueryInterface )
, idsn8_AddRef :: FunPtr ( Ptr IDSNotify8 -> AddRef )
, idsn8_Release :: FunPtr ( Ptr IDSNotify8 -> Release )
-- IDirectSoundNotify methods
, idsn8_SetNotificationPositions :: FunPtr ( Ptr IDSNotify8 -> SetNotificationPositions )
}
idsn8_peekSetNotificationPositions :: Ptr IDSNotify8 -> IO SetNotificationPositions
idsn8_peekSetNotificationPositions pidsn = do
idsn <- peek pidsn
let k = sizeOf (undefined :: FunPtr (IO ()))
psnp <- peek (castPtr (unIDSNotify8 idsn) `plusPtr` (3*k)) :: IO ( FunPtr ( Ptr IDSNotify8 -> SetNotificationPositions) )
let snp = mkSetNotificationPositions psnp
return (snp pidsn)
foreign import stdcall "dynamic" mkSetNotificationPositions
:: FunPtr (Ptr IDSNotify8 -> SetNotificationPositions) -> (Ptr IDSNotify8 -> SetNotificationPositions)
-------------------------------------------------------------------------------
-- we assume here that we are on a low-endian architecture!!!
makeGUID :: Word32 -> Word16 -> Word16 -> [Word8] -> GUID
makeGUID data1 data2 data3 data4 = GUID chunk1 chunk2 where
chunk1 = shiftL (fromIntegral data3 :: Word64) 48
+ shiftL (fromIntegral data2 :: Word64) 32
+ (fromIntegral data1 :: Word64)
chunk2 = sum $ map f $ zip [0..7] data4
f (i,b) = shiftL (fromIntegral b :: Word64) (i*8)
iid_IDirectSoundBuffer8 :: GUID
iid_IDirectSoundBuffer8 =
makeGUID 0x6825a449 0x7524 0x4d82 [ 0x92, 0x0f, 0x50, 0xe3, 0x6a, 0xb3, 0xab, 0x1e ]
-- DEFINE_GUID(IID_IDirectSoundBuffer8, 0x6825a449, 0x7524, 0x4d82, 0x92, 0x0f, 0x50, 0xe3, 0x6a, 0xb3, 0xab, 0x1e);
-- chunk1 = 0x4d8275246825a449
-- chunk2 = 0x1eabb36ae3500f92
iid_IDirectSoundNotify :: GUID
iid_IDirectSoundNotify =
makeGUID 0xb0210783 0x89cd 0x11d0 [ 0xaf, 0x08, 0x00, 0xa0, 0xc9, 0x25, 0xcd, 0x16 ]
-- DEFINE_GUID(IID_IDirectSoundNotify, 0xb0210783, 0x89cd, 0x11d0, 0xaf, 0x8, 0x0, 0xa0, 0xc9, 0x25, 0xcd, 0x16);
-------------------------------------------------------------------------------
-- Buffer size is given in frames, not bytes!
-- The latency will be half of the buffer size when doublebuffering.
createSoundBuffer :: DirectSound -> WaveFormatX -> Int -> IO (Either String SoundBuffer)
createSoundBuffer ds wfx bufsize = do
withSecondaryDSBufferDesc wfx bufsize $ \pdesc -> do
alloca $ \q -> do
hr <- ds_createSoundBuffer ds pdesc q nullPtr
if hr==0 -- xx || hr==DS_NO_VIRTUALIZATION
then do
-- To obtain the interface, use the CreateSoundBuffer method to retrieve
-- IDirectSoundBuffer, and then pass IID_IDirectSoundBuffer8 to IDirectSoundBuffer::QueryInterface.
isb <- peek q
qif <- isb8_peekQueryInterface isb
isb8 <- with iid_IDirectSoundBuffer8 $ \iid ->
alloca $ \q -> do
qif iid q
liftM castPtr $ peek q
sb <- mkSoundBuffer8 isb8 wfx (fromIntegral bufsize)
return (Right sb)
else
return $ Left "error creating the sound buffer"
sbQueryInterface :: SoundBuffer -> GUID -> IO (Ptr a)
sbQueryInterface sb guid =
with guid $ \iid -> alloca $ \p -> do
sb_queryInterface sb iid p
liftM castPtr $ peek p
getCurrentPlayWritePosition :: SoundBuffer -> IO (Word32,Word32)
getCurrentPlayWritePosition sb = do
alloca $ \playcursor -> alloca $ \writecursor -> do
sb_getCurrentPosition sb playcursor writecursor
play <- peek playcursor
write <- peek writecursor
return (play,write)
getCurrentPlayPosition :: SoundBuffer -> IO Word32
getCurrentPlayPosition sb = liftM fst $ getCurrentPlayWritePosition sb
getCurrentWritePosition :: SoundBuffer -> IO Word32
getCurrentWritePosition sb = liftM snd $ getCurrentPlayWritePosition sb
setCurrentPosition :: SoundBuffer -> Word32 -> IO ()
setCurrentPosition sb pos = do
sb_setCurrentPosition sb pos
return ()
dsblock_FromWriteCursor = 0x00000001 :: DWORD
dsblock_EntireBuffer = 0x00000002 :: DWORD
data Portion a = Portion !(Ptr a) !Word32 deriving Show
{-
-- locks at write position
withLockedBuffer1 :: SoundBuffer -> Int -> (Portion a -> Maybe (Portion a) -> IO b) -> IO b
withLockedBuffer1 sb nframes action = do
let nbytes = nframes * (nBlockAlign $ sb_waveFormatX sb)
flags = dsblock_FromWriteCursor
alloca $ \pptr1 -> alloca $ \psiz1 -> alloca $ \pptr2 -> alloca $ \psiz2 -> do
sb_lock sb 0 nbytes pptr1 psiz1 pptr2 psiz2 flags
ptr1 <- peek pptr1
siz1 <- peek psiz2
let portion1 = Portion (castPtr ptr1) siz1
ptr2 <- peek pptr2
siz2 <- peek psiz2
let portion2 = if ptr2 == nullPtr
then Nothing
else Just (Portion (castPtr ptr2) siz2)
action portion1 portion2
sb_unlock sb ptr1 siz1 ptr2 siz2
-}
-- ofs / size in bytes!
withLockedBuffer :: SoundBuffer -> Word32 -> Word32 -> (Portion a -> Maybe (Portion a) -> IO b) -> IO b
withLockedBuffer sb ofs siz action = do
alloca $ \pptr1 -> alloca $ \psiz1 -> alloca $ \pptr2 -> alloca $ \psiz2 -> do
sb_lock sb ofs siz pptr1 psiz1 pptr2 psiz2 0
ptr1 <- peek pptr1
siz1 <- peek psiz1
let portion1 = Portion (castPtr ptr1) siz1
ptr2 <- peek pptr2
siz2 <- peek psiz2
let portion2 = if ptr2 == nullPtr
then Nothing
else Just (Portion (castPtr ptr2) siz2)
--print (ofs,siz,portion1,portion2)
res <- action portion1 portion2
sb_unlock sb ptr1 siz1 ptr2 siz2
return res
-------------------------------------------------------------------------------
data DSBPositionNotify = DSBPositionNotify
{ pn_offset :: Word32
, pn_event :: HANDLE
}
instance Storable DSBPositionNotify where
alignment _ = 4
sizeOf _ = 4 + sizeOf (undefined :: HANDLE)
peek = undefined
poke p (DSBPositionNotify ofs event) = do
poke (castPtr p) ofs
poke (castPtr p `plusPtr` 4) event
foreign import stdcall "windows.h CreateEventA" c_CreateEventA
:: Ptr () -> BOOL -> BOOL -> CString -> IO HANDLE
-- ofs/siz in bytes!!
data DoubleBuffering = DoubleBuffering
{ db_ofs1 :: Word32
, db_siz1 :: Word32
, db_ev1 :: HANDLE
, db_ofs2 :: Word32
, db_siz2 :: Word32
, db_ev2 :: HANDLE
}
deriving Show
closeDoubleBuffering :: DoubleBuffering -> IO ()
closeDoubleBuffering db = do
closeHandle (db_ev1 db)
closeHandle (db_ev2 db)
-- | Sets up the sound buffer for double buffered continous playback
setupDoubleBuffering :: SoundBuffer -> IO DoubleBuffering
setupDoubleBuffering sb = do
idsn <- sbQueryInterface sb iid_IDirectSoundNotify
setNotificationPos <- idsn8_peekSetNotificationPositions idsn :: IO SetNotificationPositions
let frame = fromIntegral (nBlockAlign $ sb_waveFormatX sb)
bsize = (sb_bufSizeInFrames sb ) * frame
half = (sb_bufSizeInFrames sb `div` 2) * frame
evFirstHalf <- c_CreateEventA nullPtr False False nullPtr
evSecondHalf <- c_CreateEventA nullPtr False False nullPtr
withArray
[ DSBPositionNotify 0 evFirstHalf
, DSBPositionNotify half evSecondHalf
] $ \p -> setNotificationPos 2 p
return $ DoubleBuffering
0 half evFirstHalf
half (bsize-half) evSecondHalf
foreign import stdcall unsafe {- this is needed so that we can terminate the playing thread???? -} "windows.h WaitForMultipleObjects" c_WaitForMultipleObjects
:: DWORD -> Ptr HANDLE -> BOOL -> DWORD -> IO DWORD
-- | the second argument is number of frames, not bytes!
type FillBufferCallback a = Ptr a -> Word32 -> IO ()
dsbplay_Looping = 0x00000001 :: DWORD
-- | Forks a new lightweight thread. Returns the action for stopping the playback.
playWithDoubleBuffering :: SoundBuffer -> FillBufferCallback a -> IO (IO ())
playWithDoubleBuffering sb fillBuffer = do
db <- setupDoubleBuffering sb
let k = fromIntegral $ nBlockAlign (sb_waveFormatX sb) :: Word32
let infinite = 0xFFFFFFFF :: Word32
{-
print k
print db
putStrLn $ "sampling rate = " ++ show (nSamplesPerSec $ sb_waveFormatX sb)
-}
threadID <- forkIO $ do
hr <- sb_play sb 0 0 dsbplay_Looping
if (hr==0)
then do
withArray [ db_ev1 db , db_ev2 db ] $ \evs -> forever $ do
which <- c_WaitForMultipleObjects 2 evs False infinite
-- print which
case which of
0 -> withLockedBuffer sb (db_ofs2 db) (db_siz2 db) $ \(Portion ptr nbytes) _ ->
fillBuffer ptr (nbytes `div` k)
1 -> withLockedBuffer sb (db_ofs1 db) (db_siz1 db) $ \(Portion ptr nbytes) _ ->
fillBuffer ptr (nbytes `div` k)
_ -> return () -- should not happen
threadDelay 100 -- wait 100 microsec (so that the thread does not lock?)
else do
--closeDoubleBuffering db
return ()
let
stop = do
sb_stop sb
killThread threadID
closeDoubleBuffering db
return stop
-------------------------------------------------------------------------------
foreign import stdcall "windows.h GetConsoleTitleW" c_GetConsoleTitleW
:: CWString -> DWORD -> IO DWORD
foreign import stdcall "windows.h SetConsoleTitleW" c_SetConsoleTitleW
:: CWString -> IO BOOL
-- | see <http://support.microsoft.com/kb/124103>
getConsoleHWND_hack :: IO HWND
getConsoleHWND_hack = do
allocaBytes (1024*2) $ \pbackup -> do
c_GetConsoleTitleW pbackup 1023
let unique = "microsoft-can-be-stupid-sometimes"
withCWString unique $ \punique -> do
c_SetConsoleTitleW punique
threadDelay (42*1000)
hwnd <- c_FindWindow nullPtr punique
c_SetConsoleTitleW pbackup
return hwnd
-------------------------------------------------------------------------------
{-
myCount = unsafePerformIO $ newMVar 0 :: MVar Double
myFillBuffer :: Ptr Int16 -> Word32 -> IO ()
myFillBuffer p n = do
x <- takeMVar myCount
--print n
forM_ [0..n-1] $ \i -> pokeElemOff p (fromIntegral i) ( round $ 16000.0 * sin (x + 0.075 * fromIntegral i) )
putMVar myCount (x + 0.075 * fromIntegral n)
main = do
drvs <- enumerateDrivers
mapM_ print drvs
hwnd <- getConsoleHWND_hack
print hwnd
ds <- directSoundCreate (Just $ head drvs) hwnd >>= \mds -> case mds of
Left err -> error err
Right ds -> return ds
sb <- createSoundBuffer ds mono44khzInt16 4096 >>= \msb -> case msb of
Left err -> error err
Right sb -> return sb
stop <- playWithDoubleBuffering sb myFillBuffer
getCurrentPlayPosition sb >>= print
threadDelay (1*1000*1000)
getCurrentPlayPosition sb >>= print
threadDelay (1*1000*1000)
getCurrentPlayPosition sb >>= print
alloca $ \p -> do
sb_getFrequency sb p
peek p >>= print
stop
threadDelay (2*1000*1000)
putStrLn "end"
-}