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

bench/Bench.hs

@@ -1,4 +1,25 @@
 import Criterion.Main
 
+import Dodge.RandomHelp
+
+import Geometry
+
+import System.Random
+import Control.Monad.State
+import Data.List (zip4)
+
 main :: IO ()
-main = putStrLn "h"
+main = do
+    [ps1, ps2, ps3, ps4] <- mapM randomPoints [500,500,500,500]
+    fs <- sequence $ replicate 500 (randomRIO (1,20))
+    defaultMain
+        [ bgroup "circLine tests"
+            [ bench "circLine" $ nf (map $ uncurry4 circOnLine) (zip4 ps1 ps2 ps3 fs)           
+            , bench "circLine'" $ nf (map $ uncurry4 circOnLine') (zip4 ps1 ps2 ps3 fs)           
+            ]
+        ]
+
+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)

package.yaml

@@ -46,6 +46,7 @@ dependencies:
 - linear
 - aeson
 - directory
+- QuickCheck
 
 library:
   source-dirs: src
@@ -84,6 +85,7 @@ benchmarks:
     loop-benchmarks:
         dependencies:
         - criterion
+        - loop
         ghc-options:
         - -threaded
         - -O2

src/Dodge/AIs.hs

@@ -1587,7 +1587,7 @@ basicShooterAI w (f,g) cr =
                             -> ( (f , g)
                                , Just $ turnCloseSlow ypos cr
                                )  -- no longer chase if see you when reloading
-                                                    -- $ replaceAction [] w
+                                                    -- -$ replaceAction [] w
                        | otherwise -> ( (f , g) , Just cr)
         (Search i:gls) | i == 0 -> ( (f , g) , replaceAction [] cr)
                        | otherwise 

src/Dodge/Base.hs

@@ -180,7 +180,7 @@ wallOnLine p1 p2 ws
 
 wallsOnCirc :: Point2 -> Float -> IM.IntMap Wall -> [Wall]
 wallsOnCirc p r wls = IM.elems $ IM.filter f wls
-    where f wl = circOnLine (_wlLine wl !! 0) (_wlLine wl !! 1) p r
+    where f wl = circOnSeg (_wlLine wl !! 0) (_wlLine wl !! 1) p r
 
 wallsNearPoint :: Point2 -> World -> IM.IntMap Wall
 wallsNearPoint p w =  IM.unions [f b $ f a $ _wallsZone w | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]]
