Refactor sounds

appDodge/Main.hs

@@ -61,7 +61,7 @@ doSideEffects :: World -> IO World
 doSideEffects w = do
     let preData = _preloadData w
     void $ doDrawing (_renderData preData) w
-    playPositionalSoundQueue (_loadedChunks $ _soundData preData) (_soundQueue w)
+    --playPositionalSoundQueue (_loadedChunks $ _soundData preData) (_soundQueue w)
     newPlayingSounds <- playSoundAndUpdate (_soundData preData) (_playingSounds w) (_sounds w)
     w' <- _sideEffects w w
     

src/Dodge/Base.hs

@@ -229,8 +229,8 @@ collidePointFF  = undefined
 
 -- | Looks for first collision of a circle with walls.
 -- If found, gives point and reflection velocity, reflection damped in normal.
-collideCircWalls' :: Point2 -> Point2 -> Float -> IM.IntMap Wall -> Maybe (Point2,Point2)
+collideCircWalls :: Point2 -> Point2 -> Float -> IM.IntMap Wall -> Maybe (Point2,Point2)
-collideCircWalls' p1 p2 rad ws 
+collideCircWalls p1 p2 rad ws 
     = safeMinimumOn f 
     $ IM.mapMaybe 
         (( \(x:y:_) -> fmap 

src/Dodge/Creature/Action.hs

@@ -165,7 +165,8 @@ blinkAction
     :: Creature
     -> World 
     -> World
-blinkAction cr w = soundOnce teleSound 
+blinkAction cr w 
+    = soundMultiFrom [TeleSound 0,TeleSound 1] p3 teleSound Nothing
     . over radDistortion (distortionBulge ++)
     . set (creatures . ix cid . crPos) p3
     . blinkShockwave cid p3
@@ -195,9 +196,11 @@ youDropItem :: World -> World
 youDropItem w = case yourItem w of
     NoItem -> w
     _ -> rmSelectedInvItem (_yourID w) 
-        . copyItemToFloor (you w) (_crInvSel $ you w)
+        . copyItemToFloor (you w) (_crInvSel cr)
-        $ soundOnce putDownSound 
+        $ soundFrom (CrSound (_crID cr)) (_crPos cr) putDownSound Nothing
         w
+  where
+    cr = you w
 {- | Copy an inventory item to the floor. -}
 copyItemToFloor 
     :: Creature
@@ -229,7 +232,7 @@ pickUpItem
 pickUpItem cid flit w = case maybeInvSlot of
     Nothing -> w
     Just i  -> w
-        & soundOnce pickUpSound
+        & soundFrom (CrSound cid) (_flItPos flit) pickUpSound Nothing
         & updateItLocation i
         & floorItems                      %~ IM.delete (_flItID flit)
         & creatures . ix cid . crInv . ix i %~ addItem it

src/Dodge/Creature/Impulse.hs

@@ -52,9 +52,9 @@ followImpulse cr w imp = case imp of
     ChangePosture post -> (id, cr & crStance . posture .~ post)
     UseItem -> (tryUseItem cr, cr)
     SwitchToItem i -> (id, cr & crInvSel .~ i)
-    Melee cid ->
+    Melee cid' ->
-        (hitCr cid
+        (hitCr cid'
-        , crMvBy (10 *.* normalizeV (posFromID cid -.- cpos)) $ cr & crMeleeCooldown .~ 20) -- randomise cooldown?
+        , crMvBy (10 *.* normalizeV (posFromID cid' -.- cpos)) $ cr & crMeleeCooldown .~ 20) -- randomise cooldown?
     RandomTurn a -> (id, creatureTurn (rr a) cr)
     MakeSound sid -> ( soundOnceOrigin sid (CrSound (_crID cr)) (_crPos cr) , cr )
     DropItem -> undefined
@@ -78,8 +78,9 @@ followImpulse cr w imp = case imp of
     turnRad = _mvTurnRad mvType
     cpos = _crPos cr
     cdir = _crDir cr
-    posFromID cid = _crPos $ _creatures w IM.! cid
+    cid  = _crID cr
+    posFromID cid' = _crPos $ _creatures w IM.! cid'
     rr a = fst $ randomR (-a,a) $ _randGen w
     hitCr i = over (creatures . ix i . crState . crDamage) (addDam i)
-        . soundOnce hitSound
+        . soundFrom (CrSound cid) cpos hitSound Nothing
     addDam i dams = Blunt 100 cpos (posFromID i) (posFromID i) : dams 

src/Dodge/Creature/State.hs

@@ -135,11 +135,11 @@ invSideEff cr w = weaponReloadSounds cr $ IM.foldrWithKey f w (_crInv cr)
 weaponReloadSounds :: Creature -> World -> World
 weaponReloadSounds cr w = case _crInv cr IM.!? _crInvSel cr of
     Just Weapon{_wpReloadType = PassiveReload stype,_wpReloadTime=rt,_wpReloadState=rs} 
-        | rt == rs -> soundOncePos stype (_crPos cr) w
+        | rt == rs -> soundFrom (CrReloadSound 0) (_crPos cr) stype Nothing w
         | otherwise -> w
     Just Weapon{_wpReloadState = 0} -> w
     Just Weapon{_wpReloadState = 1} -> stopSoundFrom (CrReloadSound cid) w
-    Just Weapon{} -> soundFrom (CrReloadSound cid) reloadSound 1 0 w
+    Just Weapon{} -> soundFrom (CrReloadSound cid) (_crPos cr) reloadSound (Just 1) w
     _ -> w
   where 
     cid = _crID cr
@@ -221,7 +221,7 @@ updateExpBarrel cr w
     applyFuseDamage cr' = cr' & crHP %~ 
         subtract (length . _piercedPoints . _crSpState $ _crState cr')
     hiss | null poss = id
-         | otherwise  = soundMultiFrom [BarrelHiss 0,BarrelHiss 1] 41 50 1
+         | otherwise  = soundMultiFrom [BarrelHiss 0,BarrelHiss 1] (_crPos cr) 41 (Just 1)
     stopSounds = stopSoundFrom (BarrelHiss 0) . stopSoundFrom (BarrelHiss 1)
 
 damToExpBarrel :: [DamageType] -> Creature -> Creature

src/Dodge/Creature/State/WalkCycle.hs

@@ -29,7 +29,7 @@ footstepSideEffect cr w = case cr ^? crStance . carriage of
 
 makeFootstepSound :: Int -> Int -> FootForward -> Point2 -> World -> World
 makeFootstepSound currentStride maxStride ff p
-    | currentStride > maxStride = soundMultiFromPos footor (chooseFootSound ff) 3 0 p
+    | currentStride > maxStride = soundMultiFrom footor p (chooseFootSound ff) Nothing
     | otherwise = id
   where
     footor = [FootstepSound 0,FootstepSound 1]

src/Dodge/Data.hs

@@ -39,7 +39,6 @@ import GHC.Generics
 import Control.Lens
 import System.Random
 import Data.Graph.Inductive
-import Data.Int (Int16)
 import qualified Data.Set as S
 import qualified Data.IntSet as IS
 import qualified Data.IntMap.Strict as IM
@@ -76,7 +75,6 @@ data World = World
     , _worldEvents          :: World -> World
     , _pressPlates          :: IM.IntMap PressPlate
     , _buttons              :: IM.IntMap Button
-    , _soundQueue           :: [(Int,Int16)]
     , _sounds               :: M.Map SoundOrigin Sound
     , _playingSounds        :: M.Map SoundOrigin Sound
     , _decorations          :: IM.IntMap Picture

src/Dodge/Data/SoundOrigin.hs

@@ -16,5 +16,9 @@ data SoundOrigin = InventorySound
     | CrHitSound Int
     | BarrelHiss Int
     | GlassBreakSound Int
+    | TeleSound Int
+    | LeverSound Int
+    | Explosion Int
+    | Tap Int
   deriving (Eq,Ord,Show)
 

src/Dodge/Default.hs

@@ -212,7 +212,7 @@ defaultButton = Button
     , _btEvent = \b w -> 
         set (buttons . ix (_btID b) . btPict) (onLayer WlLayer $ color red $ polygon $ rectNSEW (-4) (-5) 10 (-10))
         . set (buttons . ix (_btID b) . btState) BtNoLabel
-        . soundOnce 1 $ w
+        . soundFrom (LeverSound 0) (_btPos b) 1 Nothing $ w
     , _btID = 0
     , _btText = "Button"
     , _btState = BtOff

src/Dodge/Default/World.hs

@@ -48,7 +48,6 @@ defaultWorld = World
     , _worldEvents = id
     , _pressPlates = IM.empty
     , _buttons = IM.empty
-    , _soundQueue = []
     , _sounds = M.empty
     , _playingSounds = M.empty
     , _corpses = IM.empty

src/Dodge/Initialisation.hs

@@ -42,8 +42,8 @@ initialWorld = defaultWorld
     , _mousePos = V2 0 0
     , _testString = testStringInit
     , _yourID = 0
-    , _worldEvents = soundOncePos foamSprayFadeOutSound (V2 0 0) . foldr ((.) . makeStartCloudAt) id 
+    , _worldEvents = soundFrom BackgroundSound (V2 0 0) foamSprayFadeOutSound Nothing 
-        [V3 x y 5 | x <- [-5,-3..5] , y <- [-5,-3..5]]
+        . foldr ((.) . makeStartCloudAt) id [V3 x y 5 | x <- [-5,-3..5] , y <- [-5,-3..5]]
     , _pressPlates = IM.empty
     , _buttons = IM.empty
     , _sounds = M.empty

src/Dodge/Item/Consumable.hs

@@ -31,5 +31,8 @@ heal25 :: Int -> World -> Maybe World
 heal25 = heal 25
 heal :: Int -> Int -> World -> Maybe World
 heal hp n w | _crHP (_creatures w IM.! n) >= 10000 = Nothing
-            | otherwise = Just $ soundOnce healSound w & creatures . ix n . crHP %~ min 10000 . (+ hp)
+            | otherwise = Just $ soundFrom (CrSound $ _crID cr) (_crPos cr) healSound Nothing w
+                & creatures . ix n . crHP %~ min 10000 . (+ hp)
+  where
+    cr = _creatures w IM.! n
 

src/Dodge/Item/Weapon.hs

@@ -751,10 +751,10 @@ moveRemoteBomb itid time pID w
                 $ set (projectiles .ix pID.pjUpdate) (\_ -> moveRemoteBomb itid (f time) pID)
                     w
     | time < 2 = case hitWl of
-            Just _ -> soundOnce tapQuiet $ halfV updatedWorld
+            Just (p,_) -> soundFrom (Tap 0) p tapQuiet Nothing $ halfV updatedWorld
             _      -> halfV updatedWorld
     | otherwise = case hitWl of
-            Just _ -> soundOnce tapQuiet updatedWorld
+            Just (p,_) -> soundFrom (Tap 0) p tapQuiet Nothing updatedWorld
             _      -> updatedWorld
   where 
     updatedWorld 
@@ -768,7 +768,7 @@ moveRemoteBomb itid time pID w
     -- this is hacky, should use a version of collidePointWalls' that collides
     -- circles and walls
     invShift x = x -.- 5 *.* normalizeV (_pjVel pj)
-    hitWl  = collideCircWalls' oldPos newPos 4 $ wallsNearPoint newPos w
+    hitWl  = collideCircWalls oldPos newPos 4 $ wallsNearPoint newPos w
     finalPos = maybe newPos (invShift . fst) hitWl
     setV v = set (projectiles . ix pID . pjVel) v
     updateV = maybe id (setV . snd) hitWl
@@ -874,7 +874,7 @@ fireRemoteLauncher :: Creature -> World -> World
 fireRemoteLauncher cr w = setLocation 
     $ resetFire 
     $ resetName 
-    $ soundOnce launcherSound
+    $ soundFrom (CrWeaponSound cid) pos launcherSound Nothing
     $ over projectiles addRemRocket w
   where
     i = IM.newKey $ _projectiles w
@@ -922,7 +922,7 @@ moveRemoteShell cid itid pj w
                 ( ( pjVel %~ ( (accel +.+) . (frict *.*) ) )
                 . ( pjDir .~ newdir )
                 )
-            & soundFromPos (ShellSound i) newPos smokeTrailSound 1 250
+            & soundFrom (ShellSound i) newPos smokeTrailSound (Just 1)
             & smokeGen
             & makeFlameletTimed oldPos 20 (0.5 *.* rotateV (pi+sparkD) accel) Nothing 3 10
     | time > -200 = case thingHit of
@@ -944,7 +944,7 @@ moveRemoteShell cid itid pj w
     (frict,g)  = randomR (0.6,0.9) $ _randGen w
     (sparkD,_) = randomR (-0.5,0.5) $ _randGen w
     hitCr    = fst <$> collideCircCrsPoint oldPos newPos 4 w
-    hitWl    = fst <$> collideCircWalls' oldPos newPos 2 (wallsNearPoint newPos w)
+    hitWl    = fst <$> collideCircWalls oldPos newPos 2 (wallsNearPoint newPos w)
     thingHit = hitCr <|> hitWl
     r1 = _randGen w & evalState (randInCirc 10)
     smokeGen = makeSmokeCloudAt $ addZ 20 $ oldPos +.+ r1 +.+ 30 *.* normalizeV (oldPos -.- newPos)

src/Dodge/Item/Weapon/Grenade.hs

@@ -31,7 +31,7 @@ moveGrenade 0 _ pID w = over projectiles (IM.delete pID)
     pj = _projectiles w IM.! pID
     explosion = _pjPayload pj
 moveGrenade time dir pID w = case hitWl of
-    Just _ -> soundOnce tapQuiet updatedWorld
+    Just (p,_) -> soundFrom (Tap 0) p tapQuiet Nothing updatedWorld
     _      -> updatedWorld
   where 
     updatedWorld = updateV $ set (projectiles . ix pID . pjPos) finalPos
@@ -42,7 +42,7 @@ moveGrenade time dir pID w = case hitWl of
     pj     = _projectiles w IM.! pID
     oldPos = _pjPos pj
     newPos = _pjVel pj +.+ oldPos
-    hitWl  = collideCircWalls' oldPos newPos 4 $ wallsNearPoint newPos w
+    hitWl  = collideCircWalls oldPos newPos 4 $ wallsNearPoint newPos w
     finalPos = maybe newPos fst hitWl
     setV v = set (projectiles .ix pID.pjVel) v
     updateV = maybe id (setV . snd) hitWl

src/Dodge/Item/Weapon/Launcher.hs

@@ -106,7 +106,7 @@ doThrust :: Projectile -> World -> World
 doThrust pj w = w
     & randGen .~ g
     & projectiles . ix i . pjVel    %~ (\v -> accel +.+ frict *.* v)
-    & soundFromPos (ShellSound i) newPos smokeTrailSound 1 250
+    & soundFrom (ShellSound i) newPos smokeTrailSound (Just 1)
     & makeFlameletTimed (oldPos -.- vel) 0 (vel +.+ rotateV (pi+sparkD) accel) Nothing 3 10
     & smokeGen
   where
@@ -174,7 +174,7 @@ moveShell pj w
     projectileExplosion = _pjPayload pj
     newPos   = oldPos +.+ vel
     hitCr    = fst <$> collideCircCrsPoint oldPos newPos 4 w
-    hitWl    = fst <$> collideCircWalls' oldPos newPos 2 (wallsNearPoint newPos w)
+    hitWl    = fst <$> collideCircWalls oldPos newPos 2 (wallsNearPoint newPos w)
     thingHit = hitCr <|> hitWl
 
 reduceSpinBy :: Float -> Projectile -> World -> World

src/Dodge/Item/Weapon/TriggerType.hs

@@ -126,7 +126,7 @@ withWarmUpI soundID f item cr w
     | _wpReloadState item /= 0 = w
     | curWarmUp < maxWarmUp = w
         & pointerToItem . wpCurWarmUp +~ 2
-        & soundFrom (CrWeaponSound cid) soundID 2 0
+        & soundFrom (CrWeaponSound cid) (_crPos cr) soundID (Just 2)
     | otherwise = w
         & pointerToItem . wpCurWarmUp .~ maxWarmUp
         & f item cr
@@ -141,7 +141,11 @@ The sound is emitted from the creature's position. -}
 withSoundI
     :: Int -- ^ Sound id
     -> ChainEffect
-withSoundI soundid f item cr = soundOncePos soundid (_crPos cr) . f item cr
+withSoundI soundid f item cr 
+    = soundFrom (CrWeaponSound cid) (_crPos cr) soundid Nothing
+    . f item cr
+  where
+    cid = _crID cr
 
 {- | Adds a sound to a creature based world effect. 
 The sound is emitted from the creature's position. -}
@@ -150,7 +154,7 @@ withSoundForI
     -> Int -- ^ Frames to play
     -> ChainEffect
 withSoundForI soundid playTime f item cr 
-    = soundFromPos (CrWeaponSound (_crID cr)) (_crPos cr) soundid playTime 0
+    = soundFrom (CrWeaponSound (_crID cr)) (_crPos cr) soundid (Just playTime)
     . f item cr
 
 afterRecoil

src/Dodge/LevelGen/Block.hs

@@ -44,10 +44,10 @@ killBlock bl w =  f bl . flip (foldr unshadow) (_blShadows bl) $ w
     pos = fst $ _wlLine bl
     breakHitSound bl' 
         | _wlIsSeeThrough bl' = mkSoundBreakGlass pos
-        | otherwise = soundMultiFrom sos soundid 25 0 
+        | otherwise = soundMultiFrom sos (fst $ _wlLine bl') (soundid + 4) Nothing
     hitSound' bl' 
         | _wlIsSeeThrough bl' = mkSoundSplinterGlass pos
-        | otherwise = soundMultiFrom sos soundid 25 0 
+        | otherwise = soundMultiFrom sos (fst $ _wlLine bl') soundid Nothing
     sos = [BlockDegradeSound 0,BlockDegradeSound 1]
     (soundid,_) = randomR (29,32) $ _randGen w
     unshadow :: Int -> World -> World

src/Dodge/LevelGen/MoveDoor.hs

@@ -65,7 +65,7 @@ addSoundToDoor i pld hwd (x:ys) = f x : ys
       where
         g dm w 
             | dist wp pld > 2 && dist wp hwd > 2 
-                        = soundFrom (WallSound i) doorSound 1 0 $ dm w
+                        = soundFrom (WallSound i) wp doorSound (Just 1) $ dm w
             | otherwise = dm w
           where 
             wp = snd $ _wlLine (_walls w IM.! i)

src/Dodge/LevelGen/Switch.hs

@@ -18,11 +18,7 @@ makeButton c eff = Button
     , _btPos = V2 0 0
     , _btRot = 0
     , _btEvent = \b w -> eff . over buttons (IM.adjust turnOn (_btID b))
---                                . set (buttons . ix (_btID b) . btPict) 
+                                . soundFromGeneral (LeverSound 0) (btpos b) 1 Nothing $ w
---                                      (onLayer WlLayer $ color c $ polygon $ rectNSEW (-3) (-5) 10 (-10))
---                                . set (buttons . ix (_btID b) . btState) BtNoLabel
---                                . set (buttons . ix (_btID b) . btEvent) (\b -> return)
-                                . soundOnce 1 $ w
     , _btID = 0
     , _btText = "Button"
     --, _btText = "Button"
@@ -31,6 +27,7 @@ makeButton c eff = Button
   where
     turnOn bt = bt {_btState = BtNoLabel, _btPict = onPict, _btEvent = const id}
     onPict = setLayer 0 $ onLayer WlLayer (color c $ polygon $ rectNSEW (-3) (-5) 10 (-10))
+    btpos b w' = _btPos $ _buttons w' IM.! _btID b
 
 makeSwitch 
     :: Color 
@@ -47,7 +44,8 @@ makeSwitch c effOn effOff = Button
     , _btState = BtOff
     }
   where 
-    flipSwitch b w = switchEffect b . soundOnce 1 $ w
+    flipSwitch b w = switchEffect b . soundFromGeneral (LeverSound 0) (bpos b) 1 Nothing $ w
+    bpos b w = _btPos $ _buttons w IM.! _btID b
     switchEffect b = case _btState b of
         BtOff -> effOn  . over buttons (IM.adjust turnOn  (_btID b))
         BtOn  -> effOff . over buttons (IM.adjust turnOff (_btID b))

src/Dodge/Particle/Bullet/HitEffect.hs

@@ -35,7 +35,7 @@ bulHitCr bt p cr w
     mvDams = [ PushDam 1 $ 2 *.* bulVel ]
     addDamage = creatures . ix cid . crState . crDamage %~ ((Piercing 100 sp p ep : mvDams) ++ )
     addDamageArmoured = creatures . ix cid . crState . crDamage %~ (mvDams ++)
-    makeHitSound = soundMultiFrom [CrHitSound 0] 15 10 0
+    makeHitSound = soundMultiFrom [CrHitSound 0] p 15 (Just 10)
     flashEff = over worldEvents (bloodFlashAt p . )
     cid = _crID cr
     (d1,_)  = randomR (-0.7,0.7) $ _randGen w
@@ -53,7 +53,7 @@ bulBounceArmCr' bt p cr w
     mvDams = [ PushDam 1 $ 2 *.* bulVel ]
     addDamage = creatures . ix cid . crState . crDamage %~ ((Piercing 100 sp p ep : mvDams) ++ )
     addDamageArmoured = creatures . ix cid . crState . crDamage %~ (mvDams ++)
-    makeHitSound = soundMultiFrom [CrHitSound 0] 15 10 0
+    makeHitSound = soundMultiFrom [CrHitSound 0] p 15 (Just 10)
     flashEff = over worldEvents ((.) $ bloodFlashAt p)
     cid = _crID cr
     newDir = safeNormalizeV (p -.- _crPos cr)
@@ -74,7 +74,7 @@ bulPenCr' bt p cr w
             ] 
             ++
            )
-    $ soundMultiFrom [CrHitSound 0] 15 10 0
+    $ soundMultiFrom [CrHitSound 0] ep 15 (Just 10)
     $ over worldEvents (addPiercer . )
     w
   where 
@@ -98,7 +98,7 @@ hvBulHitCr bt p cr w
             ] 
             ++
            )
-    $ soundMultiFrom [CrHitSound 0] 15 10 0
+    $ soundMultiFrom [CrHitSound 0] ep 15 (Just 10)
     w
   where 
     (d1,_)  = randomR (-0.7,0.7) $ _randGen w
@@ -110,7 +110,7 @@ bulIncCr' :: Particle -> Point2 -> Creature -> World -> World
 bulIncCr' bt p cr w 
     = over (creatures . ix cid . crState . crDamage)
            ( Piercing 60 sp p ep : )
-    $ soundMultiFrom [CrHitSound 0] 15 10 0
+    . soundMultiFrom [CrHitSound 0] p 15 (Just 10)
     $ incFlamelets
     w
   where   
@@ -124,7 +124,7 @@ bulConCr' :: Particle -> Point2 -> Creature -> World -> World
 bulConCr' bt p cr w 
     = over (creatures . ix cid . crState . crDamage)
            ( Piercing 60 sp p ep : )
-    $ soundMultiFrom [CrHitSound 0] 15 10 0
+    . soundMultiFrom [CrHitSound 0] p 15 (Just 10)
     $ mkwave
     w
   where   

src/Dodge/SoundLogic.hs

@@ -6,13 +6,10 @@ This module allows us to talk to the "Sound" module.
 -}
 module Dodge.SoundLogic (
     -- * Manipulation of individual sounds
-      soundOnce
+      soundOnceOrigin
-    , soundOncePos
-    , soundOnceOrigin
-    , soundFromPos
     , soundFrom
+    , soundFromGeneral
     , soundMultiFrom
-    , soundMultiFromPos
     , stopSoundFrom
 
     -- * Manipulation of all sounds
@@ -41,20 +38,6 @@ pauseSound w = w
 resumeSound :: World -> World
 resumeSound w = w
 
-{-| Add a sound to the queue for playback.
-Consider replacing instances with 'soundOncePos'.
- -}
-soundOnce :: Int -> World -> World
-soundOnce i = soundQueue %~  ((i,0) : )
-
-{-| Play a sound with a given position in the world.
-Uses the angle between the given position and '_cameraViewFrom', taking into account '_cameraRot'.
- -}
-soundOncePos :: Int -> Point2 -> World -> World
-soundOncePos i pos w = w & soundQueue %~ ((i,a) :)
-  where
-    a = soundAngle pos w
-
 {-| Play a sound once, with a given origin.
 For each origin only one sound will play at a time.
 -}
@@ -69,7 +52,6 @@ soundOnceOrigin sType so p w = w & sounds %~ M.insertWith (\ _ x -> x) so theSou
     theSound = Sound 
         { _soundChunkID     = sType
         , _soundTime        = Nothing
-        , _soundFadeTime    = 0
         , _soundStatus      = ToStart
         , _soundChannel     = Nothing
         , _soundAngDist     = Just (a,0)
@@ -78,28 +60,48 @@ soundOnceOrigin sType so p w = w & sounds %~ M.insertWith (\ _ x -> x) so theSou
         }
     a = soundAngle p w
 
-soundFromPos 
+soundFrom 
     :: SoundOrigin  -- ^ \"Creator\" of sound
     -> Point2       -- ^ Position of sound
     -> Int          -- ^ ID of sound to be played
-    -> Int          -- ^ Frames to play sound for
+    -> Maybe Int    -- ^ Frames to play sound for, Nothing for until finished
-    -> Int          -- ^ Time sound fades out after playing for the given number of frames (ms)
+    -> World 
-    -> World -> World
+    -> World
-soundFromPos so pos sType time fadeTime w = over sounds (M.insertWith f so sound) w
+soundFrom so pos sType mtime w = over sounds (M.insertWith f so sound) w
   where 
     sound = Sound 
         { _soundChunkID     = sType
-        , _soundTime        = Just time
+        , _soundTime        = mtime
         , _soundStatus      = ToStart
-        , _soundFadeTime    = fadeTime
         , _soundChannel     = Nothing
         , _soundAngDist     = Just (a,0)
         , _soundPos         = pos
         , _soundVolume      = soundVolID sType
         }
-    f _ s = s {_soundTime = Just time, _soundFadeTime = fadeTime}
+    f _ s = s {_soundTime = mtime }
     a = soundAngle pos w
 
+soundFromGeneral
+    :: SoundOrigin  -- ^ \"Creator\" of sound
+    -> (World -> Point2)       -- ^ Position of sound
+    -> Int          -- ^ ID of sound to be played
+    -> Maybe Int    -- ^ Frames to play sound for, Nothing for until finished
+    -> World 
+    -> World
+soundFromGeneral so fpos sType mtime w = over sounds (M.insertWith f so sound) w
+  where 
+    sound = Sound 
+        { _soundChunkID     = sType
+        , _soundTime        = mtime
+        , _soundStatus      = ToStart
+        , _soundChannel     = Nothing
+        , _soundAngDist     = Just (a,0)
+        , _soundPos         = fpos w
+        , _soundVolume      = soundVolID sType
+        }
+    f _ s = s {_soundTime = mtime }
+    a = soundAngle (fpos w) w
+
 {-| Calculates the angle of a sound with reference to '_cameraViewFrom'.
 Within 10 units considers the sound to be directly in front.
 -}
@@ -115,71 +117,24 @@ soundAngle p w
   where
     earPos = _cameraViewFrom w
 
-soundFrom 
-    :: SoundOrigin 
-    -> Int -- ^ Sound ID
-    -> Int -- ^ Frames to play
-    -> Int -- ^ Fade out time (ms)
-    -> World 
-    -> World
-soundFrom so sType time fadeTime w = w & sounds %~ M.insertWith f so sound
-  where 
-    sound = Sound 
-        { _soundChunkID     = sType
-        , _soundTime        = Just time
-        , _soundStatus      = ToStart
-        , _soundFadeTime    = fadeTime
-        , _soundChannel     = Nothing
-        , _soundAngDist     = Nothing
-        , _soundPos         = _cameraCenter w
-        , _soundVolume      = soundVolID sType
-        }
-    f _ s = s {_soundTime = Just time, _soundFadeTime = fadeTime} 
-{-| Uses the first free origin from a list.
-Does nothing if all origins are already creating sounds.
-TODO: add positional information.
--}
-soundMultiFrom 
-    :: [SoundOrigin] 
-    -> Int -- ^ Sound ID
-    -> Int -- ^ Frames to play for
-    -> Int -- ^ Fade out time (ms)
-    -> World -> World
-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
-        , _soundStatus      = ToStart
-        , _soundFadeTime    = fadeTime
-        , _soundChannel     = Nothing
-        , _soundAngDist     = Nothing
-        , _soundPos         = _cameraCenter w
-        , _soundVolume      = soundVolID sType
-        }
 {-| Uses the first free origin from a list.
 Does nothing if all origins are already creating sounds.  -}
-soundMultiFromPos
+soundMultiFrom
     :: [SoundOrigin] 
-    -> Int -- ^ Sound ID
-    -> Int -- ^ Frames to play for
-    -> Int -- ^ Fade out time (ms)
     -> Point2 -- ^ Position
+    -> Int -- ^ Sound ID
+    -> Maybe Int -- ^ Frames to play for, Nothing for full length
     -> World 
     -> World
-soundMultiFromPos [] _ _ _ _ w = w
+soundMultiFrom [] _ _ _ w = w
-soundMultiFromPos (so:sos) sType time fadeTime pos w
+soundMultiFrom (so:sos) pos sType mtime w
-    | so `M.member` _sounds w = soundMultiFromPos sos sType time fadeTime pos w
+    | so `M.member` _sounds w = soundMultiFrom sos pos sType mtime w
     | otherwise = over sounds (M.insert so sound) w
   where 
     sound = Sound 
         { _soundChunkID     = sType
-        , _soundTime        = Nothing
+        , _soundTime        = mtime
         , _soundStatus      = ToStart
-        , _soundFadeTime    = fadeTime
         , _soundChannel     = Nothing
         , _soundAngDist     = Just (a,0)
         , _soundPos         = pos

src/Dodge/Update.hs

@@ -117,7 +117,7 @@ updateTriggers w
     cr = _creatures w IM.! 0 & crPos .~ V2 0 0
 
 updateSoundQueue :: World -> World
-updateSoundQueue = set soundQueue [] . set sounds M.empty
+updateSoundQueue = set sounds M.empty
 
 updateLightSources :: World -> World
 updateLightSources w = set tempLightSources (catMaybes tlss) w'
@@ -195,7 +195,7 @@ updateCloud w c
     oldPos2 = stripZ oldPos
     newPos@(V3 _ _ npz) = oldPos +.+.+ newVel
     newPos2 = stripZ newPos
-    hitWl = collideCircWalls' oldPos2 newPos2 5 $ wallsNearPoint newPos2 w
+    hitWl = collideCircWalls oldPos2 newPos2 5 $ wallsNearPoint newPos2 w
     finalPos = addZ npz $ maybe newPos2 fst hitWl
     finalVel = addZ nvz $ maybe newVel2 snd hitWl
 

src/Dodge/WorldEvent/Explosion.hs

@@ -28,7 +28,9 @@ makePoisonExplosionAt
     :: Point2   -- ^ Position
     -> World 
     -> World
-makePoisonExplosionAt p w = soundOncePos grenadeBang p $ foldr (makeGasCloud p) w vels
+makePoisonExplosionAt p w 
+    = soundMultiFrom [Explosion 0,Explosion 1] p grenadeBang Nothing
+    $ foldr (makeGasCloud p) w vels
   where 
     vels = replicateM 25 (randInCirc 2) & evalState $ _randGen w
 -- just change the number after replicateM to get more or less clouds
@@ -54,7 +56,9 @@ makeFlameExplosionAt
     :: Point2   -- ^ Position
     -> World 
     -> World
-makeFlameExplosionAt p w = soundOncePos grenadeBang p $ over particles (newFlames ++ ) w
+makeFlameExplosionAt p w 
+    = soundMultiFrom [Explosion 0,Explosion 1] p grenadeBang Nothing
+    $ over particles (newFlames ++ ) w
   where 
     newFlames = zipWith makeFlameWithVelAndTime velocities timers
     makeFlameWithVelAndTime vel time = aFlameParticle time p vel Nothing
@@ -68,7 +72,7 @@ makeExplosionAt
     -> World 
     -> World
 makeExplosionAt p w 
-    = soundOncePos grenadeBang p
+    = soundMultiFrom [Explosion 0,Explosion 1] p grenadeBang Nothing
     . addFlames 
     -- . explosionFlashAt p
     . over tempLightSources (theTLS :)

src/Dodge/WorldEvent/SpawnParticle.hs

@@ -97,7 +97,7 @@ moveFlame rotd w pt
         _                     -> (glare $ doSound damcrs        , mvPt)
   where 
     time = _btTimer' pt
-    doSound = soundFrom Flame fireSound 2 500 -- . over worldEvents ((.) $ flameGlareAt ep)
+    doSound = soundFrom Flame (V2 x y) fireSound (Just 2) -- . over worldEvents ((.) $ flameGlareAt ep)
     glare 
         | time `mod` 5 == 0
                     = tempLightSources %~ (theTLS :)

src/Sound.hs

@@ -55,7 +55,7 @@ playSoundAndUpdate sData oldSounds newSounds
 
 mergeSound :: Sound -> Sound -> Sound
 mergeSound oldS newS
-    | _soundChunkID newS == _soundChunkID oldS && _soundStatus oldS /= FadingOut
+    | _soundChunkID newS == _soundChunkID oldS
                 = newS & soundChannel .~ _soundChannel oldS
                        & soundStatus  .~ _soundStatus oldS
     | otherwise = newS & soundChannel .~ _soundChannel oldS
@@ -87,25 +87,18 @@ tryPlay sd s = do
         & soundChannel  ?~ i
         & soundStatus   .~ JustStartedPlaying
 
---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)
+        | otherwise -> do 
-                            >> return (s & soundTime .~ Nothing
+            forM_ (_soundChannel s) Mix.halt
-                                         & soundStatus .~ FadingOut)
+            return $ s & soundTime .~ Nothing
     Nothing -> return s
 
 applyPosition :: Sound -> IO Sound
@@ -114,14 +107,6 @@ applyPosition s = case _soundAngDist s of
     Just (a,d)  -> Mix.effectPosition (fromJust $ _soundChannel s) a d
                     >> return (s & soundAngDist .~ 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
@@ -137,10 +122,10 @@ 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
@@ -171,4 +156,3 @@ Behind the scenes, scales a float [0,1] to an Int [0..128].
  -}
 setMusicVolume :: Float -> IO ()
 setMusicVolume x = Mix.setMusicVolume (round (x * 128))
-

src/Sound/Data.hs

@@ -12,7 +12,6 @@ import Data.Int (Int16)
 data SoundStatus 
     = JustStartedPlaying
     | Playing
-    | FadingOut
     | ToStart
   deriving (Eq,Ord,Show)
 
@@ -21,7 +20,6 @@ newtype SoundData = SoundData
     }
 data Sound = Sound 
     { _soundTime        :: Maybe Int
-    , _soundFadeTime    :: Int
     , _soundStatus      :: SoundStatus
     , _soundChannel     :: Maybe Mix.Channel
     , _soundAngDist     :: Maybe (Int16,Word8)