Merge branch 'master' of ssh://git.xkjq.uk:30001/justin/loop

app/Main.hs

@@ -19,30 +19,37 @@ import Picture.Render
 import Picture.Preload
 import Sound
 import Preload
-import Sound.Preload
+import Sound.Data
+import Music
 
 import           Control.Concurrent
 import           Control.Lens
 import           Foreign                   (Word32)
 
 import Control.Monad (when,void)
- 
-import System.Random
-
-import           System.Random
 
 import qualified Data.Map                  as M
 import           Graphics.Rendering.OpenGL hiding (color, rotate, scale,
                                             translate)
+import qualified Data.Map as M
+import qualified Data.IntMap as IM
 import qualified SDL
 import qualified SDL.Mixer                 as Mix
 
 doPreload' :: IO (PreloadData a)
 doPreload' = do
     lChunks <- loadSounds
+    lMusic  <- loadMusic
     let sData = SoundData {_loadedChunks = lChunks, _playingSounds = M.empty}
+        mData = MusicData {_loadedMusic = lMusic}
+    Mix.playMusic Mix.Forever (lMusic IM.! 0)
     rData <- preloadRender
-    return $ PreloadData rData sData 0
+    return $ PreloadData 
+        { _renderData   = rData 
+        , _soundData    = sData 
+        , _musicData    = mData
+        , _frameTimer   = 0
+        }
 
 main :: IO ()
 main = do
