summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorBalazsKomuves <>2013-11-04 20:12:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2013-11-04 20:12:00 (GMT)
commitbd85f5ca64e50abb701be863778313e04d9c801e (patch)
treebe273be1fa405d4fe6567b7b6155226ae6ff2005
version 0.0.0HEAD0.0.0master
-rw-r--r--DirectSound.cabal44
-rw-r--r--LICENSE29
-rw-r--r--Setup.lhs3
-rw-r--r--Sound/Win32/DirectSound.hs1032
-rw-r--r--example/DirectSound_playback_example.hs87
5 files changed, 1195 insertions, 0 deletions
diff --git a/DirectSound.cabal b/DirectSound.cabal
new file mode 100644
index 0000000..44b314f
--- /dev/null
+++ b/DirectSound.cabal
@@ -0,0 +1,44 @@
+Name: DirectSound
+Version: 0.0.0
+Synopsis: Partial binding to the Microsoft DirectSound API.
+Description: Partial binding to the Microsoft DirectSound API.
+ See the example program for a simple stereo playback.
+License: BSD3
+License-file: LICENSE
+Author: Balazs Komuves
+Copyright: (c) 2009 Balazs Komuves
+Maintainer: bkomuves (plus) hackage (at) gmail (dot) com
+Stability: Unstable
+Homepage: http://code.haskell.org/~bkomuves/
+Category: Sound
+Tested-With: GHC == 7.4.2
+Cabal-Version: >= 1.6
+Build-Type: Simple
+
+extra-source-files: example/DirectSound_playback_example.hs
+
+source-repository head
+ type: darcs
+ location: http://code.haskell.org/~bkomuves/projects/DirectSound/
+
+Flag splitBase
+ Description: Choose the new smaller, split-up base package.
+
+Library
+ if flag(splitBase)
+ Build-Depends: base >= 3 && < 5
+ else
+ Build-Depends: base < 3
+
+ Build-Depends: Win32
+
+ extra-libraries: dsound
+
+ Exposed-Modules: Sound.Win32.DirectSound
+
+ -- ghc-options: -threaded
+
+ Extensions: ForeignFunctionInterface, CPP,
+ EmptyDataDecls, TypeSynonymInstances
+ Hs-Source-Dirs: .
+
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..6e74feb
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,29 @@
+Copyright (c) 2009, Balazs Komuves
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+- Redistributions of source code must retain the above copyright notice,
+this list of conditions and the following disclaimer.
+
+- Redistributions in binary form must reproduce the above copyright notice,
+this list of conditions and the following disclaimer in the documentation
+and/or other materials provided with the distribution.
+
+- Neither names of the copyright holders nor the names of the contributors
+may be used to endorse or promote products derived from this software without
+specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
+OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
diff --git a/Setup.lhs b/Setup.lhs
new file mode 100644
index 0000000..2917094
--- /dev/null
+++ b/Setup.lhs
@@ -0,0 +1,3 @@
+#! /usr/bin/env runhaskell
+> import Distribution.Simple
+> main = defaultMain \ No newline at end of file
diff --git a/Sound/Win32/DirectSound.hs b/Sound/Win32/DirectSound.hs
new file mode 100644
index 0000000..1b530ff
--- /dev/null
+++ b/Sound/Win32/DirectSound.hs
@@ -0,0 +1,1032 @@
+
+{-
+(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"
+-}
diff --git a/example/DirectSound_playback_example.hs b/example/DirectSound_playback_example.hs
new file mode 100644
index 0000000..bca6854
--- /dev/null
+++ b/example/DirectSound_playback_example.hs
@@ -0,0 +1,87 @@
+
+module Main where
+
+import Control.Monad
+import Control.Concurrent
+
+import Data.Maybe
+
+import qualified Sound.Win32.DirectSound as DS
+
+import Foreign
+
+import System.IO
+import System.IO.Unsafe as Unsafe
+
+--------------------------------------------------------------------------------
+
+sampleRate = 44100 :: Int
+bufSize = 2048 :: Int -- in frames, not bytes
+
+--------------------------------------------------------------------------------
+
+frameCounter = Unsafe.unsafePerformIO (newMVar 0) :: MVar Word32
+
+fillAudioBuffer :: Ptr Int16 -> Word32 -> IO ()
+fillAudioBuffer buf nframes = do
+ c <- readMVar frameCounter
+ forM_ [0..nframes-1] $ \i -> do
+ let k = fromIntegral (i+i) :: Int
+ x = fromIntegral (c+i) / fromIntegral sampleRate :: Float
+ y = sin ( x * 440.0 * 6.2830 + 100.0 * sin ( x*10.0) )
+ a = round (y*20000) :: Int16
+ pokeElemOff buf (k ) a -- left channel
+ pokeElemOff buf (k+1) a -- right channel
+
+ swapMVar frameCounter (c+nframes)
+ return ()
+
+--------------------------------------------------------------------------------
+
+maybeRead :: Read a => String -> Maybe a
+maybeRead s = case reads s of
+ [(x,"")] -> Just x
+ _ -> Nothing
+
+select srclist getName = do
+ names <- mapM getName srclist
+ forM_ (zip [1..] names) $ \(i,name) -> putStrLn $ show i ++ ": " ++ name
+ let nsrc = length srclist
+ src <- case srclist of
+ [] -> error "no devices found"
+ [x] -> return x
+ _ -> do
+ putStrLn "please select a device"
+ l <- getLine
+ let k = case maybeRead l of
+ Nothing -> nsrc
+ Just m -> if m<1 || m>nsrc then nsrc else m
+
+ putStrLn $ "device #" ++ show k ++ " selected."
+ return $ srclist!!(k-1)
+ return src
+
+--------------------------------------------------------------------------------
+
+main = do
+
+ drvlist <- DS.enumerateDrivers
+ drv <- case drvlist of
+ [] -> error "no audio device found"
+ [drv] -> return drv
+ _ -> select drvlist (\d -> return (DS.drv_desc d))
+ hwnd <- DS.getConsoleHWND_hack
+ -- putStrLn $ "hwnd = " ++ show hwnd
+ ds <- DS.directSoundCreate (Just drv) hwnd >>= \mds -> case mds of
+ Left err -> error err
+ Right ds -> return ds
+ let waveFormatX = DS.makeWaveFormatX sampleRate 2 DS.SampleInt16
+ sb <- DS.createSoundBuffer ds waveFormatX (2*bufSize) >>= \msb -> case msb of
+ Left err -> error err
+ Right sb -> return sb
+
+ stopAudio <- DS.playWithDoubleBuffering sb fillAudioBuffer
+ -- threadDelay (20*1000*1000) -- 20 seconds
+ putStrLn "\nplaying...\npress enter to exit"
+ _ <- getLine
+ stopAudio