OpenAL.hs

module Player.OpenAL (
   Player.OpenAL.play
 , initOpenAL
 , deInitOpenAL
 , process
 , Chunk (..)
 ) where

import Data.Audio

import FRP.Yampa

import Sound.OpenAL 

import Data.Int
import Data.IORef
import Foreign.Storable
import Foreign.Marshal.Alloc
import Foreign.Ptr
import Control.Concurrent  

play ::Int -> Int -> SF () (Sample, Event ()) -> IO ()
play sampleRate' sampleNumber' sf = do
  mVarEnd <- newEmptyMVar
  _ <- forkIO $ (play' sampleRate' sampleNumber' sf) >> putMVar mVarEnd ()
  takeMVar mVarEnd
  return ()

play' ::Int -> Int -> SF () (Sample, Event ()) -> IO ()
play' sampleRate' sampleNumber' sf = do
  (device,context,pSource,pBuffer) <- initOpenAL
  
  mVarMaybeChunk <- newEmptyMVar
  mVarReply <- newEmptyMVar
  
  _ <- forkIO $ process sampleRate' pSource pBuffer mVarMaybeChunk mVarReply

  ir <- newIORef (0 :: Int)
  let sampleSize = sizeOf (undefined :: Int16)
      chunkSize' = sampleNumber' * sampleSize
  chunkData' <- mallocBytes chunkSize'

  let chunk = Chunk chunkData' chunkSize' 
      sense _ = return (1.0 / fromIntegral sampleRate', Just ())
      actuate _ (s,e) = if (isEvent e)
        then return True
        else do
          i <- readIORef ir
          pokeElemOff (chunkData chunk) i (fromSample s)
          if i == (sampleNumber' - 1)
            then do
              putMVar mVarMaybeChunk (Just chunk)
              takeMVar mVarReply
              writeIORef ir 0
              return False
            else do
              writeIORef ir (i + 1)
              return False
  
  reactimate (return ()) sense actuate sf

  i <- readIORef ir
  putMVar mVarMaybeChunk (Just $ chunk {chunkSize = i * sampleSize})
  takeMVar mVarReply
  putMVar mVarMaybeChunk Nothing
  takeMVar mVarReply

  deInitOpenAL device context pSource pBuffer
  free (chunkData chunk)

  
initOpenAL :: IO (Device, Context, Source, Buffer)
initOpenAL = do
  mDevice <- openDevice Nothing
  case mDevice of
    Nothing -> fail "opening OpenAL device"
    Just device -> do
      mContext <- createContext device []
      case mContext of 
        Nothing -> fail "opening OpenAL context"
        Just context -> do
          currentContext $= Just context
          [pSource] <- genObjectNames 1
          [pBuffer] <- genObjectNames 1
          queueBuffers pSource [pBuffer]
          return (device,context,pSource,pBuffer)
        
deInitOpenAL :: Device -> Context -> Source -> Buffer -> IO ()
deInitOpenAL device context pSource pBuffer = do 
  unqueueBuffers pSource [pBuffer]
  deleteObjectNames [pSource]
  deleteObjectNames [pBuffer]
  currentContext $= Nothing
  destroyContext context
  b <- closeDevice device
  case b of
    True -> return ()
    False -> fail "closing OpenAL device"
    
data Chunk =  Chunk {
    chunkData :: Ptr Int16
  , chunkSize :: Int
  } deriving (Eq, Show)

process :: Int -> Source -> Buffer -> MVar (Maybe Chunk) -> MVar () -> IO ()
process sampleRate' pSource pBuffer mVarMaybeChunk mVarReply = do
  mChunk <- takeMVar mVarMaybeChunk
  case mChunk of
    Nothing -> do
      waitForSource pSource
      putMVar mVarReply ()
    Just chunk -> do
      (bufferData pBuffer) $= createBufferData sampleRate' chunk
      putMVar mVarReply ()
      Sound.OpenAL.play [pSource]
      waitForSource pSource
      process sampleRate' pSource pBuffer mVarMaybeChunk mVarReply

createBufferData :: Int -> Chunk -> BufferData Int16
createBufferData sampleRate' chunk =
  BufferData (MemoryRegion (chunkData chunk) (fromIntegral $ chunkSize chunk))
             Mono16
             (fromIntegral sampleRate')

waitForSource :: Source -> IO ()
waitForSource pSource = do
  state <- get (sourceState pSource)
  case state of
    Playing -> do
      threadDelay 10 -- micro seconds
      waitForSource pSource
    _ -> return ()