@@ -56,7 +63,7 @@ main = do
         ( \preData w -> do
             startTicks <- SDL.ticks
             void $ doDrawing (_renderData preData) w
-            playSoundQueue (_loadedChunks $ _soundData preData) (_soundQueue w)
+            playPositionalSoundQueue (_loadedChunks $ _soundData preData) (_soundQueue w)
             newPlayingSounds <- playAndUpdate (_soundData preData) (_sounds w)
 
             endTicks <- SDL.ticks

src/Dodge/Creature/Inanimate.hs

@@ -35,8 +35,11 @@ updateLamp :: Int -> CRUpdate
 updateLamp i = unrandUpdate handleLS internalUpdate
   where
     handleLS cr w 
-        | _crHP cr < 0 = explosionFlashAt (_crPos cr) $ mkSoundBreakGlass w & lightSources %~ IM.delete i
+        | _crHP cr < 0 = explosionFlashAt cPos 
-        | otherwise    = w & lightSources . ix i . lsPos .~ _crPos cr
+                        $ mkSoundBreakGlass cPos w & lightSources %~ IM.delete i
+        | otherwise    = w & lightSources . ix i . lsPos .~ cPos
+      where
+        cPos = _crPos cr
     internalUpdate cr 
         | _crHP cr < 0 = Nothing
         | otherwise    = Just $ doDamage cr

src/Dodge/Data.hs

@@ -10,7 +10,7 @@ module Dodge.Data
   where
 import Picture.Data
 import Geometry.Data
-import Sound.Preload
+import Sound.Data
 import Control.Lens
 import Control.Monad.State
 import System.Random
@@ -25,6 +25,8 @@ import Codec.Picture (Image,PixelRGBA8)
 import qualified Data.DList as DL
 import Dodge.LoadConfig
 
+import Data.Int (Int16)
+
 data World = World 
     { _keys                 :: !(S.Set Scancode)
     , _mouseButtons         :: !(S.Set MouseButton)
@@ -50,7 +52,7 @@ data World = World
     , _worldEvents          :: !(World -> World)
     , _pressPlates          :: IM.IntMap PressPlate
     , _buttons              :: IM.IntMap Button
-    , _soundQueue           :: [Int]
+    , _soundQueue           :: [(Int,Int16)]
     , _sounds               :: M.Map SoundOrigin Sound
     , _decorations          :: IM.IntMap Picture
     , _corpses              :: IM.IntMap (IM.IntMap [Corpse])

src/Dodge/Item/Weapon.hs

@@ -810,7 +810,7 @@ moveShell time i cid rot accel w
                    $ set (projectiles . ix i . pjUpdate) 
                              (moveShell (time-1) i cid rot (rotateV rot accel))
                    $ over (projectiles . ix i . pjVel) (\v -> accel +.+ frict *.* v)
-                   $ soundFrom (ShellSound i) (fromIntegral smokeTrailSound) (1) 250
+                   $ soundFromPos (ShellSound i) newPos (fromIntegral smokeTrailSound) (1) 250
                    $ makeFlameletTimed oldPos 
                          (0.5 *.* rotateV (pi+sparkD) accel) Nothing 3 10
                    $ smokeGen
@@ -879,8 +879,7 @@ tractorBeamAt colID i pos dir = Projectile
 
 aGasCloud :: Int -> World -> World
 aGasCloud cid w
-    = -- soundFrom Flame fireSound 2 500 
+    = insertCloud $ set randGen g $
-          insertCloud $ set randGen g $
             w
         where 
             (a,g) = randomR (-0.1,0.1) (_randGen w)
@@ -896,7 +895,6 @@ aGasCloud cid w
 aFlame :: Float -> Int -> World -> World
 aFlame a cid w
     = shakeCr cid 2
---          $ soundFrom Flame fireSound 2 500 
           $ insertFlame $ resetAngle $ set randGen g $
             w
         where 
@@ -1381,7 +1379,7 @@ moveRemoteShell time i cid itid dir w
                                   $ set (projectiles . ix i . pjUpdate) 
                                             (moveRemoteShell (time-1) i cid itid newdir)
                                   $ over (projectiles . ix i . pjVel) (\v -> accel +.+ frict *.* v)
-                                  $ soundFrom (ShellSound i) (fromIntegral smokeTrailSound) (1) 250
+                                  $ soundFromPos (ShellSound i) newPos (fromIntegral smokeTrailSound) (1) 250
                                   $ smokeGen
                                   $ makeFlameletTimed oldPos 
                                         (0.5 *.* rotateV (pi+sparkD) accel) Nothing 3 10

src/Dodge/Item/Weapon/TriggerType.hs

@@ -43,9 +43,9 @@ withWarmUp t f cid w
             | fState == 0 = set (pointerToItem . wpFire) (withWarmUp 100 f) 
                                             $ set (pointerToItem . wpFireState) 2 
                                                 w
-            | t > 1  = set (pointerToItem . wpFire) (withWarmUp (t-1) f)
+            | t > 2  = set (pointerToItem . wpFire) (withWarmUp (t-1) f)
                                             $ set (pointerToItem . wpFireState) 2
-                                            $ soundFrom (CrWeaponSound cid) 26 1 0
+                                            $ soundFrom (CrWeaponSound cid) 26 2 0
                                                 w 
             | t > 0  = set (pointerToItem . wpFire) (withWarmUp (t-1) f)
                                             $ set (pointerToItem . wpFireState) 2
@@ -56,16 +56,19 @@ withWarmUp t f cid w
                                             $ f cid
                                             $ soundFrom (CrWeaponSound cid) 28 2 0
                                                 w
-    where cr = _creatures w IM.! cid
+  where 
-          itRef = _crInvSel cr
+    cr = _creatures w IM.! cid
-          item = _crInv cr IM.! itRef
+    itRef = _crInvSel cr
-          pointerToItem = creatures . ix cid . crInv . ix itRef
+    item = _crInv cr IM.! itRef
-          fState = _wpFireState item
+    pointerToItem = creatures . ix cid . crInv . ix itRef
-          fRate = _wpFireRate item
+    fState = _wpFireState item
-          reloadCondition = _wpLoadedAmmo item == 0
+    fRate = _wpFireRate item
+    reloadCondition = _wpLoadedAmmo item == 0
 
 withSound :: Int -> (Int -> World -> World) -> Int -> World -> World
-withSound soundid f cid = soundOnce soundid . f cid
+withSound soundid f cid w = (soundOncePos soundid p . f cid) w
+  where
+    p = _crPos (_creatures w IM.! cid)
 
 withRecoil :: Float -> (Int -> World -> World) -> Int -> World -> World
 withRecoil recoilAmount eff cid w = eff cid . over (creatures . ix cid) pushback $ w

src/Dodge/LevelGen/Block.hs

@@ -42,11 +42,10 @@ killBlock bl w =  f bl .
     where
         f bl@(Block {_blDegrades = (x:xs)}) = degradeBlock bl . hitSound bl
         f bl          = hitSound' bl
-        hitSound bl | _wlIsSeeThrough bl = mkSoundBreakGlass
+        pos = _wlLine bl !! 0
---        hitSound bl | _wlIsSeeThrough bl = soundMultiFrom sos (soundid+8) 25 0 
+        hitSound bl | _wlIsSeeThrough bl = mkSoundBreakGlass pos
                     | otherwise = soundMultiFrom sos soundid 25 0 
-        hitSound' bl | _wlIsSeeThrough bl = mkSoundSplinterGlass
+        hitSound' bl | _wlIsSeeThrough bl = mkSoundSplinterGlass pos
---        hitSound' bl | _wlIsSeeThrough bl = soundMultiFrom sos (soundid+4) 25 0 
                      | otherwise = soundMultiFrom sos soundid 25 0 
         sos = [BlockDegradeSound 0,BlockDegradeSound 1]
         (soundid,_) = randomR (29,32) $ _randGen w

src/Dodge/LoadSound.hs

@@ -14,15 +14,15 @@ import qualified SDL.Mixer as Mix
 -- }}}
 loadSounds :: IO (IM.IntMap Mix.Chunk)
 loadSounds = do