@@ -653,11 +653,11 @@ collidePointCrsWithoutPoint cid p1 p2 w = fmap f $ listToMaybe $ sortBy (csndsnd
           f (cID,(p,_)) = (p,cID)
 
 circOnSomeWall :: Point2 -> Float -> World -> Bool
-circOnSomeWall p rad w = any (\(x:y:_) -> circOnLine x y p rad) 
+circOnSomeWall p rad w = any (\(x:y:_) -> circOnSeg x y p rad) 
                             $ fmap _wlLine $ IM.elems $ wallsNearPoint p w
 
 crsNearLine :: Float -> [Point2] -> World -> Bool
-crsNearLine d (p1:p2:_) w = any (\c -> circOnLine p1 p2 (_crPos c) (d + _crRad c)) 
+crsNearLine d (p1:p2:_) w = any (\c -> circOnSeg p1 p2 (_crPos c) (d + _crRad c)) 
                                 $ IM.filter (\cr -> _crMass cr > 4) $ _creatures w
 
 crsNearPoint :: Float -> Point2 -> World -> Bool
@@ -665,12 +665,12 @@ crsNearPoint d p w = any (\c -> dist (_crPos c) p < (d + _crRad c)) (_creatures
 
 crsOnLine :: Point2 -> Point2 -> World -> [Creature]
 crsOnLine p1 p2 w = IM.elems 
-                        $ IM.filter (\cr -> circOnLine p1 p2 (_crPos cr) (_crRad cr))
+                        $ 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 -> circOnLine p1 p2 (_crPos cr) (_crRad cr + thickness))
+                        $ IM.filter (\cr -> circOnSeg p1 p2 (_crPos cr) (_crRad cr + thickness))
                         $ _creatures w
 
 nearestCrInRad :: Point2 -> Float -> World -> Maybe Creature

src/Dodge/Creature/Property.hs

@@ -14,7 +14,7 @@ crIsArmouredFrom p cr
 -- even though angleVV can generate NaN, the comparison seems to deal with it
 
 crOnSeg :: Point2 -> Point2 -> Creature -> Bool
-crOnSeg p1 p2 cr = circOnLine p1 p2 (_crPos cr) (_crRad cr)
+crOnSeg p1 p2 cr = circOnSeg p1 p2 (_crPos cr) (_crRad cr)
 
 crNearSeg :: Float -> Point2 -> Point2 -> Creature -> Bool
-crNearSeg d p1 p2 cr = circOnLine p1 p2 (_crPos cr) (_crRad cr + d)
+crNearSeg d p1 p2 cr = circOnSeg p1 p2 (_crPos cr) (_crRad cr + d)

src/Dodge/Graph.hs

@@ -0,0 +1,21 @@
+module Dodge.Graph
+  where
+import Data.Function (on)
+import Data.List
+
+import Data.Graph
+
+pairsToIncidence :: (Eq a,Ord a) => [(a,a)] -> [(a,[a])]
+pairsToIncidence = map ((\(xs,ys) -> (head xs,ys)) . unzip)
+                     . groupBy ( (==) `on` fst)
+                     . sort
+
+incidenceToFunction :: Eq a => [(a,[a])] -> a -> [a]
+incidenceToFunction xs a = case lookup a xs of Just ys -> ys
+                                               Nothing -> []
+
+mkNode :: (a,[a]) -> (a,a,[a])
+mkNode (x,xs) = (x,x,xs)
+
+pairsToSCC :: (Eq a, Ord a) => [(a,a)] -> [SCC a]
+pairsToSCC = stronglyConnComp . map mkNode . pairsToIncidence

src/Dodge/Initialisation.hs

@@ -20,7 +20,10 @@ initializeWorld :: World -> World
 initializeWorld w = w
 
 firstWorld :: IO World
-firstWorld = return $ generateFromTree lev1 $ initialWorld
+firstWorld = do
+    i <- randomRIO (0,5000)
+    putStrLn $ "Random seed for level generation: " ++ show ( i :: Int)
+    return $ generateFromTree lev1 $ initialWorld {_randGen = mkStdGen i}
 
 initialWorld :: World
 initialWorld = defaultWorld

src/Dodge/Item/Weapon.hs

@@ -929,7 +929,7 @@ reflect a b = a + 2*(a-b)
 moveGrenade :: Int -> Float -> Int -> World -> World
 moveGrenade 0 dir pID w = over projectiles (IM.delete pID) 
                             $ explosion (_pjPos (_projectiles w IM.! pID)) 
-                            -- $ set (pointToItem (_itemPositions w IM.! wpID) . itEquipPict) 
+                            -- set (pointToItem (_itemPositions w IM.! wpID) . itEquipPict) 
                             --      (drawWeapon $ grenadePic 50)
                             w
   where
@@ -1493,7 +1493,7 @@ explodeRemoteBomb itid pjid n w
         $ resetPict
 --        $ resetScope
         $ makeExplosionAt (_pjPos (_projectiles w IM.! pjid)) w
-        -- $ makeShrapnelBombAt (_pjPos (_projectiles w IM.! pjid)) w
+        -- - $ makeShrapnelBombAt (_pjPos (_projectiles w IM.! pjid)) w
   where 
     resetName = set (creatures . ix n . crInv . ix j . itName) "REMOTEBOMB"
     resetPict = set (creatures . ix n . crInv . ix j . itEquipPict ) 
@@ -1656,7 +1656,7 @@ updateTractor colID time i w
                     $ over floorItems (IM.map tractFlIt) 
                         w
     | otherwise = over projectiles (IM.delete i) w
-    where tractCr cr | circOnLine p1 p2 cP 10
+    where tractCr cr | circOnSeg p1 p2 cP 10
                                  = over crPos (\p -> 
                                                 p -.- m *.* ((0.3/ x) *.* q +.+ (f y *.* p4))
                                               ) cr
@@ -1666,7 +1666,7 @@ updateTractor colID time i w
                       cP = _crPos cr
                       m | dist cP p1 < 350 = 1
                         | otherwise        = (400 - dist cP p1) / 50
-          tractFlIt it | circOnLine p1 p2 iP 10
+          tractFlIt it | circOnSeg p1 p2 iP 10
                                  = over flItPos  (\p -> p -.- m *.* 
                                                             ( (0.3/ x) *.* q +.+ (f y *.* p4))
                                                  ) it

src/Dodge/Layout.hs

@@ -8,7 +8,7 @@ import Dodge.Data
 import Dodge.LevelGen
 import Dodge.Base
 import Dodge.RandomHelp
-import Dodge.Path
+import Dodge.Graph
 import Dodge.Layout.Tree
 import Dodge.Room.Data
 import Dodge.Default
@@ -64,10 +64,10 @@ makePath = concat . map _rmPath . flatten
 -- consider nubbing walls after dividing them
 wallsFromTree :: Tree Room -> IM.IntMap Wall
 wallsFromTree t = 
-    createInnerWalls 
+--    createInnerWalls 
-    . divideWalls 
+    divideWalls 
     . assignKeys 
-    . foldr cutWalls [] -- $ map (map (g . roundPoint2)) 
+    . foldr cutWalls [] -- map (map (g . roundPoint2)) 
 --    . map (map roundPoint2)
     $ (concatMap _rmPolys $ flatten t)
   where

src/Dodge/Layout/LockAndKey.hs

@@ -0,0 +1,14 @@
+module Dodge.Layout.LockAndKey
+  where
+
+data Key = Key Int
+
+-- data Area 
+--     = Area 
+--         { _arID     :: Int    
+--         , _arLinks  :: [Int]
+--         , _arMonsters   :: [Creature]
+--         , _arItems      :: [Item]
+--         }
+
+--generateGraph 

src/Dodge/LevelGen.hs

@@ -3,7 +3,7 @@
 module Dodge.LevelGen 
     ( module Dodge.LevelGen
     , cutWalls
-    , createInnerWalls
+--    , createInnerWalls
     , pairsToGraph
     , makeButton
     , makeSwitch

src/Dodge/LevelGen/InnerWalls.hs

@@ -0,0 +1,46 @@
+module Dodge.LevelGen.InnerWalls
+  where
+import Dodge.Data
+import Dodge.Base
+
+import Geometry
+
+import Control.Lens
+import qualified Data.IntMap as IM
+
+------------------------------------------------------------------------------------
+-- idea: create inner walls to draw and to cast shadows
+createInnerWalls :: IM.IntMap Wall -> IM.IntMap Wall
+createInnerWalls wls = IM.map (createInnerWall wls) wls
+
+createInnerWall :: IM.IntMap Wall -> Wall -> Wall
+createInnerWall walls wl = wl & wlLine %~ \l -> l ++ [wlL,wlR]
+  where wl0 = _wlLine wl !! 0
+        wl1 = _wlLine wl !! 1
+        wlLeft = findWallLeft wl walls
+        wlRight = findWallRight wl walls
+        wlN = normalizeV $ vNormal $ wl1 -.- wl0
+        rN = normalizeV $ vNormal $ (_wlLine wlRight !! 1) -.- (_wlLine wlRight !! 0)
+        lN = normalizeV $ vNormal $ (_wlLine wlLeft  !! 1) -.- (_wlLine wlLeft  !! 0)
+        wlR = wl0 +.+ 20 *.* normalizeV (wlN +.+ rN)
+        wlL = wl1 +.+ 20 *.* normalizeV (wlN +.+ lN)
+
+findWallLeft :: Wall -> IM.IntMap Wall -> Wall
+findWallLeft wl wls = case filter (\w -> _wlID w /= _wlID wl) $ IM.elems $ findWallsLeft (_wlLine wl !! 1) wls of
+    [w] -> w
+    wls   -> error $ "findWallLeft: " ++ show (map _wlID wls)
+                                                                 ++ " wlLines: "++ show (map _wlLine wls)
+
+findWallRight :: Wall -> IM.IntMap Wall -> Wall
+findWallRight wl wls = case filter (\w -> _wlID w /= _wlID wl) $ IM.elems $ findWallsRight (_wlLine wl !! 0) wls of
+    [w] -> w
+    wls   -> error $ "findWallRight: wall with ID " ++ show (_wlID wl) ++ " and points " ++
+                    show (_wlLine wl) ++ "\nhas a right corner with and only with the walls "
+                    ++ show (map _wlID wls) ++ "\nwlLines "++ show (map _wlLine wls)
+                    ++ "\nUnless a wall has a corner with exactly one other wall, there is a problem"
+
+findWallsLeft :: Point2 -> IM.IntMap Wall -> IM.IntMap Wall
+findWallsLeft x wls = IM.filter (\wl -> dist x (_wlLine wl !! 0) < 1) wls
+
+findWallsRight :: Point2 -> IM.IntMap Wall -> IM.IntMap Wall
+findWallsRight x wls = IM.filter (\wl -> dist x (_wlLine wl !! 1) < 1) wls

src/Dodge/LevelGen/StaticWalls.hs

@@ -1,3 +1,7 @@
+{-|
+Module      : Dodge.LevelGen.StaticWalls
+Description : Concerns carving out of static walls to create the general room plan of the level.
+-}
 module Dodge.LevelGen.StaticWalls 
     where
 import Dodge.Data
@@ -10,6 +14,7 @@ import Control.Lens
 
 import Data.Function (on)
 
+import Data.Graph
 import Data.List
 import Data.Maybe
 import qualified Data.IntMap as IM
@@ -18,9 +23,22 @@ import qualified Data.Set as S
 
 type WallP = (Point2,Point2)
 
--- the following checks one of the corners of cut walls at each step
+-- | Cut out a polygon from a set of walls, and check for errors in the
+-- created walls.
+-- If created walls are not consistent, expand poly and retry.
 cutWalls :: [Point2] -> [WallP] -> [WallP]
 cutWalls ps wls = case mapMaybe (flip checkWallRight newWalls) newWalls of
+    [] -> newWalls
+    _  -> cutWalls (expandPolyBy 0.01 ps) wls
+  where
+    newWalls = cutWalls' ps wls
+    errsL = mapMaybe (flip checkWallLeft newWalls) newWalls
+
+-- | Cut out a polygon from a set of walls, and check for errors in the
+-- created walls.
+-- Give error if created walls are not consistent.
+cutWalls'' :: [Point2] -> [WallP] -> [WallP]
+cutWalls'' ps wls = case mapMaybe (flip checkWallRight newWalls) newWalls of
     [] -> newWalls
     errs -> error $ "during level generation function cutWalls: when cutting poly:\n" ++ show ps 
         ++ "\nRight corner errors:\n"
@@ -35,17 +53,42 @@ cutWalls ps wls = case mapMaybe (flip checkWallRight newWalls) newWalls of
     newWalls = cutWalls' ps wls
     errsL = mapMaybe (flip checkWallLeft newWalls) newWalls
 
+-- | Given a specific wall and list of walls, checks that the number of walls leaving the
+-- second point is the same as the number of walls entering the second point of
+-- the specific wall.
+-- On success returns Nothing, on failure returns Just the specific wall and the
+-- list of walls leaving the second point.
 checkWallRight :: WallP -> [WallP] -> Maybe (WallP,[WallP])
-checkWallRight (x,y) wls = case filter (\(a,b) -> a == y ) wls of
+checkWallRight (x,y) wls 
-    [w] -> Nothing
+    | length ins == length outs = Nothing
-    wls -> Just ((x,y), wls)
+    | otherwise                 = Just ((x,y), outs)
+  where
+    ins     = filter (\(a,b) -> b == y) wls
+    outs    = filter (\(a,b) -> a == y) wls
+-- | Given a specific wall and list of walls, checks that the number of walls leaving the
+-- first point is the same as the number of walls entering the first point of
+-- the specific wall.
+-- On success returns Nothing, on failure returns Just the specific wall and the
+-- list of walls leaving the first point.
 checkWallLeft :: WallP -> [WallP] -> Maybe (WallP,[WallP])
-checkWallLeft (x,y) wls = case filter (\(a,b) -> b == x ) wls of
+checkWallLeft (x,y) wls
-    [w] -> Nothing
+    | length ins == length outs = Nothing
-    wls -> Just ((x,y),wls)
+    | otherwise                 = Just ((x,y), outs)
+  where
+    ins     = filter (\(a,b) -> a == x) wls
+    outs    = filter (\(a,b) -> b == x) wls
 
--- given a polygon of points and collection of walls, cuts out the polygon
+-- | Given a polygon of points and collection of walls, cuts out the polygon.
--- ie returns a new set of walls with a hole determined by anticlockwise ordering of the points
+-- Ie returns a new set of walls with a hole determined by anticlockwise ordering of the points.
+-- The overall procedure is: 
+-- 1. split walls that intersect with the polygon into two 
+-- (possibly three if the wall extends across the polygon),
+-- 2. remove any created walls that are inside the polygon,
+-- 3. create the required new walls along the polygon boundary.
+-- 4. fuse wall endpoints that end up close to each or to polygon intersection points
+-- 5. remove any walls that ended up zero length after fusing
+-- 6. remove any duplicate walls
+-- Unclear behaviour if a line in the polygon is colinear with a wall.
 cutWalls' :: [Point2] -> [WallP] -> [WallP]
 cutWalls' qs walls = 
     nub
@@ -61,18 +104,19 @@ cutWalls' qs walls =
     (zs,cwals) = cutWallsWithPoints ps walls
     ps = orderPolygon qs
     rs = orderPolygon $ nub $ zs ++ qs
--- the overall procedure is: 
--- split walls that intersect with the polygon into two 
---      (possibly three if the wall extends across the polygon)
--- remove any created walls that are inside the polygon
--- create the required new walls along the polygon boundary
--- fuse wall endpoints that end up close to each or to polygon intersection points
--- remove any walls that ended up zero length after fusing
--- remove any duplicate walls
 
--- given a polygon expressed as a list of points and a collection of walls,
+-- | Given a value and a poly, pushes the poly points out from the center by the
--- returns: fst: points of the polygon's intersection with walls
+-- value amount.
---          snd: the collection of walls after cutting by the polygon
+expandPolyBy :: Float -> [Point2] -> [Point2]
+expandPolyBy x ps = map f ps
+  where
+    cp = (1/(fromIntegral (length ps))) *.* (foldr (+.+) (0,0) ps)
+    f p = p +.+ x *.* (p -.- cp)
+
+-- | Given a polygon expressed as a list of points and a collection of walls,
+-- returns: 
+-- fst: points of the polygon's intersection with walls
+-- snd: the collection of walls after cutting by the polygon.
 cutWallsWithPoints :: [Point2] -> [WallP] -> ([Point2], [WallP] )
 cutWallsWithPoints (p:ps) ws = foldr f ([],ws) (zip (p:ps) (ps++[p]))
   where 
@@ -81,12 +125,12 @@ cutWallsWithPoints (p:ps) ws = foldr f ([],ws) (zip (p:ps) (ps++[p]))
         , concatMap (cutWall p1 p2) ws'
         )
 
--- lists the points of intersection between a segment and collection of walls
+-- | List the points of intersection between a segment and collection of walls.
 cutWallsPoints :: Point2 -> Point2 -> [WallP] -> [Point2]
 --cutWallsPoints p1 p2 ws = mapMaybe (\(x:y:_) -> intersectExtendedSegSeg p1 p2 x y)
 cutWallsPoints p1 p2 ws = mapMaybe (uncurry $ myIntersectSegSeg p1 p2) ws
 
--- given a segment and a wall, split the wall into two if it crosses the segment
+-- | Given a segment and a wall, split the wall into two if it crosses the segment.
 cutWall :: Point2 -> Point2 -> WallP -> [WallP]
 cutWall p1 p2 (x,y) = case myIntersectSegSeg p1 p2 x y of
     Nothing -> [(x,y)]
@@ -95,60 +139,63 @@ cutWall p1 p2 (x,y) = case myIntersectSegSeg p1 p2 x y of
 addPolyWalls :: [Point2] -> [WallP] -> [WallP]
 addPolyWalls (q:qs) walls = foldr addPolyWall walls (zip (q:qs) (qs++[q]))
 
--- adds a wall if there is not already a wall on the clockwise normal to this wall
+-- | Add a new wall to a list of walls only if either
--- such that this existing wall faces towards the new wall
+-- 1. no wall already exists on the normal line from the new wall
+-- 2. any of the first existing walls hit on the normal line from the new wall
+-- face away from the new wall.
+-- The normal line is the line from the center point of the new wall outwards 
+-- along the clockwise normal of the new wall (currently 10000 units along)
 addPolyWall :: WallP -> [WallP] -> [WallP]
 addPolyWall (p1,p2) walls =
-    case maybeW of Just (x,y) -> if isLHS x y p3
+    case maybeWs of 
+        Just ws -> if all (\(x,y) -> isLHS x y p3) ws
                    then walls
                    else (p1,p2) : walls
         Nothing -> ((p1,p2) : walls)
   where 
     p3 = 0.5 *.* (p1 +.+ p2)
     p4 = p3 +.+ 10000 *.* vNormal (p2 -.- p1)
-    maybeW = listToMaybe 
+    maybeWs = -- listToMaybe .
-              . fst
+              fmap fst
-              . unzip
+              . fmap unzip
-              . sortBy (compare `on` (dist p3 . snd))
+              . listToMaybe
+              $ groupBy ((==) `on` (dist p3 . snd))
+                wlsP
+    wlsP :: [(WallP, Point2)]
+    wlsP = sortBy (compare `on` (dist p3 . snd))
               . catMaybes
               $ zipWith f walls maybes
     f a (Just b) = Just (a,b)
     f _ Nothing  = Nothing
     maybes = map (uncurry $ myIntersectSegSeg p3 p4) walls
 
--- intersects two segments, each extended by one unit in both directions
+-- | Given a list of points and a point, returns a point in the list if any is close
-intersectExtendedSegSeg p1 p2 a1 a2 = myIntersectSegSeg p1' p2' a1' a2'
+-- to the point.
-  where 
-    p1' = p1 +.+ normalizeV (p1 -.- p2)
-    p2' = p2 +.+ normalizeV (p2 -.- p1)
-    a1' = a1 +.+ normalizeV (a1 -.- a2)
-    a2' = a2 +.+ normalizeV (a2 -.- a1)
-
--- given a list of points and a point, returns a point in the list if any is close
--- enough to the point
 findClosePoint :: [Point2] -> Point2 -> Maybe Point2
 findClosePoint ps p = find (\q -> dist p q < 5) ps
 
+-- | Given a list of points and a point, returns the point if none in the list
+-- is close to the point.
 pointIfNotClose :: [Point2] -> Point2 -> Maybe Point2
 pointIfNotClose ps p = case findClosePoint ps p of
                         Nothing -> Just p
                         _       -> Nothing
 
--- fuses a point with one in a list if any are close enough
+-- | Fuses a point with one in a list if any are close enough.
 fusePoint :: [Point2] -> Point2 -> Point2
 fusePoint ps p = fromMaybe p $ findClosePoint ps p
 
--- given a list of points and wall, moves the wall to be on the points if it is
+-- | Given a list of points and wall, moves the wall to be on the points if it is
--- close to any of the points
+-- close to any of the points.
--- if either wall point is not moved, this point gets added to the list
+-- If either wall point is not moved, this point gets added to the list.
 fuseWall :: ([Point2], WallP) -> ([Point2], WallP)
 fuseWall (ps, (x,y)) = ( nub (x':y':ps) , (x',y') )
   where 
     x' = fusePoint ps x
     y' = fusePoint (x':ps) y
 
