{-----------------------------------------------------------------------------
tomato-rubato
------------------------------------------------------------------------------}
module Sound.Tomato.Speakers (
-- * Synopsis
-- | Very small module for playing audio data on your speakers.
--
-- Currently based on the Haskell OpenAL bindings.
-- * Setting up audio devices
Speakers, SampleRate, standardSampleRates, BlockSize,
withSpeakers, testSine,
-- * Audio data and playback
Sample, playSamples,
AudioBlock, playBlock,
) where
import Control.Applicative
import Control.Monad
import Control.Exception
import Control.Concurrent
import Control.Concurrent.STM
import Data.Int (Int16)
import System.Info
import qualified Data.Vector.Storable as V
-- Code heavily adapated from from YampaSynth
-- which was written by George Giorgidze and Henrik Nilsson
import Sound.OpenAL
{-----------------------------------------------------------------------------
Representation and playing of audio data
------------------------------------------------------------------------------}
-- | Single audio sample.
type Sample = Float
-- | Audio sample rate.
-- Needs to be one of the 'standardSampleRates' .
type SampleRate = Frequency
-- | List of standard sample rates, from high quality to low quality
--
-- > standardSampleRates = [44100,22050,11025]
standardSampleRates :: [SampleRate]
standardSampleRates = [44100,22050,11025]
-- | Size of an audio block.
--
-- The lower the block size, the lower the latency.
-- However, if the block size is too low, there will be jitter.
--
-- Recommended values: 64, 128, 256, 512
type BlockSize = Int
-- | Data type representing your loudspeakers.
data Speakers = Speakers
{ sampleRate :: SampleRate
, blockSize :: BlockSize
, source :: Source
, freeBuffers :: MyChan Buffer
, usedBuffers :: MyChan Buffer
}
-- | Initialize audio environment.
withSpeakers :: SampleRate -> BlockSize -> (Speakers -> IO a) -> IO a
withSpeakers rate size f = bracket init final try
where
init = do
(d,c,source, buffers) <- initOpenAL 20
s <- Speakers rate size source
<$> newMyChan buffers <*> newMyChan []
threadId <- forkIO $ recycleBuffers s -- start buffer recycling
return (s,d,c,source,buffers,threadId)
final (s,d,c,source,buffers,threadId) = do
killThread threadId -- stop buffer recycling
deInitOpenAL (d,c,source,buffers)
try (s,_,_,_,_,_) = do
x <- f s
waitForSource (source s) -- wait for sound to finish playing
return x
-- | Play a (possibly) infinite list of samples.
playSamples :: Speakers -> [Sample] -> IO ()
playSamples s = mapM_ (playBlock s) . map V.fromList . chunk (blockSize s)
-- | Memory block containing audio data.
-- Blockwise audio processing may be faster than lazy lists of samples.
type AudioBlock = V.Vector Sample
-- | Add a block of audio data to the speaker queue.
-- May block if the speaker has too much pending data.
playBlock :: Speakers -> AudioBlock -> IO ()
playBlock s block = do
evaluate block
(used, b) <- atomically $
(,) <$> takeMyChan (usedBuffers s)
<*> readMyChan (freeBuffers s) -- get free buffer
withBufferData s block (bufferData b $=) -- write data
queueBuffers (source s) [b] -- queue to source
playing <- (== Playing) <$> get (sourceState $ source s)
when (not playing) $ play [source s] -- set status to Playing
atomically $
putMyChan (usedBuffers s) (used ++ [b]) -- mark buffer as used
{-----------------------------------------------------------------------------
Test
------------------------------------------------------------------------------}
-- | Play a test sine wave.
-- Look at the source code to see how the library is used.
--
-- This should be a clear sound, similar to a telephone test tone.
-- If there is rattling or hissing, you have a problem.
--
-- > > testSine 440
testSine :: Frequency -> IO ()
testSine freq = withSpeakers sampleRate 128 $ \s -> playSamples s sound
where
sampleRate = 22050
dt = 1 / sampleRate -- time in seconds of a single sample
duration = 3 -- seconds
sound = take (ceiling $ duration / dt)
$ map (0.4*) $ sine freq
sine freq = [sin (2*pi*freq*dt*fromIntegral t) | t <- [0..]]
-- square freq = cycle $ replicate n 0 ++ replicate n 1
-- where n = ceiling $ sampleRate / (2*freq)
{-----------------------------------------------------------------------------
OpenAL glue code
------------------------------------------------------------------------------}
-- | Convert 'AudioBlock' to 'BufferData'
withBufferData :: Speakers -> AudioBlock -> (BufferData Int16 -> IO a) -> IO a
withBufferData speakers block f =
V.unsafeWith blockInt16 $ \ptr -> do
f $ BufferData (MemoryRegion ptr sizeInBytes)
Mono16 (sampleRate speakers)
where
sizeInBytes = 2 * fromIntegral (V.length block)
blockInt16 = V.map toSample block
-- | Convert a normalized floating point value in (-1,1) to a 'Sample'
toSample :: Float -> Int16
toSample = floor . (fromIntegral (maxBound - 1 :: Int16) *) . min 1 . max (-1)
-- | Process that recycles used buffers forever.
recycleBuffers :: Speakers -> IO ()
recycleBuffers s = forever $ do
hasGarbage <- (> 0) <$> get (buffersProcessed $ source s)
if not hasGarbage
then threadDelay 10
else do
-- recycle the last used buffer
buffer <- atomically $ readMyChan (usedBuffers s)
unqueueBuffers (source s) [buffer]
atomically $ writeMyChan (freeBuffers s) buffer
-- | Wait for an OpenAL source to complete playing.
waitForSource :: Source -> IO ()
waitForSource source = do
isPlaying <- (== Playing) <$> (get $ sourceState source)
when isPlaying $ do
threadDelay 10
waitForSource source
-- | Init OpenAL
initOpenAL :: Int -> IO (Device, Context, Source, [Buffer])
initOpenAL numBuffs = do
Just device <- openDevice Nothing
Just context <- createContext device []
currentContext $= Just context
[pSource] <- genObjectNames 1
pBuffers <- genObjectNames numBuffs
printErrors
return (device,context,pSource,pBuffers)
-- | Deinitialize OpenAL
deInitOpenAL :: (Device, Context, Source, [Buffer]) -> IO ()
deInitOpenAL (device,context,pSource,pBuffers) = do
buffer pSource $= Nothing
deleteObjectNames [pSource]
deleteObjectNames pBuffers
when (False) $ do
-- Not executing the code below fixes a crash on linux.
-- It's unproblematic on OS X, too, so why bother.
currentContext $= Nothing
destroyContext context
b <- closeDevice device
when (not b) $ fail "closing OpenAL device"
printErrors
-- | Print all OpenAL errors if applicable
printErrors :: IO ()
printErrors = do
e <- get alErrors
when (not $ null e) $ print e
{-----------------------------------------------------------------------------
Concurrency primitives
------------------------------------------------------------------------------}
type MyChan a = TMVar [a]
newMyChan :: [a] -> IO (MyChan a)
newMyChan = newTMVarIO
-- read single value from channel
readMyChan :: MyChan a -> STM a
readMyChan c = do
xs <- readTMVar c
case xs of
[] -> retry
(x:xs) -> do
takeTMVar c
putTMVar c xs
return x
-- write single value to channel
writeMyChan :: MyChan a -> a -> STM ()
writeMyChan c x = do
xs <- takeTMVar c
putTMVar c (xs ++ [x])
-- block channel
takeMyChan :: MyChan a -> STM [a]
takeMyChan = takeTMVar
-- unblock channel
putMyChan :: MyChan a -> [a] -> STM ()
putMyChan = putTMVar
{-----------------------------------------------------------------------------
Utilities
------------------------------------------------------------------------------}
-- | Divide a list into chunks of n elements.
chunk :: Int -> [a] -> [[a]]
chunk n [] = []
chunk n xs = y : chunk n xs'
where (y,xs') = splitAt n xs