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

app/Main.hs

@@ -1,31 +1,33 @@
 module Main where
-import           Dodge.Data
+import Loop
+import Shader
+import LoadConfig
 import Dodge.Default
-import           Dodge.Event
+import Dodge.Data
-import           Dodge.Floor
 import Dodge.Initialisation
+import Dodge.Rooms
 import Dodge.Layout
+import Dodge.Update
+import Dodge.Event
+import Dodge.Render
+import Dodge.Menu
+import Dodge.Floor
 import Dodge.LoadConfig
 import Dodge.LoadSound
-import           Dodge.Menu
-import           Dodge.Render
-import           Dodge.Rooms
-import           Dodge.Update
-import           LoadConfig
-import           Loop
 import Picture
-import           Picture.Preload
 import Picture.Render
-import           Preload
+import Picture.Preload
-import           Shader
 import Sound
+import Preload
 import Sound.Preload
 
 import           Control.Concurrent
 import           Control.Lens
 import           Foreign                   (Word32)
 
-import           Control.Monad             (void, when)
+import Control.Monad (when,void)
+ 
+import System.Random
 
 import           System.Random
 
@@ -53,9 +55,9 @@ 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)
+            playSoundQueue (_loadedChunks $ _soundData preData) (_soundQueue w)
-            newSoundData <- playAndUpdate (_sounds w) (_soundData preData)
+            newPlayingSounds <- playAndUpdate (_soundData preData) (_sounds w)
 
             endTicks <- SDL.ticks
             let lastFrameTicks = _frameTimer preData
@@ -67,7 +69,7 @@ main = do
                         )
 
 
-            return $ preData & soundData  .~ newSoundData
+            return $ preData & soundData . playingSounds .~ newPlayingSounds
                              & frameTimer .~ endTicks
         )
         (flip $ menuEvents handleEvent)

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)

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
+{- | Looks for first collision of a point with walls.
--- if found, gives point and colour of wall
+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
+{- | Looks for first collision of a point with walls.
--- if found, gives point, and normal and colour of wall
+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
+-- | As for 'collidePointCreatures', only increases the radius of creatures by a
---fixed amount, thus collides a moving circle with creaures
+--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,34 +624,45 @@ 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
+-- | Returns the first creature, if any, that a point intersects with, gives point
---in creature on line
+--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
+  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 $
+collideCircCrsPoint p1 p2 rad w 
-                                IM.mapMaybe (\x -> 
+    = 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
+  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 $
+collidePointCrsWithoutPoint cid p1 p2 w 
-                                IM.mapMaybe (\x -> 
+    = 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
+  where 
+    csndsnd (_,(_,a)) (_,(_,b)) = compare a b
     f (cID,(p,_)) = (p,cID)
 
 circOnSomeWall :: Point2 -> Float -> World -> Bool
@@ -664,36 +677,56 @@ 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 
+crsOnLine p1 p2 w 
-                        $ IM.filter (\cr -> circOnSeg p1 p2 (_crPos cr) (_crRad cr))
+    = 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 
+crsOnThickLine thickness p1 p2 w 
-                        $ IM.filter (\cr -> circOnSeg p1 p2 (_crPos cr) (_crRad cr + thickness))
+    = 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
+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 
+ 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
-nearestCrInFront :: Point2 -> Float -> Float -> World -> Maybe Creature
+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
+  where 
+    rec = [p
           ,pR
           ,pR1
           ,pL1
@@ -704,15 +737,25 @@ nearestCrInFront p dir x w
     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 *.* (normV . vNormal $ y -.- x)
-          x' = x +.+ n
-          y' = y +.+ n
 
-wallsLOS :: Foldable t => t [Point2] -> Point2 -> Point2 -> Bool
+{- | given a target and a start point, shift toward the end point by a given
-{-# INLINE wallsLOS #-}
+amount.
-wallsLOS !ls !c !p = all (\l -> wallLOS l c p) ls
+If close enough, end up on the end point
-
+-}
-mvPointTowardAtSpeed :: Float -> Point2 -> Point2 -> Point2
+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)
 

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
+        ,poisonSprayer
-        ,teslaGrenade
         ,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]

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
@@ -223,7 +223,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)
@@ -232,8 +232,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 
-blinkShockwave p = makeShockwaveAt p 40 1 2 cyan 
+    :: 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

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)]
+                       ]

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)
 
