From 772103f92cf3852faf338875800097f46fd89950 Mon Sep 17 00:00:00 2001 From: jgk Date: Mon, 5 Apr 2021 11:36:54 +0200 Subject: [PATCH] Cleanup, haddocks --- app/Main.hs | 1 - bench/Bench.hs | 6 ++-- src/Dodge/Creature.hs | 8 ++--- src/Dodge/Item/Weapon.hs | 22 ------------- src/Dodge/WorldEvent/Shockwave.hs | 2 +- src/Geometry.hs | 18 +++++------ src/LoadConfig.hs | 1 - src/Loop.hs | 2 +- src/Sound.hs | 52 +++++++++++++++++++++++-------- 9 files changed, 56 insertions(+), 56 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 90f18982c..f4515a0ba 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -7,7 +7,6 @@ import Dodge.Data import Dodge.Initialisation import Dodge.Rooms import Dodge.Layout -import Dodge.LoadSound import Dodge.Update import Dodge.Event import Dodge.Render diff --git a/bench/Bench.hs b/bench/Bench.hs index 7a0c03590..63103383c 100644 --- a/bench/Bench.hs +++ b/bench/Bench.hs @@ -5,13 +5,15 @@ import Dodge.RandomHelp import Geometry import System.Random +import Control.Monad (replicateM) +import Data.Functor ((<&>)) import Control.Monad.State import Data.List (zip4) main :: IO () main = do [ps1, ps2, ps3, ps4] <- mapM randomPoints [500,500,500,500] - fs <- sequence $ replicate 500 (randomRIO (1,20)) + fs <- replicateM 500 (randomRIO (1,20)) defaultMain [ bgroup "circLine tests" [ bench "circLine" $ nf (map $ uncurry4 circOnLine) (zip4 ps1 ps2 ps3 fs) @@ -22,4 +24,4 @@ main = do uncurry4 f (a,b,c,d) = f a b c d randomPoints :: Int -> IO [Point2] -randomPoints i = getStdGen >>= return . evalState (sequence $ replicate i $ randInCirc 500) +randomPoints i = getStdGen <&> evalState (replicateM i $ randInCirc 500) diff --git a/src/Dodge/Creature.hs b/src/Dodge/Creature.hs index bcdef972b..e08aa429b 100644 --- a/src/Dodge/Creature.hs +++ b/src/Dodge/Creature.hs @@ -14,6 +14,7 @@ import Dodge.Item.Consumable import Dodge.WorldEvent.Cloud import Dodge.Creature.YourControl import Dodge.Creature.Inanimate +import Dodge.Item import Picture import Geometry @@ -255,13 +256,9 @@ startCr = defaultCreature [pistol ,blinkGun ,spawnGun lamp - ,flameGrenade - ,teslaGrenade + ,poisonSprayer ,autoGun ,launcher - ,flameLauncher - ,poisonLauncher - ,teslaLauncher ,lasGun ,grenade ,ltAutoGun,flamer,multGun,spreadGun,remoteLauncher @@ -272,7 +269,6 @@ startCr = defaultCreature ,miniGun ,medkit 50 ,bezierGun - ,poisonSprayer ] ++ repeat NoItem)) , _crCorpse = onLayer CorpseLayer $ color (greyN 0.5) $ pictures [color (greyN 0.8) $ circleSolid 10, circLine 10] diff --git a/src/Dodge/Item/Weapon.hs b/src/Dodge/Item/Weapon.hs index 390b51789..08a3ba7a4 100644 --- a/src/Dodge/Item/Weapon.hs +++ b/src/Dodge/Item/Weapon.hs @@ -1578,28 +1578,6 @@ jetPack = defaultEquipment , _itID = Nothing } -latchkey :: Int -> Item -latchkey n = defaultEquipment - { _itIdentity = Generic - , _itName = "KEY "++show n - , _itMaxStack = 1 - , _itAmount = 1 - , _itFloorPict = onLayer FlItLayer $ latchkeyPic - , _itEquipPict = \cr _ -> onLayer PtLayer $ translate (-5) (-5) $ rotate (pi/2.5) latchkeyPic - , _itEffect = NoItEffect - , _itHammer = HammerUp - , _itID = Nothing - , _itAimingSpeed = 1 - , _itAimingRange = 0 - , _itZoom = defaultItZoom - , _itInvColor = yellow - , _itInvDisplay = _itName - } -latchkeyPic = color yellow $ - pictures [translate (-4) 0 $ thickCircle 4 2 - ,lineOfThickness 2 [(0,0),(8,0),(8,-4)] - ,lineOfThickness 2 [(4,0),(4,-4)] - ] -- }}} diff --git a/src/Dodge/WorldEvent/Shockwave.hs b/src/Dodge/WorldEvent/Shockwave.hs index 27e7bf910..41c5bc0b0 100644 --- a/src/Dodge/WorldEvent/Shockwave.hs +++ b/src/Dodge/WorldEvent/Shockwave.hs @@ -57,7 +57,7 @@ mvShockwave' mvShockwave' is w pt | _btTimer' pt <= 0 = (w, Nothing) | otherwise - = (dams w , Just $ set btTimer' (t - 1) pt) -- $ set ptDraw (const pic) pt) + = (dams w , Just $ set btTimer' (t - 1) pt) -- $ set ptDraw (const pic) pt) where r = _btRad' pt p = _btPos' pt diff --git a/src/Geometry.hs b/src/Geometry.hs index ee96bf004..d4e53124d 100644 --- a/src/Geometry.hs +++ b/src/Geometry.hs @@ -90,13 +90,13 @@ errorPointInPolygon !i !p xs -- | Debug version of 'normalizeV'. errorNormalizeV :: Int -> Point2 -> Point2 -errorNormalizeV !i !(0,0) = error $ "problem with function: errorNormalizeV "++show i +errorNormalizeV !i (0,0) = error $ "problem with function: errorNormalizeV "++show i errorNormalizeV !i !p = normalizeV p -- | Debug version of 'angleVV'. errorAngleVV :: Int -> Point2 -> Point2 -> Float -errorAngleVV !i !(0,0) _ = error $ "problem with function: errorAngleVV "++show i -errorAngleVV !i _ !(0,0) = error $ "problem with function: errorAngleVV "++show i +errorAngleVV !i (0,0) _ = error $ "problem with function: errorAngleVV "++show i +errorAngleVV !i _ (0,0) = error $ "problem with function: errorAngleVV "++show i errorAngleVV !i !p !p' = angleVV p p' -- | Debug version of 'isLHS'. @@ -126,9 +126,9 @@ isLHS -> Bool {-# INLINE isLHS #-} isLHS - !(x,y) - !(x',y') - !(x'',y'') + (x,y) + (x',y') + (x'',y'') | (x,y) == (x',y') = False | otherwise = a1 * b2 - a2 * b1 > 0 where @@ -146,9 +146,9 @@ isRHS -> Bool {-# INLINE isRHS #-} isRHS - !(x,y) - !(x',y') - !(x'',y'') + (x,y) + (x',y') + (x'',y'') | (x,y) == (x',y') = False | otherwise = a1 * b2 - a2 * b1 < 0 where diff --git a/src/LoadConfig.hs b/src/LoadConfig.hs index 72983344b..3413b2eed 100644 --- a/src/LoadConfig.hs +++ b/src/LoadConfig.hs @@ -8,7 +8,6 @@ import Foreign.C.Types import GHC.Generics import qualified GHC.Int import qualified SDL -import SDL.Internal.Numbered as SDL.Internal.Numbered import System.Directory diff --git a/src/Loop.hs b/src/Loop.hs index 4ed1f8e0c..b202638ef 100644 --- a/src/Loop.hs +++ b/src/Loop.hs @@ -1,6 +1,6 @@ {-| Module : Loop -Description : A minimal game loop +Description : Minimal game loop This module sets up an SDL window which may be updated using a simple game loop. -} diff --git a/src/Sound.hs b/src/Sound.hs index a9ef2bc9e..703b44152 100644 --- a/src/Sound.hs +++ b/src/Sound.hs @@ -1,45 +1,64 @@ +{-| +Module : Sound +Description : Channel selection and storage + +This module checks for empty channels and plays sounds on them, using data chunks loaded into an IntMap, +and sound specifications of type 'Sound' loaded into a Map. +Uses SDL.Mixer. +-} module Sound where import Sound.Preload -import Control.Monad - import qualified SDL.Mixer as Mix - import Data.Maybe import qualified Data.IntMap as IM import qualified Data.Map as M - +import Control.Monad import Control.Lens +{- | Play sounds from a list of indices. +Each sound is played once if there is a free channel. +-} playSoundQueue :: SoundData a -> [Int] -> IO () playSoundQueue sd ns = forM_ ns $ \n -> playIfFree (_loadedChunks sd IM.! n) Mix.Once --- this can be cleaned up +{- | 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 - +{- | 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 + 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 .~ Just chan)) + 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 --- logic: check if sound is playing: --- if so, decrement timers, and/or stop playing and remove --- if not, check if there is free channel: --- if so, start playing --- if not, remove sound +{- Play a sound according to it's specification. +Logic: check if sound is playing: + + - If so, decrement timers, and/or stop playing and remove + - If not, check if there is free channel: + - If so, start playing + - If not, remove sound. +-} playSound :: SoundData a -> Sound -> IO (Maybe Sound) playSound sd s = case _soundChannel s of Just i -> case _soundTime s of @@ -51,15 +70,22 @@ playSound sd s = case _soundChannel s of ) Nothing -> playSoundIfFree (_loadedChunks sd IM.! _soundType s) s +{- Play all sounds and create new sound data. + -} playSounds :: SoundData a -> IO (SoundData a) playSounds sd = do newSounds <- mapM (playSound 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} +{- Start playing new sounds and update sound specifications. + -} playAndUpdate :: Ord a => M.Map a Sound -> SoundData a -> IO (SoundData a) playAndUpdate new sd = playSounds $ over playingSounds (updatePlaying new) sd