-    Mix.openAudio Mix.defaultAudio 256
+    Mix.openAudio Mix.defaultAudio 128
     pFireSound      <- Mix.load "./data/sound/tap3.wav"
     click           <- Mix.load "./data/sound/click1.wav"
     reloadSound'    <- Mix.load "./data/sound/reload1.wav"
     tone440         <- Mix.load "./data/sound/tone440.wav"
     pickupSound'    <- Mix.load "./data/sound/pickUp.wav"
-    putdownSound' <- Mix.load "./data/sound/whiteNoiseFadeOut.wav"
+    putdownSound'   <- Mix.load "./data/sound/whiteNoiseFadeOut.wav"
-    fireSound' <- Mix.load "./data/sound/fire1.wav"
+    fireSound'      <- Mix.load "./data/sound/fire1.wav"
-    grenadeBang' <- Mix.load "./data/sound/grenade.wav"
+    grenadeBang'    <- Mix.load "./data/sound/grenade.wav"
     tapQuiet' <- Mix.load "./data/sound/tapQuiet.wav"
     twoStep' <- Mix.load "./data/sound/twoStep.wav"
     healSound' <- Mix.load "./data/sound/heal.wav"
@@ -57,52 +57,54 @@ loadSounds = do
     glass3' <- Mix.load "./data/sound/Small-Piece-Of-Glass-Shattering-A3.wav" 
     glass4' <- Mix.load "./data/sound/Small-Piece-Of-Glass-Shattering-A4.wav" 
     foamSpray' <- Mix.load "./data/sound/foamSprayLoop.wav" 
-    return $ IM.fromList $ zip [0..] 
+    return $ IM.fromList $ zip [0..] $ 
-                         $ [ pFireSound
+        [ pFireSound
-                           , click
+        , click
-                           , reloadSound'
+        , reloadSound'
-                           , tone440
+        , tone440
-                           , pickupSound'
+        , pickupSound'
-                           , putdownSound'
+        , putdownSound'
-                           , fireSound'
+        , fireSound'
-                           , grenadeBang'
+        , grenadeBang'
-                           , tapQuiet'
+        , tapQuiet'
-                           , twoStep'
+        , twoStep'
-                           , healSound'
+        , healSound'
-                           , doorSound'
+        , doorSound'
-                           , twoStepSlow'
+        , twoStepSlow'
-                           , knifeSound'
+        , knifeSound'
-                           , buzzSound'
+        , buzzSound'
-                           , hitSound'      --15
+        , hitSound'      --15
-                           , autoGunSound'
+        , autoGunSound'
-                           , shotgunSound'
+        , shotgunSound'
-                           , teleSound'
+        , teleSound'
-                           , longGunSound'
+        , longGunSound'
-                           , launcherSound'
+        , launcherSound'
-                           , smokeTrailSound'
+        , smokeTrailSound'
-                           , foot1Sound'
+        , foot1Sound'
-                           , foot2Sound'
+        , foot2Sound'
-                           , lasSound'
+        , lasSound'
-                           , teslaSound'  --25
+        , teslaSound'  --25
-                           , crankSlow'  
+        , crankSlow'  
-                           , autoB'
+        , autoB'
-                           , mini'
+        , mini'
-                           , impactA'
+        , impactA'
-                           , impactB'  --30
+        , impactB'  --30
-                           , impactC'
+        , impactC'
-                           , impactD'
+        , impactD'
-                           , glassShat1' --33
+        , glassShat1' --33
-                           , glassShat2'
+        , glassShat2'
-                           , glassShat3'
+        , glassShat3'
-                           , glassShat4'
+        , glassShat4'
-                           , glass1'    --37
+        , glass1'    --37
-                           , glass2'
+        , glass2'
-                           , glass3'
+        , glass3'
-                           , glass4'    --40
+        , glass4'    --40
-                           , foamSpray'
+        , foamSpray'
-                           ]
+        ]
-
-
-soundOnce :: Int -> World -> World
-soundOnce i = over soundQueue ((:) i)
 