@@ -1581,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)]
-                       ]
 
 
 -- }}}

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

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,9 +21,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
+        , _soundStatus      = ToStart
         , _soundChannel     = Nothing
         , _soundPos         = Nothing
         }
@@ -30,8 +33,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
+        , _soundStatus      = ToStart
         , _soundFadeTime    = fadeTime
         , _soundChannel     = Nothing
         , _soundPos         = Nothing
@@ -43,8 +47,11 @@ 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
+        , _soundStatus      = ToStart
         , _soundFadeTime    = fadeTime
         , _soundChannel     = Nothing
         , _soundPos         = Nothing

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) 

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

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

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'.
@@ -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 
@@ -132,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 
@@ -152,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 

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)

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)

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]
+-- | If two lines intersect, return 'Just' that point.
-intersectSegBezquad = undefined
-
 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
+-- | Due to floating point issues, 'intersectSegSeg'' is not always 
--- the cases
+-- accurate---'myIntersectSegSeg'
--- it is, however, slow
+-- 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,46 @@ 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.
+__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)
 
+-- | 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
+

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
+{- | Normalize a vector safely: on (0,0) return (0,0).
-{-# INLINE normV #-}
+ -}
-normV (0,0) = (0,0)
+safeNormalizeV :: Point2 -> Point2
-normV p = (1/magV p ) *.* p
+{-# 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
 

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
 

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.
 -}

src/Sound.hs

@@ -1,21 +1,125 @@
-module Sound
+{-|
-    where
+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.
+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 (
+    -- * Simple (One-Shot) Playback
+      playSoundQueue
+    -- * Complex Playback
+    , playAndUpdate
+    ) 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.Monad.Trans
+import Control.Monad.Trans.Maybe
 import Control.Lens
+{- | 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.
+The Map of updated sound specifications is returned.
 
-playSoundQueue :: SoundData a -> [Int] -> IO ()
+New sounds with the same keys as 
-playSoundQueue sd ns = forM_ ns $ \n -> playIfFree (_loadedChunks sd IM.! n) Mix.Once
+already playing sounds are merged in the following manner:
 
--- this can be cleaned up
+    * 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 => SoundData a -> M.Map a Sound -> IO (M.Map a Sound)
+playAndUpdate sData newSounds 
+    = updateSounds (_loadedChunks sData) (mergeSounds newSounds (_playingSounds sData))
+
+mergeSounds :: Ord a => M.Map a Sound -> M.Map a Sound -> M.Map a Sound
+mergeSounds as bs = M.unionWith mergeSound as bs
+
+mergeSound :: Sound -> Sound -> Sound
+mergeSound newS oldS 
+    | _soundStatus oldS == FadingOut
+                = newS & soundChannel .~ _soundChannel oldS
+    | otherwise = newS & soundChannel .~ _soundChannel oldS
+                       & soundStatus  .~ _soundStatus oldS
+
+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
+                                         & soundStatus .~ FadingOut)
+    Nothing -> return s
+
+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.
+-}
 playIfFree :: Mix.Chunk -> Mix.Times -> IO (Maybe Mix.Channel)
 playIfFree c times = do
     mayChan <- Mix.getAvailable Mix.DefaultGroup
@@ -23,43 +127,3 @@ playIfFree c times = do
         Nothing -> return Nothing
         Just i  -> Just <$> Mix.playOn i times c
 
-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 .~ Just chan))
-
-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
-playSound :: SoundData a -> Sound -> IO (Maybe Sound)
-playSound 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.! _soundType s) s
-
-playSounds :: SoundData a -> IO (SoundData a)
-playSounds sd = do
-    newSounds <- mapM (playSound sd) (_playingSounds sd)
-    return $ sd & playingSounds .~ M.mapMaybe id newSounds
-
-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}
-
-playAndUpdate :: Ord a => M.Map a Sound -> SoundData a -> IO (SoundData a)
-playAndUpdate new sd = playSounds $ over playingSounds (updatePlaying new) sd

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,9 +20,10 @@ data SoundData a = SoundData
 data Sound = Sound 
     { _soundTime        :: Maybe Int
     , _soundFadeTime    :: Int
+    , _soundStatus      :: SoundStatus
     , _soundChannel     :: Maybe Mix.Channel
     , _soundPos         :: Maybe Point2
-    , _soundType :: Int
+    , _soundChunkID     :: Int
     }
   deriving (Eq,Ord,Show)