diff --git a/app/Main.hs b/app/Main.hs index f4515a0ba..df1793804 100644 --- a/app/Main.hs +++ b/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) - newSoundData <- playAndUpdate (_sounds w) (_soundData preData) + playSoundQueue (_loadedChunks $ _soundData preData) (_soundQueue w) + 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) diff --git a/src/Dodge/Base.hs b/src/Dodge/Base.hs index 21cfeb529..0c0380c44 100644 --- a/src/Dodge/Base.hs +++ b/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 --- if found, gives point and colour of wall +{- | Looks for first collision of a point with walls. +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 --- if found, gives point, and normal and colour of wall +{- | Looks for first collision of a point with walls. +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 ---fixed amount, thus collides a moving circle with creaures +-- | As for 'collidePointCreatures', only increases the radius of creatures by a +--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,35 +624,46 @@ 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 ---in creature on line +-- | Returns the first creature, if any, that a point intersects with, gives point +--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 - f (cID,(p,_)) = (p,cID) + 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 $ - IM.mapMaybe (\x -> - collidePointCirc'' p1 p2 (rad + _crRad x) (_crPos x) - ) - (_creatures w) - where csndsnd (_,(_,a)) (_,(_,b)) = compare a b - f (cID,(p,_)) = (p,cID) +collideCircCrsPoint p1 p2 rad w + = 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 + 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 $ - IM.mapMaybe (\x -> - collidePointCirc'' p1 p2 (_crRad x) (_crPos x) - ) - (IM.delete cid $ _creatures w) - where csndsnd (_,(_,a)) (_,(_,b)) = compare a b - f (cID,(p,_)) = (p,cID) +collidePointCrsWithoutPoint cid p1 p2 w + = 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 + f (cID,(p,_)) = (p,cID) circOnSomeWall :: Point2 -> Float -> World -> Bool circOnSomeWall p rad w = any (\(x:y:_) -> circOnSeg x y p rad) @@ -664,55 +677,85 @@ 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 - $ IM.filter (\cr -> circOnSeg p1 p2 (_crPos cr) (_crRad cr)) - $ _creatures w +crsOnLine p1 p2 w + = 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 - $ IM.filter (\cr -> circOnSeg p1 p2 (_crPos cr) (_crRad cr + thickness)) - $ _creatures w +crsOnThickLine thickness p1 p2 w + = 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 - sortedCrs = sortBy (compare `on` (dist p . _crPos)) $ IM.elems crs - in listToMaybe sortedCrs +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 - ,p +.+ rotateV (dir-pi/4) (x,0) - ,p +.+ rotateV (dir+pi/4) (x,0) - ] - -nearestCrInFront :: Point2 -> Float -> Float -> World -> Maybe Creature + 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 +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 - ,pR - ,pR1 - ,pL1 - ,pL - ] - pR = p +.+ rotateV (dir - pi*(3/8)) (x/2,0) - pL = p +.+ rotateV (dir + pi*(3/8)) (x/2,0) - pR1 = pR +.+ rotateV dir (x/2,0) - pL1 = pL +.+ rotateV dir (x/2,0) + where + rec = [p + ,pR + ,pR1 + ,pL1 + ,pL + ] + pR = p +.+ rotateV (dir - pi*(3/8)) (x/2,0) + pL = p +.+ rotateV (dir + pi*(3/8)) (x/2,0) + 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 -{-# INLINE wallsLOS #-} -wallsLOS !ls !c !p = all (\l -> wallLOS l c p) ls - -mvPointTowardAtSpeed :: Float -> Point2 -> Point2 -> Point2 +{- | given a target and a start point, shift toward the end point by a given +amount. +If close enough, end up on the end point +-} +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) diff --git a/src/Dodge/SoundLogic.hs b/src/Dodge/SoundLogic.hs index 27eae8a2f..a0d633eda 100644 --- a/src/Dodge/SoundLogic.hs +++ b/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 @@ -19,24 +21,24 @@ soundOnceOrigin :: Int -> SoundOrigin -> World -> World soundOnceOrigin sType so = over sounds (M.insertWith (flip const) so sound) where sound = Sound - { _soundChunkID = sType - , _soundTime = Nothing - , _soundFadeTime = 0 - , _soundIsFadingOut = False - , _soundChannel = Nothing - , _soundPos = Nothing + { _soundChunkID = sType + , _soundTime = Nothing + , _soundFadeTime = 0 + , _soundStatus = ToStart + , _soundChannel = Nothing + , _soundPos = Nothing } soundFrom :: SoundOrigin -> Int -> Int -> Int -> World -> World soundFrom so sType time fadeTime w = over sounds (M.insertWith f so sound) w where sound = Sound - { _soundChunkID = sType - , _soundTime = Just time - , _soundIsFadingOut = False - , _soundFadeTime = fadeTime - , _soundChannel = Nothing - , _soundPos = Nothing + { _soundChunkID = sType + , _soundTime = Just time + , _soundStatus = ToStart + , _soundFadeTime = fadeTime + , _soundChannel = Nothing + , _soundPos = Nothing } f _ s = s {_soundTime = Just time, _soundFadeTime = fadeTime} @@ -45,12 +47,15 @@ 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 - , _soundTime = Nothing - , _soundFadeTime = fadeTime - , _soundChannel = Nothing - , _soundPos = Nothing - } + where + sound = Sound + { _soundChunkID = sType + , _soundTime = Nothing + , _soundStatus = ToStart + , _soundFadeTime = fadeTime + , _soundChannel = Nothing + , _soundPos = Nothing + } stopSoundFrom :: SoundOrigin -> World -> World diff --git a/src/Sound.hs b/src/Sound.hs index 08dac24e7..f158043a2 100644 --- a/src/Sound.hs +++ b/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, -and sound specifications of type 'Sound' loaded into a Map to +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 - where +module Sound ( + -- * 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: -there may be a leak in the current typical usage. +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 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 new sd = playSounds $ over playingSounds (updatePlaying new) sd +playAndUpdate :: Ord a => SoundData a -> M.Map a Sound -> IO (M.Map a Sound) +playAndUpdate sData newSounds + = updateSounds (_loadedChunks sData) (mergeSounds newSounds (_playingSounds sData)) ---updateSound :: Sound -> Sound -> IO Sound ---updateSound newS oldS --- | _soundIsFadingOut oldS --- = Mix.playOn i times --- | otherwise = newS & soundChannel .~ _soundChannel oldS +mergeSounds :: Ord a => M.Map a Sound -> M.Map a Sound -> M.Map a Sound +mergeSounds as bs = M.unionWith mergeSound as bs -startPlaying :: SoundData a -> Sound -> IO (Maybe Sound) -startPlaying sd s = case _soundChannel s of - Just _ -> return $ Just s - Nothing -> playSoundIfFree (_loadedChunks sd IM.! _soundChunkID s) s +mergeSound :: Sound -> Sound -> Sound +mergeSound newS oldS + | _soundStatus oldS == FadingOut + = newS & soundChannel .~ _soundChannel oldS + | otherwise = newS & soundChannel .~ _soundChannel oldS + & soundStatus .~ _soundStatus oldS -decrimentTimer :: Sound -> IO Sound -decrimentTimer s = case _soundTime s of - Just t | t > 0 -> return $ s & soundTime ?~ t - 1 +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 >>= 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) -cleanupHalted s = case _soundChannel s of - Nothing -> return Nothing - Just i -> do - isPlaying <- Mix.playing i - if isPlaying - then return $ Just s - else return Nothing +fadeOutMaybe :: Maybe Mix.Channel -> Int -> IO () +fadeOutMaybe (Just x) fadeT = Mix.fadeOut (fromIntegral fadeT + 1) 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. +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} diff --git a/src/Sound/Preload.hs b/src/Sound/Preload.hs index a8d26799c..7ba4d541c 100644 --- a/src/Sound/Preload.hs +++ b/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