+loadMusic :: IO (IM.IntMap Mix.Music)
+loadMusic = do
+    undercity <- Mix.load "./data/music/undercity.mid"
+    return $ IM.fromList $ zip [0..] $
+        [ undercity
+        ]

src/Dodge/SoundLogic.hs

@@ -1,35 +1,144 @@
-module Dodge.SoundLogic where
+{-|
+Module      : Dodge.SoundLogic
+Description : Messages to "Sound" backend
+
+This module allows us to talk to the "Sound" module.
+-}
+module Dodge.SoundLogic (
+    -- * Manipulation of individual sounds
+      soundOnce
+    , soundOncePos
+    , soundOnceOrigin
+    , soundFromPos
+    , soundFrom
+    , soundMultiFrom
+    , stopSoundFrom
+
+    -- * Manipulation of all sounds
+    , haltSound
+    , resumeSound
+    , pauseSound
+
+    -- * Synonyms for sound identifiers
+    , clickSound 
+    , reloadSound 
+    , pickUpSound  
+    , putDownSound 
+    , fireSound    
+    , grenadeBang 
+    , tapQuiet 
+    , twoStepSound 
+    , healSound 
+    , doorSound 
+    , twoStepSlowSound 
+    , knifeSound 
+    , buzzSound 
+    , hitSound 
+    , autoGunSound 
+    , shotgunSound 
+    , teleSound 
+    , longGunSound 
+    , launcherSound 
+    , smokeTrailSound 
+    , foot1Sound 
+    , foot2Sound 
+    ) where
 import Dodge.Data
-import Sound.Preload (SoundStatus (..))
+import Sound.Data (SoundStatus (..))
+import Geometry.Vector
+import Geometry (dist)
 
 import Control.Lens
 import qualified Data.Map as M
+import Data.Int (Int16)
 
+{-| Placeholder...-}
 haltSound :: World -> World
 haltSound w = w
 
+{-| Placeholder...-}
 pauseSound :: World -> World
 pauseSound w = w
 
+{-| Placeholder...-}
 resumeSound :: World -> World
 resumeSound w = w
 
+{-| Add a sound to the queue for playback.
+Consider replacing with 'soundOncePos'.
+ -}
 soundOnce :: Int -> World -> World
-soundOnce i = over soundQueue ((:) i)
+soundOnce i = over soundQueue ((:) (i,0))
 
-soundOnceOrigin :: Int -> SoundOrigin -> World -> World
+{-| Play a sound with a given position in the world.
-soundOnceOrigin sType so = over sounds (M.insertWith (flip const) so sound)
+Uses the angle between the given position and '_cameraViewFrom', taking into account '_cameraRot'.
+ -}
+soundOncePos :: Int -> Point2 -> World -> World
+soundOncePos i pos w = over soundQueue ((:) (i,a)) w
+  where
+    a = soundAngle pos w
+
+{-| Play a sound once, with a given origin.
+For each origin only one sound will play at a time.
+-}
+soundOnceOrigin 
+    :: Int          -- ^ ID of the sound to be played
+    -> SoundOrigin  -- ^ The \"creator\" of the sound
+    -> Point2       -- ^ The position of the sound in the world
+    -> World -> World
+soundOnceOrigin sType so p w = over sounds (M.insertWith (flip const) so theSound) w
   where 
