diff --git a/DirectSound.cabal b/DirectSound.cabal new file mode 100644 --- /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 --- /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 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#! /usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/Sound/Win32/DirectSound.hs b/Sound/Win32/DirectSound.hs new file mode 100644 --- /dev/null +++ b/Sound/Win32/DirectSound.hs @@ -0,0 +1,1032 @@ + +{- +(c) 2009 Balazs Komuves +-} + +-- | 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 +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 --- /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