From d3821fc7b3ebfc756a85351b020242454756c609 Mon Sep 17 00:00:00 2001 From: jgk Date: Sun, 4 Apr 2021 17:14:30 +0200 Subject: [PATCH 1/8] Add haddocks --- src/Geometry/Intersect.hs | 43 +++++++++++++++++++++++++++++++-------- 1 file changed, 34 insertions(+), 9 deletions(-) diff --git a/src/Geometry/Intersect.hs b/src/Geometry/Intersect.hs index 44277a725..e43b1fdcf 100644 --- a/src/Geometry/Intersect.hs +++ b/src/Geometry/Intersect.hs @@ -1,12 +1,9 @@ module Geometry.Intersect where import Geometry.Data - import Control.Applicative -intersectSegBezquad :: Point2 -> Point2 -> Point2 -> Point2 -> Point2 -> [Point2] -intersectSegBezquad = undefined - +-- | If two lines intersect, return 'Just' that point. intersectLineLine' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2 {-# INLINE intersectLineLine' #-} intersectLineLine' (x1,y1) (x2,y2) (x3,y3) (x4,y4) @@ -16,6 +13,7 @@ intersectLineLine' (x1,y1) (x2,y2) (x3,y3) (x4,y4) den = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4) t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4) +-- | If two segments intersect, return 'Just' that point. intersectSegSeg' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2 {-# INLINE intersectSegSeg' #-} intersectSegSeg' (x1,y1) (x2,y2) (x3,y3) (x4,y4) @@ -30,6 +28,8 @@ intersectSegSeg' (x1,y1) (x2,y2) (x3,y3) (x4,y4) t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4) u' = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3) +-- | Intended to intersect a segment with a half-line-segment, ie a segment +-- extending infinitely in one direction. intersectSegLineFrom' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2 {-# INLINE intersectSegLineFrom' #-} intersectSegLineFrom' (x1,y1) (x2,y2) (x3,y3) (x4,y4) @@ -44,7 +44,7 @@ intersectSegLineFrom' (x1,y1) (x2,y2) (x3,y3) (x4,y4) t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4) u' = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3) --- this is probably not correct... +-- | Similar to 'intersectSegLineFrom'', but this version is probably not correct... intersectSegLineext :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2 {-# INLINE intersectSegLineext #-} intersectSegLineext (x1,y1) (x2,y2) (x3,y3) (x4,y4) @@ -59,6 +59,7 @@ intersectSegLineext (x1,y1) (x2,y2) (x3,y3) (x4,y4) t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4) u' = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3) +-- | Intersect a segment with a line. intersectSegLine' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2 {-# INLINE intersectSegLine' #-} intersectSegLine' (x1,y1) (x2,y2) (x3,y3) (x4,y4) @@ -73,9 +74,13 @@ intersectSegLine' (x1,y1) (x2,y2) (x3,y3) (x4,y4) t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4) u' = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3) --- intersectSegSeg is sometimes broken-- the following fixes at least some of --- the cases --- it is, however, slow +-- | Due to floating point issues, 'intersectSegSeg'' is not always +-- accurate---'myIntersectSegSeg' +-- fixes at least some of +-- the problem cases by transforming the points into rationals and then doing the +-- intersection. +-- This version is, probably, slower---both testing and benchmarking should be +-- done. myIntersectSegSeg a@(ax,ay) b@(bx,by) c@(cx,cy) d@(dx,dy) = case ratIntersectLineLine a b c d of Nothing -> Nothing Just (x,y) -> if inbetween x && inbetween' y @@ -86,6 +91,7 @@ myIntersectSegSeg a@(ax,ay) b@(bx,by) c@(cx,cy) d@(dx,dy) = case ratIntersectLin inbetween' y = ((ay <= y && y <= by) || (by <= y && y <= ay)) && ((cy <= y && y <= dy) || (dy <= y && y <= cy)) +-- | Polymorphic intersection of fractional line points. myIntersectLineLine :: (Eq a,Fractional a) => (a,a) -> (a,a) -> (a,a) -> (a,a) -> Maybe (a,a) myIntersectLineLine a@(ax,ay) b c@(cx,cy) d | linGrad a b == Nothing = fmap ((,) ax) $ axisInt (c *-* (ax,0)) (d *-* (ax,0)) @@ -102,24 +108,43 @@ myIntersectLineLine a@(ax,ay) b c@(cx,cy) d newx = (axisInt c d ^-^ axisInt a b) ^/^ (linGrad a b ^-^ linGrad c d) (*-*) (ax,ay) (bx,by) = (ax-bx,ay-by) +-- | Transforms floating points to rationals then performs line intersection. ratIntersectLineLine :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2 ratIntersectLineLine a b c d = fmap toNumPoint2 $ myIntersectLineLine (toRatPoint2 a) (toRatPoint2 b) (toRatPoint2 c) (toRatPoint2 d) where toRatPoint2 (x,y) = (toRational x, toRational y) toNumPoint2 (x,y) = (fromRational x, fromRational y) f = toRatPoint2 . roundPoint2 +-- | Round the floats within a 'Point2' to the nearest integer. +-- Rounding jumps after intervals of .5: +-- +-- >>> roundPoint (0.5,0.5001) +-- (0.0,1.0) +-- +-- but is symmetric around 0: +-- +-- >>> roundPoint2 (0.5,-0.5) +-- (0.0,0.0) +-- roundPoint2 :: Point2 -> Point2 roundPoint2 (x,y) = (fromIntegral $ round x,fromIntegral $ round y) +-- | Given two points, finds the linear gradient if it is non-infinite. linGrad :: (Eq a,Fractional a) => (a,a) -> (a,a) -> Maybe a linGrad (x,y) (a,b) | x-a == 0 = Nothing | otherwise = Just $ (y-b)/(x-a) +-- | Given two points, finds the intersection with the y axis if it exists. axisInt :: (Eq a,Fractional a) => (a,a) -> (a,a) -> Maybe a axisInt p (a,b) = pure b ^-^ (pure a ^*^ linGrad p (a,b)) where (^-^) = liftA2 (-) (^*^) = liftA2 (*) - +-- | Placeholder, undefined. intersectSegsSeg :: [Point2] -> Point2 -> Point2 -> Maybe Point2 intersectSegsSeg = undefined + +-- | Placeholder: should intersect a segment with a bezier curve. +intersectSegBezquad :: Point2 -> Point2 -> Point2 -> Point2 -> Point2 -> [Point2] +intersectSegBezquad = undefined + From b3649597fae7aef20a92deb3e0d0e8c80c745ae5 Mon Sep 17 00:00:00 2001 From: jgk Date: Sun, 4 Apr 2021 18:53:43 +0200 Subject: [PATCH 2/8] Add haddocks --- src/Dodge/Base.hs | 2 +- src/Geometry.hs | 6 ----- src/Geometry/Bezier.hs | 12 +++++++++ src/Geometry/Data.hs | 1 - src/Geometry/Vector.hs | 61 +++++++++++++++++++++++++++++++++--------- 5 files changed, 61 insertions(+), 21 deletions(-) diff --git a/src/Dodge/Base.hs b/src/Dodge/Base.hs index 4f75a6cab..21cfeb529 100644 --- a/src/Dodge/Base.hs +++ b/src/Dodge/Base.hs @@ -761,7 +761,7 @@ 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 *.* (normV . vNormal $ y -.- x) + where n = 10 *.* (safeNormalizeV . vNormal $ y -.- x) x' = x +.+ n y' = y +.+ n diff --git a/src/Geometry.hs b/src/Geometry.hs index 1f2e10cdf..ee96bf004 100644 --- a/src/Geometry.hs +++ b/src/Geometry.hs @@ -117,12 +117,6 @@ errorClosestPointOnLineParam !i !x! y! z | x == y = dist x z | otherwise = closestPointOnLineParam x y z --- | Normalize a vector to be unit length. --- For (0,0) return (0,0). -safeNormalizeV :: Point2 -> Point2 -safeNormalizeV !(0,0) = (0,0) -safeNormalizeV !p = normalizeV p - -- | Test whether a point is on the LHS of a line. -- Returns False if the line is of zero length. isLHS diff --git a/src/Geometry/Bezier.hs b/src/Geometry/Bezier.hs index 55b727007..a67bc374c 100644 --- a/src/Geometry/Bezier.hs +++ b/src/Geometry/Bezier.hs @@ -3,8 +3,15 @@ module Geometry.Bezier import Geometry.Data import Geometry.Vector +{- | A synonym describing a quadratic Bezier curve as three 'Point2's: start, +control and end. + -} type BQuad = (Point2,Point2,Point2) +{- | Split a quadratic Bezier curve into two at a fractional point along the +curve. +If the fraction is not between 0 and 1, this will create backwards curves. + -} splitBezierquad :: BQuad -> Float -> (BQuad,BQuad) splitBezierquad (a,b,c) z = ( ( a @@ -17,11 +24,16 @@ splitBezierquad (a,b,c) z ) ) +{- | Split a quadratic Bezier curve into a given number of straight lines, and + return the list of points defining these lines. + -} bQuadToLine :: BQuad -> Int -> [Point2] bQuadToLine (a,_,c) 0 = [a,c] bQuadToLine x i = let (l,r) = splitBezierquad x 0.5 in bQuadToLine l (i-1) ++ bQuadToLine r (i-1) +{- | Transform a quadratic Bezier curve into a function. + -} bQuadToF :: (Point2,Point2,Point2) -> Float -> Point2 bQuadToF (c,b,a) t = t *.* (t *.* a +.+ (1-t) *.* b) +.+ (1-t) *.* (t *.* b +.+ (1-t) *.* c) diff --git a/src/Geometry/Data.hs b/src/Geometry/Data.hs index 8f985d3b7..9a3adf4ad 100644 --- a/src/Geometry/Data.hs +++ b/src/Geometry/Data.hs @@ -4,7 +4,6 @@ module Geometry.Data , Point4 (..) ) where - type Point2 = (Float,Float) type Point3 = (Float,Float,Float) type Point4 = (Float,Float,Float,Float) diff --git a/src/Geometry/Vector.hs b/src/Geometry/Vector.hs index 26a6d1803..afb0deaf7 100644 --- a/src/Geometry/Vector.hs +++ b/src/Geometry/Vector.hs @@ -2,7 +2,8 @@ module Geometry.Vector where import Geometry.Data - +{- | Moves from to three dimensions, adding zero in z direction. + -} zeroZ :: Point2 -> Point3 {-# INLINE zeroZ #-} zeroZ (x,y) = (x,y,0) @@ -10,6 +11,8 @@ zeroZ (x,y) = (x,y,0) infixl 6 +.+, -.- infixl 7 *.* +{- | 2D coordinate-wise addition. + -} (+.+) :: Point2 -> Point2 -> Point2 {-# INLINE (+.+) #-} (x1, y1) +.+ (x2, y2) = @@ -17,7 +20,8 @@ infixl 7 *.* !x = x1 + x2 !y = y1 + y2 in (x, y) - +{- | 2D coordinate-wise subtraction. + -} (-.-) :: Point2 -> Point2 -> Point2 {-# INLINE (-.-) #-} (x1, y1) -.- (x2, y2) = @@ -25,7 +29,8 @@ infixl 7 *.* !x = x1 - x2 !y = y1 - y2 in (x, y) - +{- | 2D scalar multiplication. + -} (*.*) :: Float -> Point2 -> Point2 {-# INLINE (*.*) #-} a *.* (x2, y2) = @@ -37,6 +42,9 @@ a *.* (x2, y2) = infixl 6 +.+.+, -.-.- infixl 7 *.*.* + +{- | 3D coordinate-wise addition. + -} (+.+.+) :: Point3 -> Point3 -> Point3 {-# INLINE (+.+.+) #-} (x1, y1, z1) +.+.+ (x2, y2, z2) = @@ -46,6 +54,8 @@ infixl 7 *.*.* !z = z1 + z2 in (x, y, z) +{- | 3D coordinate-wise subtraction. + -} (-.-.-) :: Point3 -> Point3 -> Point3 {-# INLINE (-.-.-) #-} (x1, y1, z1) -.-.- (x2, y2, z2) = @@ -55,6 +65,8 @@ infixl 7 *.*.* !z = z1 - z2 in (x, y, z) +{- | 3D scalar multiplication. + -} (*.*.*) :: Point3 -> Point3 -> Point3 {-# INLINE (*.*.*) #-} (x1, y1, z1) *.*.* (x2, y2, z2) = @@ -64,10 +76,15 @@ infixl 7 *.*.* !z = z1 * z2 in (x, y, z) +{- | Normalize a vector to length 1. + -} normalizeV :: Point2 -> Point2 {-# INLINE normalizeV #-} normalizeV p = (1 / magV p) *.* p +{- | Angle between two vectors. +Always positive. + -} angleVV :: Point2 -> Point2 -> Float {-# INLINE angleVV #-} angleVV a b = let ma = magV a @@ -75,20 +92,28 @@ angleVV a b = let ma = magV a d = a `dotV` b in acos $ d / (ma * mb) +{- | Dot product. + -} dotV :: Point2 -> Point2 -> Float {-# INLINE dotV #-} dotV (x,y) (z,w) = x*z + y*w +{- | Given vector, returns the angle, anticlockwise from +ve x-axis, in radians. + -} argV :: Point2 -> Float {-# INLINE argV #-} argV (x,y) = normalizeAngle $ atan2 y x +{- | Determinant of the matrix formed by two vectors. + -} detV :: Point2 -> Point2 -> Float {-# INLINE detV #-} detV (x1, y1) (x2, y2) = x1 * y2 - y1 * x2 --- | Angle in radians, anticlockwise from +ve x-axis. +{- | Given an angle in radians, anticlockwise from +ve x-axis, returns the +corresponding unit vector. +-} unitVectorAtAngle :: Float -> Point2 {-# INLINE unitVectorAtAngle #-} unitVectorAtAngle r @@ -106,36 +131,46 @@ degToRad :: Float -> Float degToRad d = d * pi / 180 {-# INLINE degToRad #-} - -- | Convert radians to degrees radToDeg :: Float -> Float radToDeg r = r * 180 / pi {-# INLINE radToDeg #-} - -- | Normalize an angle to be between 0 and 2*pi radians normalizeAngle :: Float -> Float -normalizeAngle f = f - 2 * pi * floor' (f / (2 * pi)) - where floor' :: Float -> Float - floor' x = fromIntegral (floor x :: Int) {-# INLINE normalizeAngle #-} +normalizeAngle f = f - 2 * pi * floor' (f / (2 * pi)) + where + floor' :: Float -> Float + floor' x = fromIntegral (floor x :: Int) +{- | Rotate vector by pi/2 clockwise. + -} vNormal :: Point2 -> Point2 {-# INLINE vNormal #-} vNormal (x,y) = (y,-x) +{- | Negate a vector. + -} vInverse :: Point2 -> Point2 vInverse (x,y) = (-x,-y) -normV :: Point2 -> Point2 -{-# INLINE normV #-} -normV (0,0) = (0,0) -normV p = (1/magV p ) *.* p +{- | Normalize a vector safely: on (0,0) return (0,0). + -} +safeNormalizeV :: Point2 -> Point2 +{-# INLINE safeNormalizeV #-} +safeNormalizeV (0,0) = (0,0) +safeNormalizeV p = (1/magV p ) *.* p +{- | Magnitude of a vector. + -} magV :: Point2 -> Float {-# INLINE magV #-} magV (x,y) = sqrt $ x^2 + y^2 +{- | Magnitude of the cross product of two vectors. +Identical to detV. +-} crossV :: Point2 -> Point2 -> Float crossV (ax,ay) (bx,by) = ax*by - ay*bx From dfee9b2f378f3732155cc89a950a5d31ac4b0646 Mon Sep 17 00:00:00 2001 From: jgk Date: Sun, 4 Apr 2021 20:19:45 +0200 Subject: [PATCH 3/8] Modularise shockwaves, stop landing self damage when blinking --- app/Main.hs | 4 +- src/Dodge/CreatureAction.hs | 12 ++-- src/Dodge/Item/Weapon.hs | 3 - src/Dodge/Item/Weapon/Bullet.hs | 5 +- src/Dodge/WorldEvent.hs | 47 +----------- src/Dodge/WorldEvent/Explosion.hs | 74 +------------------ src/Dodge/WorldEvent/Shockwave.hs | 114 ++++++++++++++++++++++++++++++ src/Geometry/Intersect.hs | 25 ++++--- 8 files changed, 144 insertions(+), 140 deletions(-) create mode 100644 src/Dodge/WorldEvent/Shockwave.hs diff --git a/app/Main.hs b/app/Main.hs index ddcf6053c..90f18982c 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -26,7 +26,7 @@ import Control.Concurrent import Control.Lens import Foreign (Word32) -import Control.Monad (when) +import Control.Monad (when,void) import System.Random @@ -53,7 +53,7 @@ main = do (fmap (setWindowSize sizex sizey keyConfig) firstWorld) ( \preData w -> do startTicks <- SDL.ticks - doDrawing (_renderData preData) w + void $ doDrawing (_renderData preData) w playSoundQueue (_soundData preData) (_soundQueue w) newSoundData <- playAndUpdate (_sounds w) (_soundData preData) diff --git a/src/Dodge/CreatureAction.hs b/src/Dodge/CreatureAction.hs index 2057b9a9c..2b3337026 100644 --- a/src/Dodge/CreatureAction.hs +++ b/src/Dodge/CreatureAction.hs @@ -7,7 +7,7 @@ module Dodge.CreatureAction where -- imports {{{ import Dodge.CreatureAction.UseItem - +import Dodge.WorldEvent.Shockwave import Dodge.Data import Dodge.Base import Dodge.SoundLogic @@ -222,7 +222,7 @@ createItemAt p it w = over floorItems (IM.insert i (set flItPos p blinkAction :: Int -> World -> World blinkAction n w = soundOnce teleSound $ set (creatures . ix n . crPos) p3 - $ blinkShockwave p3 + $ blinkShockwave n p3 $ inverseShockwaveAt cp 40 2 2 2 w where p1 = _cameraCenter w +.+ (1 / _cameraZoom w) *.* rotateV (_cameraRot w) (_mousePos w) @@ -231,8 +231,12 @@ blinkAction n w = soundOnce teleSound $ set (creatures . ix n . crPos) p3 r = 1.5 * _crRad (_creatures w IM.! n) p3 = fromMaybe p1 (fmap ((\p -> moveAmountToward p r cp) . fst) p2) -blinkShockwave :: Point2 -> World -> World -blinkShockwave p = makeShockwaveAt p 40 1 2 cyan +blinkShockwave + :: Int -- ^ Blinking creature ID. + -> Point2 + -> World + -> World +blinkShockwave i p = makeShockwaveAt [i] p 60 1 2 cyan moveAmountToward :: Point2 -> Float -> Point2 -> Point2 moveAmountToward p1 am p2 diff --git a/src/Dodge/Item/Weapon.hs b/src/Dodge/Item/Weapon.hs index 2fbdaa5d9..390b51789 100644 --- a/src/Dodge/Item/Weapon.hs +++ b/src/Dodge/Item/Weapon.hs @@ -920,9 +920,6 @@ flamerAngle = 0.3 aSelf :: Int -> World -> World aSelf = blinkAction - - - reflect :: Float -> Float -> Float reflect a b = a + 2*(a-b) diff --git a/src/Dodge/Item/Weapon/Bullet.hs b/src/Dodge/Item/Weapon/Bullet.hs index 5e68943fc..664ae680b 100644 --- a/src/Dodge/Item/Weapon/Bullet.hs +++ b/src/Dodge/Item/Weapon/Bullet.hs @@ -5,6 +5,7 @@ import Dodge.Base import Dodge.WorldEvent import Dodge.SoundLogic import Dodge.RandomHelp +import Dodge.WorldEvent.Shockwave import Dodge.Creature.Property @@ -129,7 +130,7 @@ bulConCr' bt p cr w where cid = _crID cr sp = head $ _btTrail' bt ep = sp +.+ _btVel' bt - mkwave = over worldEvents $ (.) (makeShockwaveAt p 15 4 1 white) + mkwave = over worldEvents $ (.) (makeShockwaveAt [] p 15 4 1 white) bulHitWall' :: Particle' -> Point2 -> Wall -> World -> World bulHitWall' bt p x w = damageBlocks x @@ -195,7 +196,7 @@ bulConWall' bt p wl w = damageBlocks wl Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 5)) w (_blIDs wall) _ -> w wallV = (_wlLine wl !! 1 -.- _wlLine wl !! 0) - mkwave = over worldEvents $ (.) (makeShockwaveAt p 15 4 1 white) + mkwave = over worldEvents $ (.) (makeShockwaveAt [] p 15 4 1 white) hvBulHitWall' :: Particle' -> Point2 -> Wall -> World -> World hvBulHitWall' bt p x w = damageBlocks x diff --git a/src/Dodge/WorldEvent.hs b/src/Dodge/WorldEvent.hs index 8fc255760..9f2e0350a 100644 --- a/src/Dodge/WorldEvent.hs +++ b/src/Dodge/WorldEvent.hs @@ -19,6 +19,7 @@ import Dodge.WorldEvent.Cloud import Dodge.WorldEvent.HitEffect import Dodge.WorldEvent.Explosion import Dodge.WorldEvent.SpawnParticle +import Dodge.WorldEvent.Shockwave import Dodge.LightSources import Dodge.Data @@ -38,52 +39,6 @@ import Data.Function import Data.List import qualified Data.IntMap.Strict as IM - -shockWaveDamage :: Point2 -> Float -> Int -> World -> World -shockWaveDamage p rad amount w = flip (foldr damageBlocks) hitBlocks $ over creatures (IM.map f) w - where f cr | dist (_crPos cr) p < rad + _crRad cr = over (crState . crDamage) - ((:) $ Concussive amount p 2 0.5 rad) cr - | otherwise = cr - hitBlocks = wallsOnCirc p rad $ wallsNearPoint p w - damageBlocks wall w - = case wall ^? blHP of - Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - (div amount 2))) - w - (_blIDs wall) - _ -> w - - -inverseShockwaveAt :: Point2 -> Float -> Int -> Float -> Float -> World -> World -inverseShockwaveAt p rad dam push pushexp = over particles' ((:) theShockwave) - where theShockwave - = Particle' - { _ptDraw = const blank - , _ptUpdate' = moveInverseShockWave 10 p rad push pushexp - } -moveInverseShockWave :: Int -> Point2 -> Float -> Float -> Float -> World -> Particle' -> (World, Maybe Particle') -moveInverseShockWave 0 _ _ _ _ w _ = (w, Nothing) -moveInverseShockWave t p r push pushexp w pt - = (dams w, Just $ newupdate $ newpic pt ) - where newupdate = set ptUpdate' $ moveInverseShockWave (t-1) p r push pushexp - newpic = set ptDraw (const $ onLayer PtLayer $ uncurry translate p - $ color cyan $ thickCircle rad thickness) - rad = r - (4/40) * r * fromIntegral (10 - t) - thickness = (fromIntegral (10 - t))**2 * rad / 40 - dams = over creatures (IM.map damCr) . flip (foldr damageBlocks) hitBlocks - hitBlocks = wallsOnCirc p rad $ wallsNearPoint p w - damageBlocks wall w - = case wall ^? blHP of - Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 1)) - w - (_blIDs wall) - _ -> w - damCr cr | dist (_crPos cr) p < rad + _crRad cr - = over (crState . crDamage) - ((:) $ PushDam 1 (25 *.* safeNormalizeV (p -.- _crPos cr))) - cr - | otherwise = cr - - createBarrelSpark :: Int -> Int -> Point2 -> Float -> Maybe Int -> World -> World createBarrelSpark time colid pos dir maycid w = over worldEvents ((.) $ ( over particles' ((:) spark) diff --git a/src/Dodge/WorldEvent/Explosion.hs b/src/Dodge/WorldEvent/Explosion.hs index 6f0621907..66072012d 100644 --- a/src/Dodge/WorldEvent/Explosion.hs +++ b/src/Dodge/WorldEvent/Explosion.hs @@ -7,7 +7,7 @@ import Dodge.WorldEvent.SpawnParticle import Dodge.WorldEvent.Flash import Dodge.RandomHelp import Dodge.SoundLogic - +import Dodge.WorldEvent.Shockwave import Geometry import Picture @@ -57,7 +57,7 @@ makeExplosionAt :: Point2 -> World -> World makeExplosionAt p w = soundOnce grenadeBang . addFlames . explosionFlashAt p - $ makeShockwaveAt p 50 10 1 white + $ makeShockwaveAt [] p 50 10 1 white w where fVs = fst $ runState ((sequence . take 75 . repeat . randInCirc) 1) $ _randGen w @@ -74,73 +74,3 @@ makeExplosionAt p w = soundOnce grenadeBang pushAgainstWalls q = fromMaybe q $ fmap (\(x,y)-> x +.+ y) $ collidePointWalls p q $ wallsNearPoint q w -makeShockwaveAt :: Point2 -> Float -> Int -> Float -> Color - -> World -> World -makeShockwaveAt p rad dam push col = over particles' ((:) theShockwave) - where theShockwave = shockwaveAt p rad dam push col 10 - -shockwaveAt :: Point2 -> Float -> Int -> Float -> Color -> Int -> Particle' -shockwaveAt p rad dam push col maxtime - = Shockwave' - { _ptDraw = const blank - , _ptUpdate' = mvShockwave' - , _btColor' = col - , _btPos' = p - , _btRad' = rad - , _btDam' = dam - , _btPush' = push - , _btMaxTime' = maxtime - , _btTimer' = maxtime - } - -mvShockwave' :: World -> Particle' -> (World, Maybe Particle') -mvShockwave' w pt - | _btTimer' pt <= 0 = (w, Nothing) - | otherwise - = (dams w , Just $ set btTimer' (t - 1) $ set ptDraw (const pic) pt) - where - r = _btRad' pt - p = _btPos' pt - push = _btPush' pt - dam = _btDam' pt - t = _btTimer' pt - tFraction = fromIntegral t / fromIntegral (_btMaxTime' pt) - pic = onLayer PtLayer $ uncurry translate p - $ color (_btColor' pt) $ thickCircle rad thickness - rad = r - (3/4) * r * tFraction - thickness = tFraction**2 * r - dams = over creatures (IM.map damCr) . flip (foldr damageBlocks) hitBlocks - hitBlocks = wallsOnCirc p rad $ wallsNearPoint p w - damageBlocks wall w - = case wall ^? blHP of - Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 1)) - w - (_blIDs wall) - _ -> w - damCr cr | dist (_crPos cr) p < rad + _crRad cr - = over (crState . crDamage) - ((:) $ PushDam dam (25 * push *.* safeNormalizeV (_crPos cr -.- p))) - cr - | otherwise = cr -moveShockWave :: Int -> Point2 -> Float -> Float -> Float -> World -> Particle' -> (World, Maybe Particle') -moveShockWave 0 _ _ _ _ w _ = (w, Nothing) -moveShockWave t p r push pushexp w pt - = (dams w, Just $ newupdate $ newpic pt ) - where newupdate = set ptUpdate' $ moveShockWave (t-1) p r push pushexp - newpic = set ptDraw (const $ onLayer PtLayer $ uncurry translate p - $ color cyan $ thickCircle rad thickness) - rad = r - (3/40) * r * fromIntegral t - thickness = (fromIntegral t)**2 * rad / 40 - dams = over creatures (IM.map damCr) . flip (foldr damageBlocks) hitBlocks - hitBlocks = wallsOnCirc p rad $ wallsNearPoint p w - damageBlocks wall w - = case wall ^? blHP of - Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 1)) - w - (_blIDs wall) - _ -> w - damCr cr | dist (_crPos cr) p < rad + _crRad cr - = over (crState . crDamage) - ((:) $ PushDam 1 (25 *.* safeNormalizeV (_crPos cr -.- p))) - cr - | otherwise = cr diff --git a/src/Dodge/WorldEvent/Shockwave.hs b/src/Dodge/WorldEvent/Shockwave.hs new file mode 100644 index 000000000..27e7bf910 --- /dev/null +++ b/src/Dodge/WorldEvent/Shockwave.hs @@ -0,0 +1,114 @@ +module Dodge.WorldEvent.Shockwave + ( makeShockwaveAt + , inverseShockwaveAt + ) + where +import Dodge.Data +import Dodge.Base +import Geometry +import Picture + +import qualified Data.IntMap.Strict as IM +import Control.Lens + +makeShockwaveAt + :: [Int] -- ^ IDs of invulnerable creatures. + -> Point2 -- ^ Center of shockwave. + -> Float -- ^ Maximal radius. + -> Int -- ^ Damage caused per frame. + -> Float -- ^ Amount of pushback per frame. + -> Color -- ^ Color of shockwave. + -> World -- ^ Start world. + -> World +makeShockwaveAt is p rad dam push col = over particles' ((:) theShockwave) + where theShockwave = shockwaveAt is p rad dam push col 10 + +shockwaveAt + :: [Int] -- ^ IDs of invulnerable creatures. + -> Point2 -> Float -> Int -> Float -> Color -> Int -> Particle' +shockwaveAt is p rad dam push col maxtime + = Shockwave' + { _ptDraw = drawShockwave + , _ptUpdate' = mvShockwave' is + , _btColor' = col + , _btPos' = p + , _btRad' = rad + , _btDam' = dam + , _btPush' = push + , _btMaxTime' = maxtime + , _btTimer' = maxtime + } + +drawShockwave :: Particle' -> Picture +drawShockwave pt = pic + where + pic = onLayer PtLayer $ uncurry translate p + $ color (_btColor' pt) $ thickCircle rad thickness + p = _btPos' pt + r = _btRad' pt + thickness = tFraction**2 * r + rad = r - (3/4) * r * tFraction + tFraction = fromIntegral t / fromIntegral (_btMaxTime' pt) + t = _btTimer' pt + +mvShockwave' + :: [Int] -- ^ IDs of invulnerable creatures. + -> World -> Particle' -> (World, Maybe Particle') +mvShockwave' is w pt + | _btTimer' pt <= 0 = (w, Nothing) + | otherwise + = (dams w , Just $ set btTimer' (t - 1) pt) -- $ set ptDraw (const pic) pt) + where + r = _btRad' pt + p = _btPos' pt + push = _btPush' pt + dam = _btDam' pt + t = _btTimer' pt + tFraction = fromIntegral t / fromIntegral (_btMaxTime' pt) + rad = r - (3/4) * r * tFraction + dams = over creatures (IM.map damCr) . flip (foldr damageBlocks) hitBlocks + hitBlocks = wallsOnCirc p rad $ wallsNearPoint p w + damageBlocks wall w + = case wall ^? blHP of + Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 1)) + w + (_blIDs wall) + _ -> w + damCr cr | _crID cr `elem` is = cr + | dist (_crPos cr) p < rad + _crRad cr + = over (crState . crDamage) + ((:) $ PushDam dam (25 * push *.* safeNormalizeV (_crPos cr -.- p))) + cr + | otherwise = cr + +------------------------------------------------- + +inverseShockwaveAt :: Point2 -> Float -> Int -> Float -> Float -> World -> World +inverseShockwaveAt p rad dam push pushexp = over particles' ((:) theShockwave) + where theShockwave + = Particle' + { _ptDraw = const blank + , _ptUpdate' = moveInverseShockWave 10 p rad push pushexp + } +moveInverseShockWave :: Int -> Point2 -> Float -> Float -> Float -> World -> Particle' -> (World, Maybe Particle') +moveInverseShockWave 0 _ _ _ _ w _ = (w, Nothing) +moveInverseShockWave t p r push pushexp w pt + = (dams w, Just $ newupdate $ newpic pt ) + where newupdate = set ptUpdate' $ moveInverseShockWave (t-1) p r push pushexp + newpic = set ptDraw (const $ onLayer PtLayer $ uncurry translate p + $ color cyan $ thickCircle rad thickness) + rad = r - (4/40) * r * fromIntegral (10 - t) + thickness = (fromIntegral (10 - t))**2 * rad / 40 + dams = over creatures (IM.map damCr) . flip (foldr damageBlocks) hitBlocks + hitBlocks = wallsOnCirc p rad $ wallsNearPoint p w + damageBlocks wall w + = case wall ^? blHP of + Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 1)) + w + (_blIDs wall) + _ -> w + damCr cr | dist (_crPos cr) p < rad + _crRad cr + = over (crState . crDamage) + ((:) $ PushDam 1 (25 *.* safeNormalizeV (p -.- _crPos cr))) + cr + | otherwise = cr diff --git a/src/Geometry/Intersect.hs b/src/Geometry/Intersect.hs index e43b1fdcf..294219b11 100644 --- a/src/Geometry/Intersect.hs +++ b/src/Geometry/Intersect.hs @@ -115,17 +115,20 @@ ratIntersectLineLine a b c d = fmap toNumPoint2 $ myIntersectLineLine (toRatPoin toNumPoint2 (x,y) = (fromRational x, fromRational y) f = toRatPoint2 . roundPoint2 --- | Round the floats within a 'Point2' to the nearest integer. --- Rounding jumps after intervals of .5: --- --- >>> roundPoint (0.5,0.5001) --- (0.0,1.0) --- --- but is symmetric around 0: --- --- >>> roundPoint2 (0.5,-0.5) --- (0.0,0.0) --- +{- | Round the floats within a 'Point2' to the nearest integer. +__Examples__ +Rounding jumps after intervals of .5: + +>>> roundPoint (0.5,0.5001) +(0.0,1.0) + +but is symmetric around 0: + +>>> roundPoint2 (0.5,-0.5) +(0.0,0.0) + +-} + roundPoint2 :: Point2 -> Point2 roundPoint2 (x,y) = (fromIntegral $ round x,fromIntegral $ round y) From 772103f92cf3852faf338875800097f46fd89950 Mon Sep 17 00:00:00 2001 From: jgk Date: Mon, 5 Apr 2021 11:36:54 +0200 Subject: [PATCH 4/8] 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 From 7b3bda91c65494fcfdb1ba8d204757a5864bb38a Mon Sep 17 00:00:00 2001 From: jgk Date: Mon, 5 Apr 2021 11:37:10 +0200 Subject: [PATCH 5/8] Modularise items --- src/Dodge/Item.hs | 53 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 53 insertions(+) create mode 100644 src/Dodge/Item.hs diff --git a/src/Dodge/Item.hs b/src/Dodge/Item.hs new file mode 100644 index 000000000..5a94aeae7 --- /dev/null +++ b/src/Dodge/Item.hs @@ -0,0 +1,53 @@ +module Dodge.Item + where + +import Dodge.Data +import Dodge.Base +import Dodge.Default +import Picture + +keyToken :: Int -> Item +keyToken n = defaultEquipment + { _itIdentity = Generic + , _itName = "KEYTOKEN "++show n + , _itMaxStack = 5 + , _itAmount = 1 + , _itFloorPict = setDepth 0.5 $ keyPic + , _itEquipPict = \cr _ -> setDepth 0 $ translate (-5) (-5) $ rotate (pi/2.5) keyPic + , _itEffect = NoItEffect + , _itHammer = HammerUp + , _itID = Nothing + , _itAimingSpeed = 1 + , _itAimingRange = 0 + , _itZoom = defaultItZoom + , _itInvColor = yellow + , _itInvDisplay = _itName + } +keyPic = color green $ + pictures [translate (-4) 0 $ thickCircle 4 2 + ,lineOfThickness 2 [(0,0),(8,0),(8,-4)] + ,lineOfThickness 2 [(4,0),(4,-4)] + ] + +latchkey :: Int -> Item +latchkey n = defaultEquipment + { _itIdentity = Generic + , _itName = "KEY "++show n + , _itMaxStack = 1 + , _itAmount = 1 + , _itFloorPict = setDepth 0.5 $ latchkeyPic + , _itEquipPict = \cr _ -> setDepth 0 $ 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)] + ] From a7e56d727d2a56c297785769a6b029c3ebd82f38 Mon Sep 17 00:00:00 2001 From: jgk Date: Mon, 5 Apr 2021 12:55:52 +0200 Subject: [PATCH 6/8] Haddock --- src/Sound.hs | 43 +++++++++++++++++++++++++------------------ 1 file changed, 25 insertions(+), 18 deletions(-) diff --git a/src/Sound.hs b/src/Sound.hs index 703b44152..c5b4c6274 100644 --- a/src/Sound.hs +++ b/src/Sound.hs @@ -2,8 +2,10 @@ 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. +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 +keep track of which sounds are playing. Uses SDL.Mixer. -} module Sound @@ -18,11 +20,19 @@ import Control.Monad import Control.Lens {- | Play sounds from a list of indices. -Each sound is played once if there is a free channel. +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. + -} +playAndUpdate :: Ord a => M.Map a Sound -> SoundData a -> IO (SoundData a) +playAndUpdate new sd = playSounds $ over playingSounds (updatePlaying new) sd + {- | Given a chunk, attempt to play this on a free channel a given number of times. Returns 'Just' the channel if succeeds. -} @@ -44,23 +54,24 @@ playSoundIfFree c s = case _soundTime s of f :: Maybe Mix.Channel -> Maybe Sound f = fmap ( \chan -> s & soundChannel ?~ chan) -{- Stop a channel if it was playing. +{- | 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 -{- Play a sound according to it's specification. +{- | 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. + 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. -} -playSound :: SoundData a -> Sound -> IO (Maybe Sound) -playSound sd s = case _soundChannel s of +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) @@ -70,14 +81,14 @@ playSound sd s = case _soundChannel s of ) Nothing -> playSoundIfFree (_loadedChunks sd IM.! _soundType s) s -{- Play all sounds and create new sound data. +{- | Play all sounds and create new sound data. -} playSounds :: SoundData a -> IO (SoundData a) playSounds sd = do - newSounds <- mapM (playSound sd) (_playingSounds sd) + 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. +{- | 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 @@ -85,7 +96,3 @@ 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 From f7e0b40cd5451790317ccd655cf17e93b302727a Mon Sep 17 00:00:00 2001 From: jgk Date: Mon, 5 Apr 2021 14:34:32 +0200 Subject: [PATCH 7/8] Tweak sound --- src/Dodge/SoundLogic.hs | 8 +++++--- src/Sound.hs | 33 ++++++++++++++++++++++++++++++++- src/Sound/Preload.hs | 11 ++++++----- 3 files changed, 43 insertions(+), 9 deletions(-) diff --git a/src/Dodge/SoundLogic.hs b/src/Dodge/SoundLogic.hs index e61b646d1..27eae8a2f 100644 --- a/src/Dodge/SoundLogic.hs +++ b/src/Dodge/SoundLogic.hs @@ -19,9 +19,10 @@ soundOnceOrigin :: Int -> SoundOrigin -> World -> World soundOnceOrigin sType so = over sounds (M.insertWith (flip const) so sound) where sound = Sound - { _soundType = sType + { _soundChunkID = sType , _soundTime = Nothing , _soundFadeTime = 0 + , _soundIsFadingOut = False , _soundChannel = Nothing , _soundPos = Nothing } @@ -30,8 +31,9 @@ soundFrom :: SoundOrigin -> Int -> Int -> Int -> World -> World soundFrom so sType time fadeTime w = over sounds (M.insertWith f so sound) w where sound = Sound - { _soundType = sType + { _soundChunkID = sType , _soundTime = Just time + , _soundIsFadingOut = False , _soundFadeTime = fadeTime , _soundChannel = Nothing , _soundPos = Nothing @@ -43,7 +45,7 @@ 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 { _soundType = sType + where sound = Sound { _soundChunkID = sType , _soundTime = Nothing , _soundFadeTime = fadeTime , _soundChannel = Nothing diff --git a/src/Sound.hs b/src/Sound.hs index c5b4c6274..08dac24e7 100644 --- a/src/Sound.hs +++ b/src/Sound.hs @@ -33,6 +33,33 @@ there may be a leak in the current typical usage. playAndUpdate :: Ord a => M.Map a Sound -> SoundData a -> IO (SoundData a) playAndUpdate new sd = playSounds $ over playingSounds (updatePlaying new) sd +--updateSound :: Sound -> Sound -> IO Sound +--updateSound newS oldS +-- | _soundIsFadingOut oldS +-- = Mix.playOn i times +-- | otherwise = newS & soundChannel .~ _soundChannel oldS + +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 + +decrimentTimer :: Sound -> IO Sound +decrimentTimer s = case _soundTime s of + Just t | t > 0 -> return $ s & soundTime ?~ t - 1 + | otherwise -> fadeOutMaybe (_soundChannel s) (_soundFadeTime s) + >> return (s & soundTime .~ Nothing + & soundIsFadingOut .~ True) + +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 + {- | Given a chunk, attempt to play this on a free channel a given number of times. Returns 'Just' the channel if succeeds. -} @@ -61,6 +88,10 @@ 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: @@ -79,7 +110,7 @@ updateOrStartSound sd s = case _soundChannel s of then return (Just s) else return Nothing ) - Nothing -> playSoundIfFree (_loadedChunks sd IM.! _soundType s) s + Nothing -> playSoundIfFree (_loadedChunks sd IM.! _soundChunkID s) s {- | Play all sounds and create new sound data. -} diff --git a/src/Sound/Preload.hs b/src/Sound/Preload.hs index ee0e15de8..a8d26799c 100644 --- a/src/Sound/Preload.hs +++ b/src/Sound/Preload.hs @@ -12,11 +12,12 @@ data SoundData a = SoundData ,_playingSounds :: M.Map a Sound } data Sound = Sound - { _soundTime :: Maybe Int - , _soundFadeTime :: Int - , _soundChannel :: Maybe Mix.Channel - , _soundPos :: Maybe Point2 - , _soundType :: Int + { _soundTime :: Maybe Int + , _soundFadeTime :: Int + , _soundIsFadingOut :: Bool + , _soundChannel :: Maybe Mix.Channel + , _soundPos :: Maybe Point2 + , _soundChunkID :: Int } deriving (Eq,Ord,Show) From ebcac3906988960610251fd7c4c70294e06b74f2 Mon Sep 17 00:00:00 2001 From: jgk Date: Tue, 6 Apr 2021 14:53:40 +0200 Subject: [PATCH 8/8] Refactor sound --- app/Main.hs | 6 +- src/Dodge/Base.hs | 188 ++++++++++++++++++++++++++-------------- src/Dodge/SoundLogic.hs | 41 +++++---- src/Sound.hs | 188 ++++++++++++++++++++-------------------- src/Sound/Preload.hs | 8 +- 5 files changed, 250 insertions(+), 181 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index f4515a0ba..df1793804 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -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) diff --git a/src/Dodge/Base.hs b/src/Dodge/Base.hs index 21cfeb529..0c0380c44 100644 --- a/src/Dodge/Base.hs +++ b/src/Dodge/Base.hs @@ -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) diff --git a/src/Dodge/SoundLogic.hs b/src/Dodge/SoundLogic.hs index 27eae8a2f..a0d633eda 100644 --- a/src/Dodge/SoundLogic.hs +++ b/src/Dodge/SoundLogic.hs @@ -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 diff --git a/src/Sound.hs b/src/Sound.hs index 08dac24e7..f158043a2 100644 --- a/src/Sound.hs +++ b/src/Sound.hs @@ -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} diff --git a/src/Sound/Preload.hs b/src/Sound/Preload.hs index a8d26799c..7ba4d541c 100644 --- a/src/Sound/Preload.hs +++ b/src/Sound/Preload.hs @@ -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