-    sound = Sound 
+    theSound = Sound 
         { _soundChunkID     = sType
         , _soundTime        = Nothing
         , _soundFadeTime    = 0
         , _soundStatus      = ToStart
         , _soundChannel     = Nothing
-        , _soundPos         = Nothing
+        , _soundPos         = Just (a,0)
         }
+    a = soundAngle p w
 
-soundFrom :: SoundOrigin -> Int -> Int -> Int -> World -> World
+soundFromPos 
+    :: SoundOrigin  -- ^ \"Creator\" of sound
+    -> Point2       -- ^ Position of sound
+    -> Int          -- ^ ID of sound to be played
+    -> Int          -- ^ Frames to play sound for
+    -> Int          -- ^ Time sound fades out after playing for the given number of frames (ms)
+    -> World -> World
+soundFromPos so pos sType time fadeTime w = over sounds (M.insertWith f so sound) w
+  where 
+    sound = Sound 
+        { _soundChunkID     = sType
+        , _soundTime        = Just time
+        , _soundStatus      = ToStart
+        , _soundFadeTime    = fadeTime
+        , _soundChannel     = Nothing
+        , _soundPos         = Just (a,0)
+        }
+    f _ s = s {_soundTime = Just time, _soundFadeTime = fadeTime}
+    a = soundAngle pos w
+
+{-| Calculates the angle of a sound with reference to '_cameraViewFrom'.
+Within 10 units considers the sound to be directly in front.
+-}
+soundAngle :: Point2 -> World -> Int16
+{-# INLINE soundAngle #-}
+soundAngle p w
+    | dist p earPos < 10 = 0
+    | otherwise = round 
+      . radToDeg 
+      . normalizeAngle 
+      . (+ pi)
+      $ argV (vNormal (p -.- earPos)) - _cameraRot 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 = over sounds (M.insertWith f so sound) w
   where 
     sound = Sound 
@@ -42,7 +151,16 @@ soundFrom so sType time fadeTime w = over sounds (M.insertWith f so sound) w
         }
     f _ s = s {_soundTime = Just time, _soundFadeTime = fadeTime}
 
-soundMultiFrom :: [SoundOrigin] -> Int -> Int -> Int -> World -> World
+{-| 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
@@ -57,7 +175,8 @@ soundMultiFrom (so:sos) sType time fadeTime w
         , _soundPos         = Nothing
         }
 
-
+{- | Sets '_soundTime' to 0.
+ -}
 stopSoundFrom :: SoundOrigin -> World -> World
 stopSoundFrom so = over (sounds . ix so . soundTime) (fmap $ min 0)
 

src/Dodge/WorldEvent/Explosion.hs

@@ -20,7 +20,7 @@ import Control.Lens
 
 -- The following should be improved.... I've made a first pass
 makePoisonExplosionAt :: Point2 -> World -> World
-makePoisonExplosionAt p w = soundOnce grenadeBang $ foldr (makeGasCloud p) w vels
+makePoisonExplosionAt p w = soundOncePos grenadeBang p $ foldr (makeGasCloud p) w vels
   where 
     vels = evalState (sequence ( replicate 25 (randInCirc 2) )) (_randGen w)
 -- just change the number after replicate to get more or less clouds
@@ -29,12 +29,12 @@ makePoisonExplosionAt p w = soundOnce grenadeBang $ foldr (makeGasCloud p) w vel
 -- currently the clouds push away from each other rather hard if they are close
 
 makeTeslaExplosionAt :: Point2 -> World -> World
-makeTeslaExplosionAt pos w = soundOnce grenadeBang $ foldr ($) w listOfFunctions -- a bit shorter
+makeTeslaExplosionAt pos w = soundOncePos grenadeBang pos $ foldr ($) w listOfFunctions -- a bit shorter
   where 
     -- rad or 360? Radians (hopefully) everywhere
     xs = randomRs (0, 2*pi) $ _randGen w
-    p = newProjectileKey w
+    j = newProjectileKey w
-    pks = [p..]
+    pks = [j..]
     listOfFunctions = map 
             (\i -> over projectiles (IM.insert (pks!!i) (makeTeslaArcAt (pks!!i) pos (xs!!i)))) 
             [1 .. 29]
