diff --git a/app/Main.hs b/app/Main.hs index 846bbe3db..e2ff9c242 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -65,6 +65,7 @@ main = do -- ] -- ) ) + (\_ _ -> return) (flip $ menuEvents $ flip handleEvent) (\w -> Just $ update w) Mix.closeAudio diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index 950de7564..cf9a18373 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -64,7 +64,6 @@ data World = World , _pressPlates :: IM.IntMap PressPlate , _buttons :: IM.IntMap Button , _soundQueue :: [Int] --- , _loadedSounds :: IM.IntMap Mix.Chunk , _sounds :: M.Map SoundOrigin Sound , _decorations :: IM.IntMap Drawing , _corpses :: IM.IntMap (IM.IntMap [Corpse]) diff --git a/src/Dodge/LoadSound.hs b/src/Dodge/LoadSound.hs index 822665171..6db2dc724 100644 --- a/src/Dodge/LoadSound.hs +++ b/src/Dodge/LoadSound.hs @@ -111,27 +111,14 @@ loadSounds = do -- -- fmap (set soundQueue creatureSounds) $ return w -- where creatureSounds = [] +--playSounds :: a -> World -> IO () +--playSounds _ w = do +-- forM_ (_soundQueue w) (\n -> Mix.playOn (-1) 0 (_loadedSounds w IM.! n)) +-- -- = return $ set soundQueue creatureSounds w +-- -- = do forM_ (_soundQueue w) (\n -> Mix.playOn (-1) (_loadedSounds w IM.! n) 0) +-- -- fmap (set soundQueue creatureSounds) $ return w +-- where creatureSounds = [] + soundOnce :: Int -> World -> World soundOnce i = over soundQueue ((:) i) ---stepSoundTimers :: World -> IO World ---stepSoundTimers w = M.foldrWithKey stepSoundTimer (return w) (_sounds w) - --- ok, this is hard to reason about-- bugs can occur because I am unsure when --- everything is evaluated ---stepSoundTimer :: SoundOrigin -> Sound -> IO World -> IO World ---stepSoundTimer so s w = --- case _soundChannel s of --- Nothing -> do w1 <- w --- let soundChunk = _loadedSounds w1 IM.! _soundType s ----- n <- Mix.playingCount --- channel <- Mix.playOn (-1) (-1) soundChunk --- -- w2 <- w -- Note that using w2 instead of w1 in the --- -- final return breaks the sound sometimes, must be --- -- something to do with order of evaluation --- return $ set (sounds . ix so . soundChannel) (Just $ fromIntegral channel) w1 --- Just channel -> case _soundTime s of --- x | x > 0 -> fmap (set (sounds . ix so . soundTime) (x-1)) w --- | x <= 0 -> do Mix.fadeOut channel (fromIntegral $ _soundFadeTime s+ 1) --- fmap (over sounds (M.delete so)) w --- the sound fade doesn't seem to like being 0 diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index 574c68266..ac2421333 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -61,6 +61,30 @@ update w where (x,y) = zoneOfPoint $ _clPos cr cid = _clID cr +--updateSound :: World -> World +--updateSound = set soundQueue [] . stepSoundTimers +--stepSoundTimers :: World -> IO World +--stepSoundTimers w = M.foldrWithKey stepSoundTimer (return w) (_sounds w) + +---- ok, this is hard to reason about-- bugs can occur because I am unsure when +---- everything is evaluated +--stepSoundTimer :: SoundOrigin -> Sound -> IO World -> IO World +--stepSoundTimer so s w = +-- case _soundChannel s of +-- Nothing -> do w1 <- w +-- let soundChunk = _loadedSounds w1 IM.! _soundType s +---- n <- Mix.playingCount +-- channel <- Mix.playOn (-1) (-1) soundChunk +-- -- w2 <- w -- Note that using w2 instead of w1 in the +-- -- final return breaks the sound sometimes, must be +-- -- something to do with order of evaluation +-- return $ set (sounds . ix so . soundChannel) (Just $ fromIntegral channel) w1 +-- Just channel -> case _soundTime s of +-- x | x > 0 -> fmap (set (sounds . ix so . soundTime) (x-1)) w +-- | x <= 0 -> do Mix.fadeOut channel (fromIntegral $ _soundFadeTime s+ 1) +-- fmap (over sounds (M.delete so)) w +---- the sound fade doesn't seem to like being 0 + updateLightSources w = set tempLightSources (catMaybes tlss) w' where (w',tlss) = mapAccumR (\a b -> _tlsUpdate b a b) w $ _tempLightSources w diff --git a/src/Loop.hs b/src/Loop.hs index 6c2a4186d..fa3c88f66 100644 --- a/src/Loop.hs +++ b/src/Loop.hs @@ -29,11 +29,12 @@ setupLoop :: String -> (setupParams -> IO ()) -> world -> (setupParams -> world -> IO ()) + -> (setupParams -> world -> storableSideEffects -> IO storableSideEffects) -> (world -> Event -> Maybe world) -> (world -> Maybe world) -> IO () setupLoop wName xSize ySize - customInit initCleanup startWorld sideEffects eventFn worldFn = do + customInit initCleanup startWorld sideEffects storableFn eventFn worldFn = do initializeAll bracket (createWindow (T.pack wName) (winConfig xSize ySize)) destroyWindow (\window -> @@ -47,7 +48,7 @@ setupLoop wName xSize ySize GL.clearColor $= GL.Color4 0 0.5 0 1 GL.clearDepth $= (200) doLoop setup window startWorld - sideEffects eventFn worldFn + sideEffects storableFn eventFn worldFn ) ) @@ -59,9 +60,14 @@ setupLoop wName xSize ySize -- -> IO () doLoop setup window startWorld worldSideEffects + storableFn eventFn worldUpdate = do + GL.clear [GL.ColorBuffer,GL.DepthBuffer] + worldSideEffects setup startWorld + glSwapWindow window + --worldSideEffects setup updatedWorld startLoopTicks <- ticks events <- pollEvents --let-- maybeUpdatedWorld :: Maybe (WorldView world0) @@ -69,15 +75,15 @@ doLoop setup window startWorld maybeUpdatedWorld <- applyEventsIO eventFn startWorld events case maybeUpdatedWorld >>= worldUpdate of Just updatedWorld -> do - GL.clear [GL.ColorBuffer,GL.DepthBuffer] - worldSideEffects setup updatedWorld - glSwapWindow window + --GL.clear [GL.ColorBuffer,GL.DepthBuffer] + --worldSideEffects setup updatedWorld + --glSwapWindow window --GL.flush performGC endLoopTicks <- ticks -- it might be better to use System.Clock (monotonic) let delay = max 0 (10 + fromIntegral startLoopTicks - fromIntegral endLoopTicks) threadDelay (delay * 1000) - doLoop setup window updatedWorld worldSideEffects eventFn worldUpdate + doLoop setup window updatedWorld worldSideEffects storableFn eventFn worldUpdate Nothing -> return () applyEvents :: (world0 -> Event -> Maybe world0) diff --git a/src/Sound.hs b/src/Sound.hs new file mode 100644 index 000000000..1bca904d9 --- /dev/null +++ b/src/Sound.hs @@ -0,0 +1,7 @@ +module Sound + where + +-- ok, the problem here is that we need to be able to return the playing channel +-- so this thread cannot be a simple observer + + diff --git a/src/Sound/Preload.hs b/src/Sound/Preload.hs new file mode 100644 index 000000000..4ca47b099 --- /dev/null +++ b/src/Sound/Preload.hs @@ -0,0 +1,7 @@ +module Sound.Preload + where +import qualified SDL.Mixer as Mix + +import qualified Data.IntMap as IM + +type LoadedSounds = IM.IntMap Mix.Chunk