Refactor sound
This commit is contained in:
+3
-3
@@ -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)
|
||||
|
||||
+123
-65
@@ -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)
|
||||
|
||||
|
||||
+23
-18
@@ -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
|
||||
|
||||
+94
-94
@@ -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}
|
||||
|
||||
|
||||
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user