@@ -43,7 +43,7 @@ makeTeslaExplosionAt pos w = soundOnce grenadeBang $ foldr ($) w listOfFunctions
 -- times
 -- the new flames are directly added to the list of particles
 makeFlameExplosionAt :: Point2 -> World -> World
-makeFlameExplosionAt p w = soundOnce grenadeBang $ over particles' (newFlames ++ ) w
+makeFlameExplosionAt p w = soundOncePos grenadeBang p $ over particles' (newFlames ++ ) w
   where 
     newFlames = zipWith makeFlameWithVelAndTime velocities timers
     makeFlameWithVelAndTime vel time = aFlameParticle time p vel Nothing
@@ -54,7 +54,7 @@ makeFlameExplosionAt p w = soundOnce grenadeBang $ over particles' (newFlames ++
 
 
 makeExplosionAt :: Point2 -> World -> World
-makeExplosionAt p w = soundOnce grenadeBang 
+makeExplosionAt p w = soundOncePos grenadeBang p
     . addFlames 
     . explosionFlashAt p
     $ makeShockwaveAt [] p 50 10 1 white

src/Dodge/WorldEvent/Sound.hs

@@ -1,18 +1,19 @@
 module Dodge.WorldEvent.Sound
   where
 import Dodge.Data
+import Geometry.Data (Point2)
 
 import Dodge.SoundLogic
 import System.Random
 
 import Control.Lens
 
-mkSoundBreakGlass :: World -> World
+mkSoundBreakGlass :: Point2 -> World -> World
-mkSoundBreakGlass w = soundOnceOrigin soundid (GlassBreakSound 0) $ set randGen g w
+mkSoundBreakGlass p w = soundOnceOrigin soundid (GlassBreakSound 0) p $ set randGen g w
   where
     (soundid,g) = _randGen w & randomR (37,40)
 
-mkSoundSplinterGlass :: World -> World
+mkSoundSplinterGlass :: Point2 -> World -> World
-mkSoundSplinterGlass w = soundOnceOrigin soundid (GlassBreakSound 1) $ set randGen g w
+mkSoundSplinterGlass p w = soundOnceOrigin soundid (GlassBreakSound 1) p $ set randGen g w
   where
     (soundid,g) = _randGen w & randomR (33,36)

src/Music.hs

@@ -0,0 +1,9 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Music
+  where
+import qualified SDL.Mixer as Mix
+import qualified Data.IntMap as IM
+
+data MusicData = MusicData
+    { _loadedMusic   :: IM.IntMap Mix.Music
+    }

src/Preload.hs

@@ -3,21 +3,16 @@ module Preload
     , module Preload.Data
     , module Preload.Update
     )
-    where
+  where
 import Preload.Data
 import Preload.Update
 
 import Picture.Preload
-import Sound.Preload
+import Sound.Data
 import Control.Lens
 
 import GHC.Word (Word32)
 
---doPreload :: IO (PreloadData a)
---doPreload = do
---    sData <- preloadSound
---    rData <- preloadRender
---    return $ PreloadData rData sData 0
 
 cleanUpPreload :: PreloadData a -> IO ()
 cleanUpPreload pd = do

src/Preload/Data.hs

@@ -5,12 +5,14 @@ import Control.Lens
 import GHC.Word (Word32)
 
 import Picture.Preload
-import Sound.Preload
+import Sound.Data
+import Music
 
 data PreloadData a = PreloadData