--- given list of points and collection of walls, fuses the wall ends if
+-- | Given list of points and collection of walls, fuses the wall ends if
--- they are close to the list of points or each other
+-- they are close to the list of points or each other.
 fuseWallsWith :: [Point2] -> [WallP] -> [WallP]
 fuseWallsWith zs ws = snd $ foldr fuseWalls' (zs, []) ws
   where 
@@ -156,47 +203,15 @@ fuseWallsWith zs ws = snd $ foldr fuseWalls' (zs, []) ws
         let (qs, w') = fuseWall (ps, w)
         in  (qs, w' :  ws)
 
+-- | Test if fst p == snd p.
 wallIsZeroLength (x,y) = x == y
 
+-- | Given a polygon and list of walls, removes walls inside the polygon.
 removeWallsInPolygon :: [Point2] -> [WallP] -> [WallP]
 removeWallsInPolygon ps walls = filter (not . cond) walls
   where 
-    cond wall = pointInsidePolygon (fst wall) ps
+    cond wall = 
-                        && pointInsidePolygon (snd wall) ps
+        pointInOrOnPolygon (0.5 *.* (fst wall +.+ snd wall)) ps
+--        pointInOrOnPolygon (fst wall) ps
+--                        && pointInOrOnPolygon (snd wall) ps
 
-------------------------------------------------------------------------------------
--- idea: create inner walls to draw and to cast shadows
-createInnerWalls :: IM.IntMap Wall -> IM.IntMap Wall
-createInnerWalls wls = IM.map (createInnerWall wls) wls
-
-createInnerWall :: IM.IntMap Wall -> Wall -> Wall
-createInnerWall walls wl = wl & wlLine %~ \l -> l ++ [wlL,wlR]
-  where wl0 = _wlLine wl !! 0
-        wl1 = _wlLine wl !! 1
-        wlLeft = findWallLeft wl walls
-        wlRight = findWallRight wl walls
-        wlN = normalizeV $ vNormal $ wl1 -.- wl0
-        rN = normalizeV $ vNormal $ (_wlLine wlRight !! 1) -.- (_wlLine wlRight !! 0)
-        lN = normalizeV $ vNormal $ (_wlLine wlLeft  !! 1) -.- (_wlLine wlLeft  !! 0)
-        wlR = wl0 +.+ 20 *.* normalizeV (wlN +.+ rN)
-        wlL = wl1 +.+ 20 *.* normalizeV (wlN +.+ lN)
-
-findWallLeft :: Wall -> IM.IntMap Wall -> Wall
-findWallLeft wl wls = case filter (\w -> _wlID w /= _wlID wl) $ IM.elems $ findWallsLeft (_wlLine wl !! 1) wls of
-    [w] -> w
-    wls   -> error $ "findWallLeft: " ++ show (map _wlID wls)
-                                                                 ++ " wlLines: "++ show (map _wlLine wls)
-
-findWallRight :: Wall -> IM.IntMap Wall -> Wall
-findWallRight wl wls = case filter (\w -> _wlID w /= _wlID wl) $ IM.elems $ findWallsRight (_wlLine wl !! 0) wls of
-    [w] -> w
-    wls   -> error $ "findWallRight: wall with ID " ++ show (_wlID wl) ++ " and points " ++
-                    show (_wlLine wl) ++ "\nhas a right corner with and only with the walls "
-                    ++ show (map _wlID wls) ++ "\nwlLines "++ show (map _wlLine wls)
-                    ++ "\nUnless a wall has a corner with exactly one other wall, there is a problem"
-
-findWallsLeft :: Point2 -> IM.IntMap Wall -> IM.IntMap Wall
-findWallsLeft x wls = IM.filter (\wl -> dist x (_wlLine wl !! 0) < 1) wls
-
-findWallsRight :: Point2 -> IM.IntMap Wall -> IM.IntMap Wall
-findWallsRight x wls = IM.filter (\wl -> dist x (_wlLine wl !! 1) < 1) wls

src/Dodge/Path.hs

@@ -1,6 +1,7 @@
 module Dodge.Path where
 import Dodge.Data
 import Dodge.Base
+import Dodge.Graph
 
 import Geometry
 
@@ -160,12 +161,3 @@ maybeToEither :: a -> Maybe b -> Either a b
 maybeToEither _ (Just x) = Right x
 maybeToEither y Nothing  = Left y
 
-pairsToIncidence :: (Eq a,Ord a) => [(a,a)] -> [(a,[a])]
-pairsToIncidence = map ((\(xs,ys) -> (head xs,ys)) . unzip)
-                     . groupBy ( (==) `on` fst)
-                     . sort
-
-incidenceToFunction :: Eq a => [(a,[a])] -> a -> [a]
-incidenceToFunction xs a = case lookup a xs of Just ys -> ys
-                                               Nothing -> []
-

src/Dodge/Render/Picture.hs

@@ -176,7 +176,7 @@ drawFFShadow w ff
           fCol = color (_ffColor ff)
           col = _ffColor ff
           ypShift = yp -.- _cameraCenter w
-          youOnFF = circOnLine' x' y' ypShift (_crRad $ you w)
+          youOnFF = circOnSeg x' y' ypShift (_crRad $ you w)
           pane j = color (withAlpha 0.1 col) 
                     $ polygon
                     $ [ x

src/Dodge/WallCreatureCollisions.hs

@@ -77,7 +77,7 @@ pushOutFromWall rad cp2 (wp1:wp2:_)
           wp1' = (rad *.* norm) +.+ wp1
           wp2' = (rad *.* norm) +.+ wp2
           newP = errorClosestPointOnLine 5 wp1' wp2' cp2
-          isOnWall = circOnLine' wp1 wp2 cp2 rad
+          isOnWall = circOnSegNoEndpoints wp1 wp2 cp2 rad
           isJust Nothing = False
           isJust _       = True
 

src/Dodge/WorldEvent.hs

@@ -111,7 +111,7 @@ createBarrelSpark time colid pos dir maycid w = over worldEvents
 
 damCrsOnLine :: Int -> Point2 -> Point2 -> World -> World
 damCrsOnLine dam p1 p2 = over creatures (IM.map damIfOnLine)
-    where damIfOnLine cr | circOnLine p1 p2 (_crPos cr) (_crRad cr) 
+    where damIfOnLine cr | circOnSeg p1 p2 (_crPos cr) (_crRad cr) 
                                      = over crHP (\hp -> hp - dam) cr
                          | otherwise = cr
 

src/Dodge/WorldEvent/Flash.hs

@@ -61,7 +61,7 @@ lowLightPic :: Float -> Float -> Color -> (Point2, Point2) -> World -> Picture
 lowLightPic len wdth col (a,b) w
     = case thingsHit a b w of
         ((p, E3x2 wall):_) 
-            -> setCol . lineOfThickness wdth $ [alongLineBy len p wa, alongLineBy len p wb]
+            -> setCol . lineOfThickness wdth $ [alongSegBy len p wa, alongSegBy len p wb]
                 where x = len *.* (normalizeV $ wa -.- wb)
                       (wa:wb:_) = _wlLine wall
         ((p, E3x1 cr):_) 

src/Dodge/WorldEvent/ThingsHit.hs

@@ -15,7 +15,7 @@ thingsHit sp ep w
         | sp == ep  = []
         | otherwise = sortBy (compare `on` dist sp . fst) (crs ++  walls ++ ffs)
     where 
-          hitCrs   = IM.elems $ IM.filter (\cr -> circOnLine sp ep (_crPos cr) (_crRad cr))
+          hitCrs   = IM.elems $ IM.filter (\cr -> circOnSeg sp ep (_crPos cr) (_crRad cr))
                                             $ _creatures w
 --                                            $ creaturesAlongLine sp ep w
           crPs     = map (\cr -> ssaTriPoint ep (_crPos cr) sp (_crRad cr)) hitCrs
@@ -53,7 +53,7 @@ thingsHitLongLine sp ep w
         | otherwise = sortBy (compare `on` dist sp . fst) (crs ++  walls ++ ffs)
     where 
           crs  = zip crPs (map E3x1 hitCrs)
-          hitCrs = IM.elems $ IM.filter (\cr -> circOnLine sp ep (_crPos cr) (_crRad cr))
+          hitCrs = IM.elems $ IM.filter (\cr -> circOnSeg sp ep (_crPos cr) (_crRad cr))
                                         $ _creatures w
                                       --   $ creaturesAlongLine sp ep w
           crPs = map (\cr -> ssaTriPoint ep (_crPos cr) sp (_crRad cr)) hitCrs

src/Geometry.hs

@@ -1,4 +1,13 @@
 {-# LANGUAGE BangPatterns #-}
+{-|
+Module      : Geometry
+Description : Geometry helpers
+
+This module provides geometry functions that manipulate pairs of floats.
+Conventions: 
+Seg refers to a segment, typically defined by two points, and will typically not extend beyond either of these points.
+Line refers to a line defined by two points, and extends beyond the two points.
+-}
 module Geometry
     ( module Geometry
     , module Geometry.Data
@@ -17,54 +26,61 @@ import Data.List
 import Data.Maybe
 
 import Control.Applicative
--- TODO add bang patterns
 
-alongLineBy :: Float -> Point2 -> Point2 -> Point2
+-- | Return a point a distance away from a first point towards a second point.
-alongLineBy !x !a !b = a +.+ y *.* normalizeV (b -.- a)
+-- Does not go past the second point.
+alongSegBy :: Float -> Point2 -> Point2 -> Point2
+alongSegBy !x !a !b = a +.+ y *.* normalizeV (b -.- a)
   where
     y = min x $ dist a b
 
-
+-- | Given a line and a point return the point on the line closest to the
-closestPointOnLine :: Point2 -> Point2 -> Point2 -> Point2
+-- point.
+closestPointOnLine 
+    :: Point2 -- ^ First line point. 
+    -> Point2 -- ^ Second line point.
+    -> Point2 -- ^ Point not on line.
+    -> Point2
 {-# INLINE closestPointOnLine #-}
 closestPointOnLine !a  !b  !p  = a +.+ u *.* (b -.- a)
   where u = closestPointOnLineParam a b p
 
-closestPointOnLineParam :: Point2 -> Point2 -> Point2 -> Float
+-- | Given a line and a point return a value corresponding to how far along the
+-- line the point is.
+closestPointOnLineParam 
+    :: Point2   -- ^ First line point. 
+    -> Point2   -- ^ Second line point.
+    -> Point2   -- ^ Point not on line.
+    -> Float
 {-# INLINE closestPointOnLineParam #-}
 closestPointOnLineParam !a !b !p
     = (p -.- a) `dotV` (b -.- a) / (b -.- a) `dotV` (b -.- a)
 
-
+-- | Draw a rectangle based on maximal N E S W values.
-
--- the following helper draws a rectangle based on maximal N E S W values
 rectNESW :: Float -> Float -> Float -> Float -> [Point2]
 rectNESW !a !b !c !d = [(b,a),(b,c),(d,c),(d,a) ]
 
+-- | Draw a rectangle based on maximal N S E W values.
 rectNSEW :: Float -> Float -> Float -> Float -> [Point2]
 rectNSEW !n !s !e !w = rectNESW n e s w
 
+-- | Draw a rectangle based on maximal N S W E values.
 rectNSWE :: Float -> Float -> Float -> Float -> [Point2]
 rectNSWE !n !s !w !e = [ (w,n), (w,s), (e,s), (e,n)]
 
--- -- the following filters points in a polygon: supposes the points in the
+-- | Test whether a point is in a polygon or on the polygon border.
--- polygon are listed in anticlockwise order
+-- Supposes the points in the
+-- polygon are listed in anticlockwise order.
 pointInOrOnPolygon :: Point2 -> [Point2] -> Bool
 pointInOrOnPolygon !p (x:xs) = all (\l -> not (uncurry isRHS l p)) $ zip (x:xs) (xs ++ [x])
 
-
+-- | Test whether a point is strictly inside a polygon.
+-- Supposes the points in the polygon are listed in anticlockwise order.
 pointInPolygon :: Point2 -> [Point2] -> Bool
 pointInPolygon !p [] = False
 pointInPolygon !p (x:xs) = all (\l -> uncurry (errorIsLHS 1) l p) $ zip (x:xs) (xs ++ [x])
 
-pointInsidePolygon :: Point2 -> [Point2] -> Bool
+-- | Debug version of 'pointInPolygon'.
-pointInsidePolygon !p (x:xs) = all (\l -> not (uncurry isRHS l (p +.+ normalizeV s))) pairs
-    || any (\l -> uncurry isOnLine l p) pairs
-  where 
-    pairs = zip (x:xs) (xs ++ [x])
-    s = ((1/fromIntegral (length (x:xs))) *.* (foldr1 (+.+) (x:xs))) -.- p
-
-
 errorPointInPolygon :: Int -> Point2 -> [Point2] -> Bool
 errorPointInPolygon !i !p xs 
     | length xs == 1 = error "one point polygon"
@@ -72,43 +88,53 @@ errorPointInPolygon !i !p xs
     | nub xs == xs = pointInPolygon p xs
     | otherwise = error $ "errorPointInPolygon "++ show i
 
+-- | Debug version of 'normalizeV'.
 errorNormalizeV :: Int -> Point2 -> Point2
 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 !p !p' = angleVV p p'
 
+-- | Debug version of 'isLHS'.
 errorIsLHS :: Int -> Point2 -> Point2 -> Point2 -> Bool
 errorIsLHS !i !x !y 
     | x == y = error $ "problem with function: errorIsLHS " ++show i
     | otherwise = isLHS x y
 
+-- | Debug version of 'closestPointOnLine'
 errorClosestPointOnLine :: Int -> Point2 -> Point2 -> Point2 -> Point2
 errorClosestPointOnLine !i !x !y 
     | x == y = error $ "problem with function: errorClosestPointOnLine " ++show i
     | otherwise = closestPointOnLine x y
 
+-- | Debug version of 'closestPointOnLineParam'
 errorClosestPointOnLineParam :: Int -> Point2 -> Point2 -> Point2 -> Float
 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
 
--- tests whether a point is on the LHS of a line
+-- | Test whether a point is on the LHS of a line.
-isLHS :: Point2 -> Point2 -> Point2 -> Bool
+-- Returns False if the line is of zero length.
+isLHS 
+    :: Point2  -- ^ First line point. 
+    -> Point2  -- ^ Second line point.
+    -> Point2  -- ^ Point not on line.
+    -> Bool
 {-# INLINE isLHS #-}
-isLHS' :: (Float, Float) -> (Float, Float) -> Point2 -> Bool
+isLHS 
-isLHS' !l1 !l2 !p 
+    !(x,y)      
-    | l1 == l2  = False
+    !(x',y')   
-    | otherwise = closestPointOnLineParam l1 (l1 +.+ vNormal (l2 -.- l1)) p < 0
+    !(x'',y'') 
-
-isLHS !(x,y) !(x',y') !(x'',y'') 
     | (x,y) == (x',y')  = False
     | otherwise = a1 * b2 - a2 * b1 > 0
   where 
@@ -117,9 +143,18 @@ isLHS !(x,y) !(x',y') !(x'',y'')
     b1 = x'' - x
     b2 = y'' - y
 
-isRHS :: Point2 -> Point2 -> Point2 -> Bool
+-- | Test whether a point is on the LHS of a line.
+-- Returns False if the line is of zero length.
+isRHS 
+    :: Point2 -- ^ First line point. 
+    -> Point2 -- ^ Second line point.
+    -> Point2 -- ^ Point not on line.
+    -> Bool
 {-# INLINE isRHS #-}
-isRHS !(x,y) !(x',y') !(x'',y'') 
+isRHS 
+    !(x,y)       
+    !(x',y')    
+    !(x'',y'')  
     | (x,y) == (x',y')  = False
     | otherwise = a1 * b2 - a2 * b1 < 0
   where 
@@ -128,54 +163,69 @@ isRHS !(x,y) !(x',y') !(x'',y'')
     b1 = x'' - x
     b2 = y'' - y
 
--- reorders points to be anticlockwise around their center
+-- | Reorder points to be anticlockwise around their center.
 orderPolygon :: [Point2] -> [Point2]
 orderPolygon [] = []
 orderPolygon ps = sortBy (compare `on` \p -> argV (p -.- cen)) ps
   where 
     cen = 1/ fromIntegral (length ps) *.* foldr1 (+.+) ps
 
+-- | Return distance between two points.
 dist :: Point2 -> Point2 -> Float
 {-# INLINE dist #-}
 dist !p1 !p2 = magV (p2 -.- p1)
 
-
+-- | Return midpoint between two points.
 pHalf :: Point2 -> Point2 -> Point2
 pHalf !a !b = 0.5 *.* (a +.+ b)
 
-circOnLine' :: Point2 -> Point2 -> Point2 -> Float -> Bool
+-- | Test whether a circle is on a segment by intersecting a new normal segment through the 
-circOnLine' !p1 !p2 !c !rad = isJustTrue (fmap (\p -> magV (p -.- c) < rad) y)
+-- center of the circle with the segment itself.
+-- Returns False if the circle center is beyond the enpoints of the
+-- segment.
+circOnSegNoEndpoints :: Point2 -> Point2 -> Point2 -> Float -> Bool
+{-# INLINE circOnSegNoEndpoints #-}
+circOnSegNoEndpoints !p1 !p2 !c !rad = isJustTrue (fmap (\p -> magV (p -.- c) < rad) y)
   where 
     y = intersectSegLine' p1 p2 c (c +.+ vNormal (p1 -.- p2))
     isJustTrue (Just True) = True
     isJustTrue _           = False
 
--- this should probably be circOnSeg
+-- | Test whether a circle is on a segment by intersecting a normal and testing
-circOnLine :: Point2 -> Point2 -> Point2 -> Float -> Bool
+-- the distance to the endpoints of the segment.
-{-# INLINE circOnLine #-}
+circOnSeg :: Point2 -> Point2 -> Point2 -> Float -> Bool
-circOnLine !p1 !p2 !c !rad = magV (p1 -.- c) <= rad || magV (p2 -.- c) <= rad
+{-# INLINE circOnSeg #-}
+circOnSeg !p1 !p2 !c !rad = magV (p1 -.- c) <= rad || magV (p2 -.- c) <= rad
                              || isJustTrue (fmap (\p -> magV (p -.- c) < rad) y)
   where 
     y = intersectSegLine' p1 p2 c (c +.+ vNormal (p1 -.- p2))
     isJustTrue (Just True) = True
     isJustTrue _           = False
 
+-- | Find the difference between two Nums.
 difference :: (Ord a, Num a) => a -> a -> a
 difference x y 
     | x > y     = x - y
     | otherwise = y - x
 
+-- | Given vector line direction and a vector movement,
+-- reflects the movement accoring to the line.
 reflectIn :: Point2 -> Point2 -> Point2
 reflectIn line vec = 
     let angle = 2 * angleBetween line vec
     in  rotateV angle vec
 
+-- | Find angle between two points.
+-- Not normalised, ranges from -2*pi to 2*pi.
 angleBetween :: Point2 -> Point2 -> Float
 angleBetween v1 v2 = argV v1 - argV v2
 
+-- | Return a list containing two copies of a pair.
 doublePair :: (a,a) -> [(a,a)]
 doublePair (x,y) = [(x,y),(y,x)]
 
+-- | Test whether two polygons intersect by testing the intersection of each
+-- consecutive pair of points.
 polysIntersect :: [Point2] -> [Point2] -> Bool
 polysIntersect (p:ps) (q:qs) 
     = any isJust $ (\(a,b) (c,d) -> myIntersectSegSeg a b c d) <$> pairs1 <*> pairs2
@@ -186,25 +236,33 @@ polysIntersect (p:ps) (q:qs)
 polysIntersect [] _ = False
 polysIntersect _ [] = False
 
+-- | Test whether any polygons from a first list intersect with any polygons from
+-- a second list.
 anyPolyssIntersect :: [[Point2]] -> [[Point2]] -> Bool
 anyPolyssIntersect x y = or $ polysIntersect <$> x <*> y
 
+-- | Return n equidistant points on a circle with a radius of 600.
 nRays :: Int -> [Point2]
 nRays n = take n $ iterate (rotateV (2*pi/fromIntegral n)) (600,0)
 
+-- | Return n equidistant points on a circle with a radius of x.
 nRaysRad :: Int -> Float -> [Point2]
 nRaysRad n x = take n $ iterate (rotateV (2*pi/fromIntegral n)) (x,0)
 
--- angles go from 0 to 2pi, need to work out what is left of another
+-- | Test whether an angle is to the left of another angle, according to the
+-- smallest change in rotation between them.
 isLeftOfA :: Float -> Float -> Bool
 isLeftOfA angle1 angle2 = 
     (angle1 - angle2 < pi && angle1 > angle2)
     || (angle2 - angle1 > pi && angle2 > angle1)
 
+-- | Test whether a vector is to the left of another, according to the smallest
+-- change of rotation between them.
 isLeftOf :: Point2 -> Point2 -> Bool
 isLeftOf x y = isLeftOfA (argV x) (argV y)
 
--- diffAngles has an issue...
+-- | Find the difference between two angles.
+-- Possibly not correct...
 diffAngles :: Float -> Float -> Float
 diffAngles x y 
     | diff > pi  = diffAngles (x - 2*pi) y
@@ -217,10 +275,10 @@ diffAngles x y
 differenceAngles = diffAngles
 angleDifference = diffAngles
 
--- given a triangle where we know the length of a first side,
+-- | Given a triangle where we know the length of a first side,
 -- the length of a second side, and the angle between the first side and the
--- third side, finds the length of the third side
+-- third side, finds the length of the third side.
--- not this doesn't necessarily find ALL solutions, asin is a map not a function
+-- Note this doesn't necessarily find ALL solutions, asin is a map not a function.
 ssaTri :: Float -> Float -> Float -> Float
 ssaTri ab bc a 
     | sin a == 0 = 0
@@ -230,12 +288,10 @@ ssaTri ab bc a
             b = pi - (a + c)
         in  sin b * bc / sin a
 
--- fix points: we now fix the triangle in the coordinate system, and return a
+-- | Given two points of a triangle and a third point, return
--- third unknown point:
+-- the point which lies between pa and pc' on a line from pb of length bc.
--- the point which lies between pa and pc' on a line from b of length bc
+-- Note that there are likely two such points, this should return the point
--- note that there are likely two such points, this seems to return the point
+-- closer to pc'.
--- closer to pc'
-
 ssaTriPoint :: Point2 -> Point2 -> Point2 -> Float -> Point2
 ssaTriPoint pa pb pc' bc
     = let ab = magV (pa -.- pb)
@@ -243,13 +299,15 @@ ssaTriPoint pa pb pc' bc
           ac = ssaTri ab bc a
       in  pa +.+ (ac *.* errorNormalizeV 47 (pc' -.- pa))
 
--- the above SHOULD return a Maybe Point...
+-- | Safe version of 'ssaTriPoint'.
 ssaTriPoint' :: Point2 -> Point2 -> Point2 -> Float -> Maybe Point2
 ssaTriPoint' pa pb pc' bc
     | dist pb (closestPointOnSeg pa pc' pb) >= bc
         = Nothing
     | otherwise
         = Just $ ssaTriPoint pa pb pc' bc
+-- | A potential correction of 'ssaTriPoint'.
+-- This should be tested and benchmarked.
 ssaTriPointCorrect :: Point2 -> Point2 -> Point2 -> Float -> Maybe Point2
 ssaTriPointCorrect pa pb pc' bc
     | param <= 1 && param >= 0 = Just p
@@ -258,42 +316,42 @@ ssaTriPointCorrect pa pb pc' bc
     p = ssaTriPoint pa pb pc' bc
     param = closestPointOnLineParam pa pc' p
 
-
+-- | Given a segment and external point, find the closest point on the segment.
 closestPointOnSeg :: Point2 -> Point2 -> Point2 -> Point2
 closestPointOnSeg segP1 segP2 p
     | errorClosestPointOnLineParam 3 segP1 segP2 p <= 0 = segP1
     | errorClosestPointOnLineParam 4 segP1 segP2 p >= 1 = segP2
     | otherwise                                  = errorClosestPointOnLine 2 segP1 segP2 p
 
+-- | Return Just a point if it is inside a circle, Nothing otherwise.
 pointInCircle :: Point2 -> Float -> Point2 -> Maybe Point2
 pointInCircle p r c 
     | p == c = Just p
     | magV (p -.- c) < r = Just p
     | otherwise = Nothing
 
---determines if a moving point intersects with a circle,
+-- | Determines if a moving point intersects with a circle,
---if so, returns a point on circle that intersects with the line passing
+-- if so, returns a point on circle that intersects with the line passing
---throught the circle : HOPEFULLY THE CORRECT OF THE TWO!
+-- throught the circle : HOPEFULLY THE CORRECT OF THE TWO!
-
 collidePointCirc :: Point2 -> Point2 -> Float -> Point2 -> Maybe Point2
 collidePointCirc p1 p2 rad c = ssaTriPoint' p2 c p1 rad
 
--- changes the point to a measure of the distance
+-- | As 'collidePointCirc', but changes the point to a measure of the distance.
 collidePointCirc' :: Point2 -> Point2 -> Float -> Point2 -> Maybe Float
 collidePointCirc' p1 p2 rad c = fmap (\x -> magV (x -.- p1))
                                     (collidePointCirc p1 p2 rad c)
 
---returns both the point and the measure of the distance
+-- | As 'collidePointCirc', but returns both the point and the measure of the distance.
 collidePointCirc'' :: Point2 -> Point2 -> Float -> Point2 -> Maybe (Point2,Float)
 collidePointCirc'' p1 p2 rad c = (,) <$> collidePointCirc p1 p2 rad c
                                      <*>  collidePointCirc' p1 p2 rad c
                                      
+-- | As 'collidePointCirc', but uses the supposedly correct version of ssaTriPoint.
 collidePointCircCorrect :: Point2 -> Point2 -> Float -> Point2 -> Maybe Point2
 collidePointCircCorrect p1 p2 rad c = ssaTriPointCorrect p2 c p1 rad
 
-
+-- | Finds the height of a triangle using herons formula.
--- finds the height of a triangle using herons formula
+-- The base is the line between the first two points.
--- the base is the line between the first two points
 heron :: Point2 -> Point2 -> Point2 -> Float
 heron x y z 
     | x == y = 0
@@ -304,7 +362,8 @@ heron x y z
             s = (a+b+c)/2
             area = sqrt(s*(s-a)*(s-b)*(s-c))
         in  2*area/a
--- multiplies reflection in normal by factor
+
+-- | Multiplies reflection in normal by factor.
 reflectInParam :: Float -> Point2 -> Point2 -> Point2
 reflectInParam x line vec = 
     let angle = 2 * angleBetween line vec
@@ -312,16 +371,17 @@ reflectInParam x line vec =
         p = x *.* errorClosestPointOnLine 3 (0,0) (vNormal line) rAng
     in  rAng -.- p
 
+--reflectIn' :: Point2 -> Point2 -> Point2 -> Point2 -> Point2
+--reflectIn' l1 l2 v1 v2 = v1 +.+ reflectIn (l1 -.- l2) (v2 -.- v1)
 
-reflectIn' :: Point2 -> Point2 -> Point2 -> Point2 -> Point2
+--isOnSeg :: Point2 -> Point2 -> Point2 -> Bool
-reflectIn' l1 l2 v1 v2 = v1 +.+ reflectIn (l1 -.- l2) (v2 -.- v1)
+--isOnSeg l1 l2 p = 
-
+--    errorClosestPointOnLineParam 10 l1 (l1 +.+ vNormal (l2 -.- l1)) p == 0
-isOnLine :: Point2 -> Point2 -> Point2 -> Bool
+--    && errorClosestPointOnLineParam 11 l1 l2 p <= 1
-isOnLine l1 l2 p = 
+--    && errorClosestPointOnLineParam 12 l1 l2 p >= 0
-    errorClosestPointOnLineParam 10 l1 (l1 +.+ vNormal (l2 -.- l1)) p == 0
-    && errorClosestPointOnLineParam 11 l1 l2 p <= 1
-    && errorClosestPointOnLineParam 12 l1 l2 p >= 0
 
+-- | Divide a segment into a list of points with a maximal distance between
+-- them.
 -- the take 5000 here is a hack, otherwise divideLine seems to sometimes
 -- generate an infinite list, and I don't know why
 divideLine :: Float -> Point2 -> Point2 -> [Point2]
@@ -335,6 +395,7 @@ divideLine x a b =
     numPoints = max 1 $ ceiling $ d / x
     ns = [0 .. numPoints]
 
+-- | As 'divideLine', but must return an odd number of points.
 divideLineOddNumPoints :: Float -> Point2 -> Point2 -> [Point2]
 --divideLine x a b = map (\i -> a +.+ (i / (fromIntegral numPoints)) *.* (b -.- a)) 
 divideLineOddNumPoints x a b = take 5000 
@@ -347,29 +408,8 @@ divideLineOddNumPoints x a b = take 5000
               | otherwise       = numPoints' + 1
     ns = [0 .. numPoints]
 
--- pulled the following from the haskell wiki
+-- | Given two pairs of Ints, returns a list of pairs of Ints that form 
--- it seems to produce an infinite loop sometimes
+-- a digital line between them.
--- fuck that, don't trust random code on the internet
-bresenham :: (Int,Int) -> (Int,Int) -> [(Int,Int)]
-{-# INLINE bresenham #-}
-bresenham pa@(xa,ya) pb@(xb,yb) = map maySwitch . unfoldr go $ (x1,y1,0)
-  where
-    steep = abs (yb - ya) > abs (xb - xa)
-    maySwitch = if steep then (\(x,y) -> (y,x)) else id
-    [(x1,y1),(x2,y2)] = sort [maySwitch pa, maySwitch pb]
-    deltax = x2 - x1
-    deltay = abs (y2 - y1)
-    ystep = if y1 < y2 then 1 else -1
-    go (xTemp, yTemp, error)
-        | xTemp > x2 = Nothing
-        | otherwise  = Just ((xTemp, yTemp), (xTemp + 1, newY, newError))
-      where
-          tempError = error + deltay
-          (newY, newError) = 
-            if (2*tempError) >= deltax
-            then (yTemp+ystep,tempError-deltax)
-            else (yTemp,tempError)
-
 digitalLine :: (Int,Int) -> (Int,Int) -> [(Int,Int)]
 digitalLine (x1,y1) (x2,y2) 
     | abs (x1-x2) > abs (y1-y2) = [ (x,( (y1-y2) * x + x1*y2 - x2*y1) `rdiv` (x1-x2) ) 
@@ -379,34 +419,44 @@ digitalLine (x1,y1) (x2,y2)
   where 
     rdiv a b = round $ fromIntegral a / fromIntegral b
 
+-- | Given two Ints, creates the list of Ints between these.
 intervalList :: Int -> Int -> [Int]
 intervalList x y 
     | y >= x = [x .. y]
     | otherwise = reverse [y..x]
 
+-- | Create points on the circumference of a circle with maximal distance
+-- between them.
 divideCircle :: Float -> Point2 -> Float -> [Point2]
-divideCircle x cen rad = map (cen +.+) $ nPointsOnCirc n rad
+divideCircle x cen rad = map (cen +.+) $ nRaysRad n rad
   where 
     n = ceiling $ rad * 2 * pi / x
 
-nPointsOnCirc :: Int -> Float -> [Point2]
+--nPointsOnCirc :: Int -> Float -> [Point2]
-nPointsOnCirc n rad = take n $ iterate (rotateV (2*pi/fromIntegral n)) (rad,0)
+--nPointsOnCirc n rad = take n $ iterate (rotateV (2*pi/fromIntegral n)) (rad,0)
 
-lineInPolygon :: Point2 -> Point2 -> [Point2] -> Bool
+--lineInPolygon :: Point2 -> Point2 -> [Point2] -> Bool
-lineInPolygon a b ps = 
+--lineInPolygon a b ps = 
-    pointInPolygon a ps 
+--    pointInPolygon a ps 
-    || pointInPolygon b ps 
+--    || pointInPolygon b ps 
-    || any (isJust . uncurry (intersectSegSeg' a b)) pss
+--    || any (isJust . uncurry (intersectSegSeg' a b)) pss
-  where 
+--  where 
-    pss = zip ps (tail ps ++ [head ps])
+--    pss = zip ps (tail ps ++ [head ps])
 
+-- | Given a list of points, returns pairs of points linking the points into a
+-- loop.
 makeLoopPairs :: [Point2] -> [(Point2,Point2)]
 makeLoopPairs [] = error "tried to make loop with empty list of points"
 makeLoopPairs [x] = error "tried to make loop with singleton list of points"
 makeLoopPairs (x:xs) = zip (x:xs) (xs ++ [x])
 
--- note the pair is ordered
+-- | Test whether a point is in a cone.
--- doesn't work for obtuse angles
+-- Note the pair is ordered.
-pointIsInCone :: Point2 -> (Point2,Point2) -> Point2 -> Bool
+-- Doesn't work for obtuse angles.
+pointIsInCone 
+    :: Point2           -- ^ Cone point. 
+    -> (Point2,Point2)  -- ^ Points delimiting the left and right boundaries of the cone.
+    -> Point2           -- ^ Point to test.
+    -> Bool
 pointIsInCone c (rightp,leftp) p = isLHS c rightp p && isLHS leftp c p
 

src/Loop.hs

@@ -1,3 +1,9 @@
+{-|
+Module      : Loop
+Description : A minimal game loop
+
+This module sets up an SDL window which may be updated using a simple game loop.
+-}
 module Loop
     ( setupLoop
     ) where
@@ -12,25 +18,17 @@ import Foreign.C
 
 import Control.Lens ((.~),(&),(+~))
 
-winConfig :: Int -> Int -> WindowConfig
+-- | Create a game loop with an SDL window.
-winConfig x y = defaultWindow 
-    { windowGraphicsContext
-        = OpenGLContext (defaultOpenGL { glProfile = Core Normal 4 3
-                                       , glColorPrecision = V4 8 8 8 8
-                                       } 
-                        )
-    , windowInitialSize = V2 (fromIntegral x) (fromIntegral y)
-    , windowResizable =True
-    }
-
 setupLoop
-    :: (Int,Int)
+    :: (Int,Int)            -- ^ The window size.
-    -> IO params
+    -> IO params            -- ^ Initial parameters.
-    -> (params -> IO ())
+    -> (params -> IO ())    -- ^ Function for cleaning up parameters, applied when exiting loop.
-    -> IO world
+    -> IO world             -- ^ Initial simulation state.
-    -> (params -> world -> IO params)
+    -> (params -> world -> IO params)   -- ^ Parameter update, called once per frame. Allows for side effects such as rendering.
     -> (world -> Event -> Maybe world)
+                            -- ^ SDL Event handling, once per frame. Evaluating 'Nothing' exits the loop.
     -> (world -> Maybe world)
+                            -- ^ Simulation update, once per frame. 'Nothing' exits the loop.
     -> IO ()
 setupLoop 
     (xSize,ySize)
@@ -53,13 +51,14 @@ setupLoop
                     paramCleanup 
                     $ doLoop window startWorld sideEffects eventFn worldFn
 
+-- | The internal loop.
 doLoop 
-    :: Window 
+    :: Window   -- ^ The SDL window.
-    -> world
+    -> world    -- ^ Current simulation state.
-    -> (params -> world -> IO params) 
+    -> (params -> world -> IO params) -- ^ Parameter update. 
-    -> (world -> Event -> Maybe world) 
+    -> (world -> Event -> Maybe world) -- ^ SDL Event handling.
-    -> (world -> Maybe world) 
+    -> (world -> Maybe world) -- ^ Simulation update
-    -> params 
+    -> params -- ^ Current parameters.
     -> IO ()
 doLoop 
     window 
@@ -92,15 +91,8 @@ applyEventsIO
     -> IO (Maybe world)
 applyEventsIO fn w = foldM (applyEventIO fn) (Just w)
 
---eventCloseOrResize :: Event -> IO (Maybe Event)
+-- | Handle quit events in a manner to exit the loop. Other events handled as
---eventCloseOrResize e = case eventPayload e of
+-- determined by the custom function, although resize events also change the viewport.
---    QuitEvent           -> return Nothing
---    WindowClosedEvent _ -> return Nothing
---    WindowSizeChangedEvent (WindowSizeChangedEventData {windowSizeChangedEventSize = V2 x y})
---                        -> GL.viewport $= (GL.Position 0 0,GL.Size x y) >> return (Just e)
---    _                   -> return $ Just e
---
-
 applyEventIO :: (world -> Event -> Maybe world) -> Maybe world -> Event -> IO (Maybe world)
 applyEventIO fn mw e = case eventPayload e of
     QuitEvent           -> return Nothing
@@ -109,3 +101,15 @@ applyEventIO fn mw e = case eventPayload e of
                         -> GL.viewport $= (GL.Position 0 0,GL.Size x y) >> return (mw >>= \w -> fn w e)
     _                   -> return $ mw >>= flip fn e
 
+-- | Create an OpenGL SDL window configuration with a given x and y size.
+winConfig :: Int -> Int -> WindowConfig
+winConfig x y = defaultWindow 
+    { windowGraphicsContext
+        = OpenGLContext (defaultOpenGL { glProfile = Core Normal 4 3
+                                       , glColorPrecision = V4 8 8 8 8
+                                       } 
+                        )
+    , windowInitialSize = V2 (fromIntegral x) (fromIntegral y)
+    , windowResizable =True
+    }
+

test/Spec.hs

@@ -1,2 +1,53 @@
+import Test.QuickCheck
+
+import Dodge.LevelGen.StaticWalls
+import Geometry
+
 main :: IO ()
-main = putStrLn "Test suite not yet implemented"
+main = do
+    putStrLn "Running tests:"
+    quickCheck prop_looping
+
+nextPair :: Eq a => (a,a) -> [(a,a)] -> [(a,a)]
+nextPair (_,y) = filter (\(x,_) -> x == y)
+
+isLooping :: Eq a => [(a,a)] -> Bool
+isLooping xs = all (( == 1) . length . flip nextPair xs) xs
+
+isLooping' :: Eq a => [(a,a)] -> Bool
+isLooping' xs = all (f xs) xs
+  where
+    f ys (x,y) = length ins == length outs && length rins == length routs
+      where
+        ins = filter (\(a,b) -> a == x) ys
+        outs = filter (\(a,b) -> b == x) ys
+        rins = filter (\(a,b) -> a == y) ys
+        routs = filter (\(a,b) -> b == y) ys
+
+polygonStrictlyConvex :: [Point2] -> Bool
+polygonStrictlyConvex ps = True
+
+--prop_looping :: [Point2] -> [WallP] -> Bool
+
+prop_looping = forAllShrink genTris shrinkTris $ \tris ->
+    (all (not . (\[a,b,c] -> isOnSeg a b c
+                            || isOnSeg a c b
+                            || isOnSeg b c a
+                ) ) tris)
+    ==> (isLooping' $ foldr cutWalls' [] tris)
+
+shrinkTris [] = []
+shrinkTris (x:xs) = xs : map (x :) (shrinkTris xs)
+
+genTri = zip <$> trip <*> trip 
+  where
+    trip = vectorOf 3 $ fmap fromIntegral $ choose (0,3::Int)
+
+genTris = listOf genTri
+
+--extractLoops :: Eq a => [(a,a)] -> [[(a,a)]]
+--extractLoops [] = []
+--extractLoops (x:xs) = 
+  
+--
+--[[(0.0,1.0),(3.0,4.0),(5.0,5.0)],[(2.0,0.0),(2.0,4.0),(1.0,1.0)],[(5.0,5.0),(2.0,2.0),(1.0,3.0)]]