loop/src/Sound.hs

{-|
Module      : Sound
Description : Channel selection and storage

This module checks for empty channels and plays sounds on them.
It uses data chunks loaded into an IntMap to determine the actual sounds played.
Sound specifications of type 'Sound' loaded into a Map can be used to
keep track of which sounds are playing.
Uses SDL.Mixer.
-}
module Sound (
    -- * Simple (One-Shot) Playback
      playSoundQueue
    , playPositionalSoundQueue
    -- * Complex Playback
    , playAndUpdate
    -- * Volume Control
    , setSoundVolume
    , setMusicVolume
    ) where
import Sound.Data

import qualified SDL.Mixer as Mix
import Data.Maybe
import qualified Data.IntMap.Strict as IM
import qualified Data.Map as M
import qualified Data.Vector.Fusion.Stream.Monadic as VS
import Control.Monad
import Control.Monad.Trans
import Control.Monad.Trans.Maybe
import Control.Lens
import Data.Int (Int16)
{- | Start playing new sounds and update sound specifications.
A Map of new sound specifications is merged with a Map of already playing sounds, 
then sounds in the merged Map are updated.
The Map of updated sound specifications is returned.

New sounds with the same keys as 
already playing sounds are merged as follows:

    * '_soundChannel' is set to the old value
    * if the old '_soundStatus' was 'FadingOut', it set to the new value (can restart playback with 'ToStart')
    * other fields are set to the new value.

In the update: 
    
    1. commence playing sounds with 'ToStart' status
    2. decrement timers, set any fading status
    3. apply 'Just' sound position effects, set value to 'Nothing'
    4. remove sounds that have stopped playing from the map.
 -}
playAndUpdate :: Ord a => SoundData a -> M.Map a Sound -> IO (M.Map a Sound)
playAndUpdate sData newSounds 
    = updateSounds (_loadedChunks sData) (M.unionWith mergeSound newSounds (_playingSounds sData))

mergeSound :: Sound -> Sound -> Sound
mergeSound newS oldS 
    | _soundStatus oldS == FadingOut
                = newS & soundChannel .~ _soundChannel oldS
    | otherwise = newS & soundChannel .~ _soundChannel oldS
                       & soundStatus  .~ _soundStatus oldS

updateSounds :: Ord a => IM.IntMap Mix.Chunk -> M.Map a Sound -> IO (M.Map a Sound)
updateSounds sd ss = do
    may <- mapM (runMaybeT . updateSound sd) ss
    return $ M.mapMaybe id may

updateSound :: IM.IntMap Mix.Chunk -> Sound -> MaybeT IO Sound
updateSound sd s =
    initialisePlaying sd s 
    >>= liftIO . (decrementTimer >=> applyPosition) 
    >>= cleanupHalted

initialisePlaying :: IM.IntMap Mix.Chunk -> Sound -> MaybeT IO Sound
initialisePlaying sd s = case _soundStatus s of
    ToStart -> tryPlay sd s
    _ -> return s

tryPlay :: IM.IntMap Mix.Chunk -> Sound -> MaybeT IO Sound
tryPlay sd s = do
    i <- tryGetChannel s
    _ <- liftIO $ do
        Mix.halt i
        Mix.playOn i Mix.Once (sd IM.! _soundChunkID s)
    return $ s 
        & soundChannel  ?~ i
        & soundStatus   .~ Playing

--repetitions :: Sound -> Mix.Times
--repetitions s = case _soundTime s of
--    Nothing -> Mix.Once
--    _       -> Mix.Forever

tryGetChannel :: Sound -> MaybeT IO Mix.Channel
tryGetChannel s = case _soundChannel s of
    Just i  -> return i
    Nothing -> MaybeT $ Mix.getAvailable Mix.DefaultGroup

decrementTimer :: Sound -> IO Sound
decrementTimer s = case _soundTime s of
    Just t 
        | t > 0     -> return $ s & soundTime ?~ t - 1
        | otherwise -> fadeOutMaybe (_soundChannel s) (_soundFadeTime s)
                            >> return (s & soundTime .~ Nothing
                                         & soundStatus .~ FadingOut)
    Nothing -> return s

applyPosition :: Sound -> IO Sound
applyPosition s = case _soundPos s of
    Nothing     -> return s
    Just (a,d)  -> Mix.effectPosition (fromJust $ _soundChannel s) a d
                    >> return (s & soundPos .~ Nothing)

fadeOutMaybe 
    :: Maybe Mix.Channel 
    -> Int -- ^ fade out time: UNUSED, Mix.fadeOut is buggy
    -> IO ()
--fadeOutMaybe (Just x) fadeT = Mix.fadeOut (fromIntegral fadeT + 1) x
fadeOutMaybe (Just x) _ = Mix.halt x
fadeOutMaybe _ _ = return ()

cleanupHalted :: Sound -> MaybeT IO Sound
cleanupHalted s = do
    i <- MaybeT $ return $ _soundChannel s
    isPlaying <- liftIO $ Mix.playing i
    if isPlaying
       then return s
       else mzero

-----------------------------------------------------------------
{- | Play sounds from a list of indices.
For each index, the corresponding sound starts playing if there is a free channel.
Use this if you don't care about timing, overlapping, fading, or sound positions.
-}
playSoundQueue :: IM.IntMap Mix.Chunk -> [Int] -> IO ()
playSoundQueue chunkMap ns = forM_ ns $ \n -> runMaybeT $ playIfFree (chunkMap IM.! n) Mix.Once
{- | Given a chunk, attempt to play this on a free channel a given number of
times. Returns 'Just' the channel if succeeds.
-}

playIfFree :: Mix.Chunk -> Mix.Times -> MaybeT IO Mix.Channel
playIfFree c times = do
    i <- MaybeT $ Mix.getAvailable Mix.DefaultGroup
    liftIO $ Mix.playOn i times c

-----------------------------------------------------------------
{- | Play sounds from a list of index/position pairs.
As for 'playSoundQueue', but with positional information in the form of an Int16.
-}
playPositionalSoundQueue :: IM.IntMap Mix.Chunk -> [(Int,Int16)] -> IO ()
playPositionalSoundQueue chunkMap = VS.mapM_ ( \(n,a) -> 
    runMaybeT $ playIfFree (chunkMap IM.! n) Mix.Once >>= setChannelPos a )
    . VS.fromList

setChannelPos :: Int16 -> Mix.Channel -> MaybeT IO Mix.Channel
setChannelPos a i = do
    _ <- liftIO $ Mix.effectPosition i a 0 
    return i


-----------------------------------------------------------------
{- | Set the volume for all sound channels.
Behind the scenes, scales a float [0,1] to an Int [0..128].
 -}
setSoundVolume :: Float -> IO ()
setSoundVolume x = Mix.setVolume (round (x * 128)) Mix.AllChannels

{- | Set the music volume.
Behind the scenes, scales a float [0,1] to an Int [0..128].
 -}
setMusicVolume :: Float -> IO ()
setMusicVolume x = Mix.setMusicVolume (round (x * 128))