Refactor sound

app/Main.hs

@@ -53,8 +53,8 @@ main = do
         ( \preData w -> do
             startTicks <- SDL.ticks
             void $ doDrawing (_renderData preData) w
-            playSoundQueue (_soundData preData) (_soundQueue w)
+            playSoundQueue (_loadedChunks $ _soundData preData) (_soundQueue w)
-            newSoundData <- playAndUpdate (_sounds w) (_soundData preData)
+            newPlayingSounds <- playAndUpdate (_soundData preData) (_sounds w)
 
             endTicks <- SDL.ticks
             let lastFrameTicks = _frameTimer preData
@@ -64,7 +64,7 @@ main = do
                     . translate (-0.5) (-0.8) . scale 0.0005 0.0005 
                     . text $ "ms/frame " ++ show (endTicks - lastFrameTicks)
                 )
-            return $ preData & soundData  .~ newSoundData
+            return $ preData & soundData . playingSounds .~ newPlayingSounds
                              & frameTimer .~ endTicks
         )
         (flip $ menuEvents handleEvent)

src/Dodge/Base.hs

@@ -583,8 +583,9 @@ collidePointWallsNorm p1 p2 ws = listToMaybe $ sortBy f $ IM.elems $ IM.mapMaybe
                                         ) ws
     where f (a,_) (b,_) = compare (magV (p1 -.- a)) (magV (p1 -.- b))
 
--- looks for first collision of a point with walls
+{- | Looks for first collision of a point with walls.
--- if found, gives point and colour of wall
+If found, gives point and colour of wall.
+-}
 collidePointWallsCol :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Color)
 collidePointWallsCol p1 p2 ws = listToMaybe $ sortBy f $ IM.elems $ IM.mapMaybe 
                                         ( (\(m, c) -> fmap (flip (,) c) m)
@@ -592,8 +593,9 @@ collidePointWallsCol p1 p2 ws = listToMaybe $ sortBy f $ IM.elems $ IM.mapMaybe
                                                     (_wlLine w !! 0) (_wlLine w !! 1), _wlColor w))
                                         ) ws
     where f (a,_) (b,_) = compare (magV (p1 -.- a)) (magV (p1 -.- b))
--- looks for first collision of a point with walls
+{- | Looks for first collision of a point with walls.
--- if found, gives point, and normal and colour of wall
+If found, gives point, and normal and colour of wall.
+-}
 collidePointWallsNormCol :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2,Color)
 collidePointWallsNormCol p1 p2 ws 
     = listToMaybe $ sortBy f $ IM.elems $ IM.mapMaybe m ws
@@ -603,7 +605,7 @@ collidePointWallsNormCol p1 p2 ws
           m w = let (a1,a2,a3) = ls w
                 in  fmap (\a4 -> (a4,a2,a3)) a1
 
---returns the first creature, if any, that a point intersects with
+-- | Returns the first creature, if any, that a point intersects with.
 collidePointCreatures :: Point2 -> Point2 -> World -> Maybe Int
 collidePointCreatures p1 p2 w = fmap fst $ listToMaybe $ sortBy (csnd) $ IM.toList $
                                 IM.mapMaybe (\x -> 
@@ -611,8 +613,8 @@ collidePointCreatures p1 p2 w = fmap fst $ listToMaybe $ sortBy (csnd) $ IM.toLi
                                        ) 
                                        (_creatures w)
     where csnd (_,a) (_,b) = compare a b