-    { _renderData :: RenderData
+    { _renderData   :: RenderData
-    , _soundData :: SoundData a
+    , _soundData    :: SoundData a
-    , _frameTimer :: Word32
+    , _musicData    :: MusicData
+    , _frameTimer   :: Word32
     }
 
 makeLenses ''PreloadData

src/Sound.hs

@@ -11,10 +11,11 @@ Uses SDL.Mixer.
 module Sound (
     -- * Simple (One-Shot) Playback
       playSoundQueue
+    , playPositionalSoundQueue
     -- * Complex Playback
     , playAndUpdate
     ) where
-import Sound.Preload
+import Sound.Data
 
 import qualified SDL.Mixer as Mix
 import Data.Maybe
@@ -24,6 +25,7 @@ import Control.Monad
 import Control.Monad.Trans
 import Control.Monad.Trans.Maybe
 import Control.Lens
+import Data.Int (Int16)
 {- | Start playing new sounds and update sound specifications.
 A Map of new sound specifications is merged with a Map of already playing sounds, 
 then sounds in the merged Map are updated.
@@ -63,7 +65,9 @@ updateSounds sd ss = do
 
 updateSound :: IM.IntMap Mix.Chunk -> Sound -> MaybeT IO Sound
 updateSound sd s =
-    initialisePlaying sd s >>= liftIO . decrementTimer >>= cleanupHalted
+    initialisePlaying sd s 
+    >>= liftIO . (decrementTimer >=> applyPosition) 
+    >>= cleanupHalted
 
 initialisePlaying :: IM.IntMap Mix.Chunk -> Sound -> MaybeT IO Sound
 initialisePlaying sd s = case _soundStatus s of
@@ -98,6 +102,12 @@ decrementTimer s = case _soundTime s of
                                          & soundStatus .~ FadingOut)
     Nothing -> return s
 
+applyPosition :: Sound -> IO Sound
+applyPosition s = case _soundPos s of
+    Nothing     -> return s
+    Just (a,d)  -> Mix.effectPosition (fromJust $ _soundChannel s) a d
+                    >> return (s & soundPos .~ Nothing)
+
 fadeOutMaybe :: Maybe Mix.Channel -> Int -> IO ()
 fadeOutMaybe (Just x) fadeT = Mix.fadeOut (fromIntegral fadeT + 1) x
 fadeOutMaybe _ _ = return ()
@@ -112,18 +122,29 @@ cleanupHalted s = do
 
 -----------------------------------------------------------------
 {- | Play sounds from a list of indices.
-Each sound starts playing (and will not repeat) if there is a free channel.
+For each index, the corresponding sound starts playing if there is a free channel.
 Use this if you don't care about timing, overlapping, fading, or sound positions.
 -}
 playSoundQueue :: IM.IntMap Mix.Chunk -> [Int] -> IO ()
-playSoundQueue chunkMap ns = forM_ ns $ \n -> playIfFree (chunkMap IM.! n) Mix.Once
+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 -> IO (Maybe Mix.Channel)
-playIfFree c times = do
-    mayChan <- Mix.getAvailable Mix.DefaultGroup
-    case mayChan of
-        Nothing -> return Nothing
-        Just i  -> Just <$> Mix.playOn i times c
 
+playIfFree :: Mix.Chunk -> Mix.Times -> MaybeT IO Mix.Channel
+playIfFree c times = do
+    i <- MaybeT $ Mix.getAvailable Mix.DefaultGroup
+    liftIO $ Mix.playOn i times c
+
+-----------------------------------------------------------------
+{- | Play sounds from a list of index/position pairs.
+As for 'playSoundQueue', but with positional information in the form of an Int16.
+-}
+playPositionalSoundQueue :: IM.IntMap Mix.Chunk -> [(Int,Int16)] -> IO ()
+playPositionalSoundQueue chunkMap ns = forM_ ns $ \(n,a) -> 
+    runMaybeT $ playIfFree (chunkMap IM.! n) Mix.Once >>= setChannelPos a
+
+setChannelPos :: Int16 -> Mix.Channel -> MaybeT IO Mix.Channel
+setChannelPos a i = do
+    liftIO $ Mix.effectPosition i a 0 
+    return i

src/Sound/Data.hs

@@ -1,11 +1,13 @@
 {-# LANGUAGE TemplateHaskell #-}
-module Sound.Preload
+module Sound.Data
     where
 import qualified SDL.Mixer as Mix
 import qualified Data.IntMap as IM
 import qualified Data.Map as M
 import Control.Lens
 import Geometry
+import Data.Word (Word8)
+import Data.Int (Int16)
 
 data SoundStatus 
     = Playing
@@ -22,7 +24,7 @@ data Sound = Sound
     , _soundFadeTime    :: Int
     , _soundStatus      :: SoundStatus
     , _soundChannel     :: Maybe Mix.Channel
-    , _soundPos         :: Maybe Point2
+    , _soundPos         :: Maybe (Int16,Word8)
     , _soundChunkID     :: Int
     }
   deriving (Eq,Ord,Show)