DirectSound-0.0.0: example/DirectSound_playback_example.hs

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