---as for collidePointCreatures, only increases the radius of creatures by a
+-- | As for 'collidePointCreatures', only increases the radius of creatures by a
---fixed amount, thus collides a moving circle with creaures
+--fixed amount, thus collides a moving circle with creaures.
 collideCircCreatures :: Point2 -> Point2 -> Float -> World -> Maybe Int
 collideCircCreatures p1 p2 rad w = fmap fst $ listToMaybe $ sortBy (csnd) $ IM.toList $
                                 IM.mapMaybe (\x -> 
@@ -622,34 +624,45 @@ collideCircCreatures p1 p2 rad w = fmap fst $ listToMaybe $ sortBy (csnd) $ IM.t
     where csnd (_,a) (_,b) = compare a b
 
 
---returns the first creature, if any, that a point intersects with, gives point
+-- | Returns the first creature, if any, that a point intersects with, gives point
---in creature on line
+--in creature on line.
 collidePointCrsPoint :: Point2 -> Point2 -> World -> Maybe (Point2,Int)
 collidePointCrsPoint p1 p2 w = fmap f $ listToMaybe $ sortBy (csndsnd) $ IM.toList $
                                 IM.mapMaybe (\x -> 
                                         collidePointCirc'' p1 p2 (_crRad x) (_crPos x)
                                        ) 
                                        (_creatures w)
-    where csndsnd (_,(_,a)) (_,(_,b)) = compare a b
+  where 
+    csndsnd (_,(_,a)) (_,(_,b)) = compare a b
     f (cID,(p,_)) = (p,cID)
 collideCircCrsPoint :: Point2 -> Point2 -> Float -> World -> Maybe (Point2,Int)
-collideCircCrsPoint p1 p2 rad w = fmap f $ listToMaybe $ sortBy (csndsnd) $ IM.toList $
+collideCircCrsPoint p1 p2 rad w 
-                                IM.mapMaybe (\x -> 
+    = fmap f 
+    . listToMaybe 
+    . sortBy (csndsnd) 
+    . IM.toList 
+    $ IM.mapMaybe (\x -> 
              collidePointCirc'' p1 p2 (rad + _crRad x) (_crPos x)
              ) 
              (_creatures w)
-    where csndsnd (_,(_,a)) (_,(_,b)) = compare a b
+  where 
+    csndsnd (_,(_,a)) (_,(_,b)) = compare a b
     f (cID,(p,_)) = (p,cID)
 
 
--- makes a creatures not hittable
+-- | Makes a creature not hittable.
 collidePointCrsWithoutPoint :: Int -> Point2 -> Point2 -> World -> Maybe (Point2,Int)
-collidePointCrsWithoutPoint cid p1 p2 w = fmap f $ listToMaybe $ sortBy (csndsnd) $ IM.toList $
+collidePointCrsWithoutPoint cid p1 p2 w 
-                                IM.mapMaybe (\x -> 
+    = fmap f 
+    . listToMaybe 
+    . sortBy (csndsnd) 
+    . IM.toList 
+    $ IM.mapMaybe (\x -> 
         collidePointCirc'' p1 p2 (_crRad x) (_crPos x)
         ) 
         (IM.delete cid $ _creatures w)
-    where csndsnd (_,(_,a)) (_,(_,b)) = compare a b
+  where 
+    csndsnd (_,(_,a)) (_,(_,b)) = compare a b
     f (cID,(p,_)) = (p,cID)
 
 circOnSomeWall :: Point2 -> Float -> World -> Bool
@@ -664,36 +677,56 @@ crsNearPoint :: Float -> Point2 -> World -> Bool
 crsNearPoint d p w = any (\c -> dist (_crPos c) p < (d + _crRad c)) (_creatures w)
 
 crsOnLine :: Point2 -> Point2 -> World -> [Creature]
-crsOnLine p1 p2 w = IM.elems 
+crsOnLine p1 p2 w 
-                        $ IM.filter (\cr -> circOnSeg p1 p2 (_crPos cr) (_crRad cr))
+    = IM.elems 
+    . IM.filter (\cr -> circOnSeg p1 p2 (_crPos cr) (_crRad cr))
     $ _creatures w
 
 crsOnThickLine :: Float -> Point2 -> Point2 -> World -> [Creature]
-crsOnThickLine thickness p1 p2 w = IM.elems 
+crsOnThickLine thickness p1 p2 w 
-                        $ IM.filter (\cr -> circOnSeg p1 p2 (_crPos cr) (_crRad cr + thickness))
+    = IM.elems 
+    . IM.filter (\cr -> circOnSeg p1 p2 (_crPos cr) (_crRad cr + thickness))
     $ _creatures w
 
+{- | Find 'Maybe' the closest creature to a point, within a circle.
+ -}
 nearestCrInRad :: Point2 -> Float -> World -> Maybe Creature
-nearestCrInRad p r w = let crs = IM.filter (\cr -> dist p (_crPos cr) < r) $ _creatures w
+nearestCrInRad p r w 
+    = let crs = IM.filter (\cr -> dist p (_crPos cr) < r) $ _creatures w
           sortedCrs = sortBy (compare `on` (dist p . _crPos)) $ IM.elems crs
       in  listToMaybe sortedCrs
 
-nearestCrInTri :: Point2 -> Float -> Float -> World -> Maybe Creature
+{- | Find 'Maybe' the closest creature in front of a point in a right-angle-triangle shape.
+ -}
+nearestCrInTri 
+    :: Point2 
+    -> Float    -- ^ Direction (radians +ve anticlockwise from x-axis).
+    -> Float    -- ^ Distance. 
+    -> World -> Maybe Creature
 nearestCrInTri p dir x w 
     = let crs = IM.filter (\cr -> errorPointInPolygon 1 (_crPos cr) tri) $ _creatures w
           sortedCrs = sortBy (compare `on` (dist p . _crPos)) $ IM.elems crs
       in  listToMaybe sortedCrs
-        where tri = [p 
+ where 
+    tri = [p 
           ,p +.+ rotateV (dir-pi/4) (x,0)
           ,p +.+ rotateV (dir+pi/4) (x,0)
           ]
-
+{- | Find 'Maybe' the closes creature in front of a point in a given direction for
-nearestCrInFront :: Point2 -> Float -> Float -> World -> Maybe Creature
+a given distance.
+The shapes within which creatures are searched are a triangle then rectangle.
+ -}
+nearestCrInFront 
+    :: Point2
+    -> Float    -- ^ Direction (radians +ve anticlockwise from x-axis).
+    -> Float    -- ^ Distance.
+    -> World -> Maybe Creature
 nearestCrInFront p dir x w 
     = let crs = IM.filter (\cr -> errorPointInPolygon 2 (_crPos cr) rec) $ _creatures w
           sortedCrs = sortBy (compare `on` (dist p . _crPos)) $ IM.elems crs
       in  listToMaybe sortedCrs
-        where rec = [p
+  where 
+    rec = [p
           ,pR
           ,pR1
           ,pL1
@@ -704,15 +737,25 @@ nearestCrInFront p dir x w
     pR1 = pR +.+ rotateV dir (x/2,0)
     pL1 = pL +.+ rotateV dir (x/2,0)
 
+{- | Test whether a creature is in a polygon.
+ -}
 crInPolygon :: Creature -> [Point2] -> Bool
 crInPolygon cr xs = errorPointInPolygon 3 (_crPos cr) xs
 
+{- | Uses a layer to set the depth.
+ -}
 onLayer :: Layer -> Picture -> Picture
 onLayer l = setDepth $ 1 - fromIntegral (levLayer l) / 100
 
+{- | Set a depth according to a list of numbers.
+Lists are lexicographically ordered if input values are always less than 100.
+Higher numbers will get placed on top of lower numbers.
+-}
 onLayerL :: [Int] -> Picture -> Picture
-onLayerL is = setDepth (1 - (sum $ zipWith (/) (map fromIntegral is) $ map (\x->100**x) [1..]))
+onLayerL is = setDepth (1 - (sum $ zipWith (/) (map fromIntegral is) $ map (100 **) [1..]))
 
+{- | For depth testing, set layer values.
+ -}
 levLayer :: Layer -> Int
 levLayer BgLayer            = 20
 levLayer PressPlateLayer    = 45
@@ -729,6 +772,8 @@ levLayer LabelLayer         = 80
 levLayer InvLayer           = 85
 levLayer MenuLayer          = 90
 
+{- | Transform coordinates from world position to normalised screen coordinates.
+ -}
 worldPosToScreen :: World -> Point2 -> Point2
 worldPosToScreen w = doWindowScale . doRotate . doZoom . doTranslate
   where
@@ -739,6 +784,9 @@ worldPosToScreen w = doWindowScale . doRotate . doZoom . doTranslate
                             , y * 2 / _windowY w
                             )
 
+{- | Transform coordinates from the map position to normalised screen
+coordinates.
+ -}
 cartePosToScreen :: World -> Point2 -> Point2
 cartePosToScreen w = doWindowScale . doRotate . doZoom . doTranslate
   where
@@ -749,32 +797,42 @@ cartePosToScreen w = doWindowScale . doRotate . doZoom . doTranslate
                             , y * 2 / _windowY w
                             )
 
+{- | The mouse position in world coordinates.
+ -}
 mouseWorldPos :: World -> Point2
 mouseWorldPos w = _cameraCenter w +.+ (1/_cameraZoom w) *.* rotateV (_cameraRot w) (_mousePos w)
 
+{- | The mouse position in map coordinates
+ -}
 mouseCartePos :: World -> Point2
 mouseCartePos w = _carteCenter w +.+ (1/_carteZoom w) *.* rotateV (_carteRot w) (_mousePos w)
 
+{- | Create a logistic function given three parameters.
+ -}
 logistic :: Float -> Float -> Float -> (Float -> Float)
 logistic x0 l k x = l / (1 + exp (k*(x0 - x)))
 
-wallLOS :: [Point2] -> Point2 -> Point2 -> Bool
-{-# INLINE wallLOS #-}
-wallLOS !(x:y:_) !c !p = isRHS c x y || isLHS p x' y' || isLHS c p x || isRHS c p y
-    where n = 10 *.* (safeNormalizeV . vNormal $ y -.- x)
-          x' = x +.+ n
-          y' = y +.+ n
 
-wallsLOS :: Foldable t => t [Point2] -> Point2 -> Point2 -> Bool
+{- | given a target and a start point, shift toward the end point by a given
-{-# INLINE wallsLOS #-}
+amount.
-wallsLOS !ls !c !p = all (\l -> wallLOS l c p) ls
+If close enough, end up on the end point
-
+-}
-mvPointTowardAtSpeed :: Float -> Point2 -> Point2 -> Point2
+mvPointTowardAtSpeed 
+    :: Float    -- ^ Speed.
+    -> Point2   -- ^ End point.
+    -> Point2   -- ^ Start point.
+    -> Point2
 mvPointTowardAtSpeed speed !ep !p 
     | dist p ep < speed = ep
     | otherwise         = p +.+ speed *.* normalizeV (ep -.- p)
 
-mvPointToward :: Point2 -> Point2 -> Point2
+{- | given a target and a start point, shift toward the end point by 1.
+If close enough, end up on the end point
+-}
+mvPointToward 
+    :: Point2 -- ^ End point.
+    -> Point2 -- ^ Start point.
+    -> Point2
 mvPointToward !ep !p | dist p ep < 1 = ep
                      | otherwise     = p +.+ normalizeV (ep -.- p)
 

src/Dodge/SoundLogic.hs

@@ -1,5 +1,7 @@
 module Dodge.SoundLogic where
 import Dodge.Data
+import Sound.Preload (SoundStatus (..))
+
 import Control.Lens
 import qualified Data.Map as M
 
@@ -22,7 +24,7 @@ soundOnceOrigin sType so = over sounds (M.insertWith (flip const) so sound)
         { _soundChunkID     = sType
         , _soundTime        = Nothing
         , _soundFadeTime    = 0
-        , _soundIsFadingOut = False
+        , _soundStatus      = ToStart
         , _soundChannel     = Nothing
         , _soundPos         = Nothing
         }
@@ -33,7 +35,7 @@ soundFrom so sType time fadeTime w = over sounds (M.insertWith f so sound) w
     sound = Sound 
         { _soundChunkID     = sType
         , _soundTime        = Just time
-        , _soundIsFadingOut = False
+        , _soundStatus      = ToStart
         , _soundFadeTime    = fadeTime
         , _soundChannel     = Nothing
         , _soundPos         = Nothing
@@ -45,8 +47,11 @@ soundMultiFrom [] _ _ _ w = w
 soundMultiFrom (so:sos) sType time fadeTime w
     | so `M.member` _sounds w = soundMultiFrom sos sType time fadeTime w
     | otherwise = over sounds (M.insert so sound) w
-        where sound = Sound { _soundChunkID = sType
+  where 
+    sound = Sound 
+        { _soundChunkID     = sType
         , _soundTime        = Nothing
+        , _soundStatus      = ToStart
         , _soundFadeTime    = fadeTime
         , _soundChannel     = Nothing
         , _soundPos         = Nothing

src/Sound.hs

@@ -3,13 +3,17 @@ 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,
+It uses data chunks loaded into an IntMap to determine the actual sounds played.
-and sound specifications of type 'Sound' loaded into a Map to 
+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
+module Sound (
-    where
+    -- * Simple (One-Shot) Playback
+      playSoundQueue
+    -- * Complex Playback
+    , playAndUpdate
+    ) where
 import Sound.Preload
 
 import qualified SDL.Mixer as Mix
@@ -17,49 +21,102 @@ import Data.Maybe
 import qualified Data.IntMap as IM
 import qualified Data.Map as M
 import Control.Monad
+import Control.Monad.Trans
+import Control.Monad.Trans.Maybe
 import Control.Lens
-
-{- | Play sounds from a list of indices.
-Each sound starts playing (and will not repeat) if there is a free channel.
-Use this if you don't care about timing, overlapping, fading, etc.
--}
-playSoundQueue :: SoundData a -> [Int] -> IO ()
-playSoundQueue sd ns = forM_ ns $ \n -> playIfFree (_loadedChunks sd IM.! n) Mix.Once
-
 {- | Start playing new sounds and update sound specifications.
-I think that this expects that unfinished sounds get passed forwards within the Map, to be rethought:
+A Map of new sound specifications is merged with a Map of already playing sounds, 
-there may be a leak in the current typical usage.
+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 in the following manner:
+
+    * the '_soundChannel' is set to the old value
+    * if the old '_soundStatus' was 'FadingOut', it is replaced with the new status (allowing playback to be restarted using 'ToStart')
+    * all other fields are set to the new value.
+
+In the update: 
+    
+    1. sounds with a value 'ToStart' commence playing
+    2. timers are decremented and any fading status is set
+    3. sounds that have stopped playing are removed from the map.
  -}
-playAndUpdate :: Ord a => M.Map a Sound -> SoundData a -> IO (SoundData a)
+playAndUpdate :: Ord a => SoundData a -> M.Map a Sound -> IO (M.Map a Sound)
-playAndUpdate new sd = playSounds $ over playingSounds (updatePlaying new) sd
+playAndUpdate sData newSounds 
+    = updateSounds (_loadedChunks sData) (mergeSounds newSounds (_playingSounds sData))
 
---updateSound :: Sound -> Sound -> IO Sound
+mergeSounds :: Ord a => M.Map a Sound -> M.Map a Sound -> M.Map a Sound
---updateSound newS oldS 
+mergeSounds as bs = M.unionWith mergeSound as bs
---    | _soundIsFadingOut oldS 
---                = Mix.playOn i times 
---    | otherwise = newS & soundChannel .~ _soundChannel oldS
 
-startPlaying :: SoundData a -> Sound -> IO (Maybe Sound)
+mergeSound :: Sound -> Sound -> Sound
-startPlaying sd s = case _soundChannel s of
+mergeSound newS oldS 
-    Just _  -> return $ Just s
+    | _soundStatus oldS == FadingOut
-    Nothing -> playSoundIfFree (_loadedChunks sd IM.! _soundChunkID s) s
+                = newS & soundChannel .~ _soundChannel oldS
+    | otherwise = newS & soundChannel .~ _soundChannel oldS
+                       & soundStatus  .~ _soundStatus oldS
 
-decrimentTimer :: Sound -> IO Sound
+updateSounds :: Ord a => IM.IntMap Mix.Chunk -> M.Map a Sound -> IO (M.Map a Sound)
-decrimentTimer s = case _soundTime s of
+updateSounds sd ss = do
-    Just t | t > 0     -> return $ s & soundTime ?~ t - 1
+    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 >>= 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  .~ Just 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 .~ Just (t - 1)
            | otherwise -> fadeOutMaybe (_soundChannel s) (_soundFadeTime s)
                             >> return (s & soundTime .~ Nothing
-                                         & soundIsFadingOut .~ True)
+                                         & soundStatus .~ FadingOut)
+    Nothing -> return s
 
-cleanupHalted :: Sound -> IO (Maybe Sound)
+fadeOutMaybe :: Maybe Mix.Channel -> Int -> IO ()
-cleanupHalted s = case _soundChannel s of
+fadeOutMaybe (Just x) fadeT = Mix.fadeOut (fromIntegral fadeT + 1) x
-    Nothing -> return Nothing
+fadeOutMaybe _ _ = return ()
-    Just i  -> do
+
-        isPlaying <- Mix.playing i
+cleanupHalted :: Sound -> MaybeT IO Sound
+cleanupHalted s = do
+    i <- MaybeT $ return $ _soundChannel s
+    isPlaying <- liftIO $ Mix.playing i
     if isPlaying
-            then return $ Just s
+       then return s
-            else return Nothing
+       else mzero
 
+-----------------------------------------------------------------
+{- | Play sounds from a list of indices.
+Each sound starts playing (and will not repeat) 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 -> 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.
 -}
@@ -69,61 +126,4 @@ playIfFree c times = do
     case mayChan of
         Nothing -> return Nothing
         Just i  -> Just <$> Mix.playOn i times c
-{- | Given a chunk and sound specification, play the chunk according to the specification
-if there is a free channel.
-On success return 'Just' an updated sound specification.
--}
-playSoundIfFree :: Mix.Chunk -> Sound -> IO (Maybe Sound)
-playSoundIfFree c s = case _soundTime s of
-    Just _  -> playIfFree c Mix.Forever >>= return . f
-    Nothing -> playIfFree c Mix.Once    >>= return . f
-  where 
-    f :: Maybe Mix.Channel -> Maybe Sound
-    f = fmap ( \chan -> s & soundChannel ?~ chan)
-
-{- | Stop a channel if it was playing.
-Always returns 'IO' 'Nothing'.
--}
-haltMaybe :: Maybe Mix.Channel -> IO (Maybe Sound)
-haltMaybe (Just x) = Mix.halt x >> return Nothing
-haltMaybe Nothing = return Nothing
-
-fadeOutMaybe :: Maybe Mix.Channel -> Int -> IO ()
-fadeOutMaybe (Just x) fadeT = Mix.fadeOut (fromIntegral fadeT) x
-fadeOutMaybe _ _ = return ()
-
-{- | Play a sound according to it's specification.
-Logic: check if sound is playing:
-
-    1. If so, decrement timers, and/or stop playing and remove 
-    2. If not, check if there is free channel:
-
-        * If so, start playing
-        * If not, remove sound.
--}
-updateOrStartSound :: SoundData a -> Sound -> IO (Maybe Sound)
-updateOrStartSound sd s = case _soundChannel s of
-    Just i  -> case _soundTime s of
-        Just t | t > 0     -> return $ Just $ set soundTime (Just $ t - 1) s
-               | otherwise -> haltMaybe (_soundChannel s)
-        Nothing -> Mix.playing i >>= (\b -> if b 
-                                            then return (Just s)
-                                            else return Nothing
-                                    )
-    Nothing -> playSoundIfFree (_loadedChunks sd IM.! _soundChunkID s) s
-
-{- | Play all sounds and create new sound data.
- -}
-playSounds :: SoundData a -> IO (SoundData a)
-playSounds sd = do
-    newSounds <- mapM (updateOrStartSound sd) (_playingSounds sd)
-    return $ sd & playingSounds .~ M.mapMaybe id newSounds
-
-{- | Update sound specifications by overwriting an old Map with a new Map.
-Copies any information about channels from the old Map to the new Map.
--} 
-updatePlaying :: Ord a => M.Map a Sound -> M.Map a Sound -> M.Map a Sound
-updatePlaying new old = M.unionWith f new old
-  where 
-    f newSound oldSound = newSound {_soundChannel = _soundChannel oldSound}
 

src/Sound/Preload.hs

@@ -7,6 +7,12 @@ import qualified Data.Map as M
 import Control.Lens
 import Geometry
 
+data SoundStatus 
+    = Playing
+    | FadingOut
+    | ToStart
+  deriving (Eq,Ord,Show)
+
 data SoundData a = SoundData
     {_loadedChunks :: IM.IntMap Mix.Chunk
     ,_playingSounds :: M.Map a Sound
@@ -14,7 +20,7 @@ data SoundData a = SoundData
 data Sound = Sound 
     { _soundTime        :: Maybe Int
     , _soundFadeTime    :: Int
-    , _soundIsFadingOut :: Bool
+    , _soundStatus      :: SoundStatus
     , _soundChannel     :: Maybe Mix.Channel
     , _soundPos         :: Maybe Point2
     , _soundChunkID     :: Int