SimplePlayer.hs

{- 2009 Daniel van den Eijkel <dvde@gmx.net> -}

{-# OPTIONS_GHC -fglasgow-exts #-}
module Sound.Hommage.DSPlayer.SimplePlayer
 ( SimplePlayer (..)
 , mkSimplePlayer
 )
 where

import Sound.Hommage.DSPlayer.DSPlayer
import Sound.Hommage.DSPlayer.VoicePlayer
import Sound.Hommage.Misc (for')

import Control.Monad
import Data.Array.Storable as STA
import Data.IORef
import Foreign
import System.IO

---------------------------------------------------------------------------------------------------
data SimplePlayer = SimplePlayer 
 { dsplayerSP :: DSPlayer                                       -- ^ DSPlayer
 , playSP :: (Ptr Double -> Ptr Double -> IO Voice) -> IO ()    -- ^ creates and plays a voice
 , killSP :: IO ()                                              -- ^ removes all active voices
 , fptSP :: Int -> IO ()                                        -- ^ set the number of frames per tick
 , setOnTickSP :: IO () -> IO ()                                -- ^ set the action which is performed on each tick
 }
---------------------------------------------------------------------------------------------------
mkSimplePlayer :: Int -> IO SimplePlayer
mkSimplePlayer latency = do
 voiceplayer       <- mkVoicePlayer
 framecount_ref    <- newIORef 0
 ontick_ref        <- newIORef (return ())
 framespertick_ref <- newIORef 800
 (leftOutputBuffer  :: STA.StorableArray Int Double) <- STA.newArray (0, 511) 0.0
 (rightOutputBuffer :: STA.StorableArray Int Double) <- STA.newArray (0, 511) 0.0
 let --mkVoice :: (Ptr Double -> Ptr Double -> IO Voice) -> IO Voice
     mkVoice f = withStorableArray leftOutputBuffer $ \ptrL ->
                 withStorableArray rightOutputBuffer $ \ptrR -> f ptrL ptrR 
           
     --addVoice :: Voice -> IO ()
     addVoice v = startVoice voiceplayer $! v     

     --stopAll :: IO ()
     stopAll = clearVoicePlayer voiceplayer          

     --setFPT :: Int -> IO ()
     setFPT fpt = writeIORef framespertick_ref $! max 512 fpt           

     --setOnTick :: IO () -> IO ()
     setOnTick f = writeIORef ontick_ref f
           
     fillOutputBuffers =
         STA.withStorableArray leftOutputBuffer $ \ptrL -> 
         STA.withStorableArray rightOutputBuffer $ \ptrR -> do
             framecount <- readIORef framecount_ref
             framecount' <- for' 0 (<512) (+1) framecount $ \i framecount -> do
                              pokeElemOff ptrL i 0
                              pokeElemOff ptrR i 0
                              when (framecount == 0) (join $ readIORef ontick_ref) --tickcount -- --$ getCurrentPE pateng tickcount >>= sequence_    
                              stepVoicePlayer voiceplayer i
                              fpt <- readIORef framespertick_ref
                              let framecount' = framecount + 1
                              if framecount' >= fpt
                                then return 0
                                else return framecount'
             writeIORef framecount_ref framecount'     
                    
     lat = max 1 latency
     sampleRate = 44100
     fillBuffer outputBuffer _ = 
              STA.withStorableArray leftOutputBuffer $ \ptrL -> 
              STA.withStorableArray rightOutputBuffer $ \ptrR -> do
                forM_ [0..lat-1] $ \i -> do 
                --for 0 (<lat) (+1) $ \i -> do 
                    fillOutputBuffers
                    copyStereoOutputBuf512 ptrL ptrR $! (outputBuffer `advancePtr` (1024 * i))       
                return ()      

 return ( SimplePlayer 
              (DSPlayer { sampleRateDS = sampleRate
                       , bufferSizeDS = lat * 512
                       , isStereoDS = True
                       , fillBufferCallbackDS = fillBuffer
                       })
              (\v -> mkVoice v >>= addVoice)
              stopAll
              setFPT
              setOnTick )
 
copyStereoOutputBuf512 :: Ptr Double -> Ptr Double -> Ptr Int16 -> IO ()
copyStereoOutputBuf512 ptrL ptrR ptrO = do
  forM_ [0..511] $ \i -> do
  --for 0 (<512) (+1) $ \i -> do 
    vl <- peekElemOff ptrL i 
    vr <- peekElemOff ptrR i 
    let k = fromIntegral (i+i) :: Int
        al = round (vl*10000) :: Int16
        ar = round (vr*10000) :: Int16 
    pokeElemOff ptrO (k  ) al  -- left channel
    pokeElemOff ptrO (k+1) ar  -- right channel