module Sound.Tomato.Speakers (
Speakers, SampleRate, standardSampleRates, BlockSize,
withSpeakers, testSine,
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
import Sound.OpenAL
type Sample = Float
type SampleRate = Frequency
standardSampleRates :: [SampleRate]
standardSampleRates = [44100,22050,11025]
type BlockSize = Int
data Speakers = Speakers
{ sampleRate :: SampleRate
, blockSize :: BlockSize
, source :: Source
, freeBuffers :: MyChan Buffer
, usedBuffers :: MyChan Buffer
}
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
return (s,d,c,source,buffers,threadId)
final (s,d,c,source,buffers,threadId) = do
killThread threadId
deInitOpenAL (d,c,source,buffers)
try (s,_,_,_,_,_) = do
x <- f s
waitForSource (source s)
return x
playSamples :: Speakers -> [Sample] -> IO ()
playSamples s = mapM_ (playBlock s) . map V.fromList . chunk (blockSize s)
type AudioBlock = V.Vector Sample
playBlock :: Speakers -> AudioBlock -> IO ()
playBlock s block = do
evaluate block
(used, b) <- atomically $
(,) <$> takeMyChan (usedBuffers s)
<*> readMyChan (freeBuffers s)
withBufferData s block (bufferData b $=)
queueBuffers (source s) [b]
playing <- (== Playing) <$> get (sourceState $ source s)
when (not playing) $ play [source s]
atomically $
putMyChan (usedBuffers s) (used ++ [b])
testSine :: Frequency -> IO ()
testSine freq = withSpeakers sampleRate 128 $ \s -> playSamples s sound
where
sampleRate = 22050
dt = 1 / sampleRate
duration = 3
sound = take (ceiling $ duration / dt)
$ map (0.4*) $ sine freq
sine freq = [sin (2*pi*freq*dt*fromIntegral t) | t <- [0..]]
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
toSample :: Float -> Int16
toSample = floor . (fromIntegral (maxBound 1 :: Int16) *) . min 1 . max (1)
recycleBuffers :: Speakers -> IO ()
recycleBuffers s = forever $ do
hasGarbage <- (> 0) <$> get (buffersProcessed $ source s)
if not hasGarbage
then threadDelay 10
else do
buffer <- atomically $ readMyChan (usedBuffers s)
unqueueBuffers (source s) [buffer]
atomically $ writeMyChan (freeBuffers s) buffer
waitForSource :: Source -> IO ()
waitForSource source = do
isPlaying <- (== Playing) <$> (get $ sourceState source)
when isPlaying $ do
threadDelay 10
waitForSource source
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)
deInitOpenAL :: (Device, Context, Source, [Buffer]) -> IO ()
deInitOpenAL (device,context,pSource,pBuffers) = do
buffer pSource $= Nothing
deleteObjectNames [pSource]
deleteObjectNames pBuffers
when (False) $ do
currentContext $= Nothing
destroyContext context
b <- closeDevice device
when (not b) $ fail "closing OpenAL device"
printErrors
printErrors :: IO ()
printErrors = do
e <- get alErrors
when (not $ null e) $ print e
type MyChan a = TMVar [a]
newMyChan :: [a] -> IO (MyChan a)
newMyChan = newTMVarIO
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
writeMyChan :: MyChan a -> a -> STM ()
writeMyChan c x = do
xs <- takeTMVar c
putTMVar c (xs ++ [x])
takeMyChan :: MyChan a -> STM [a]
takeMyChan = takeTMVar
putMyChan :: MyChan a -> [a] -> STM ()
putMyChan = putTMVar
chunk :: Int -> [a] -> [[a]]
chunk n [] = []
chunk n xs = y : chunk n xs'
where (y,xs') = splitAt n xs