Reorganise geometry modules slightly

src/Dodge/Block.hs

@@ -7,7 +7,7 @@ import Dodge.Wall.Delete
 import Dodge.Wall.Dust
 import Dodge.RandomHelp
 import Geometry
-import Geometry.ConvexPoly
+--import Geometry.ConvexPoly
 
 import Data.Function
 import qualified Data.IntSet as IS

src/Dodge/Creature/Boid.hs

@@ -3,7 +3,7 @@ module Dodge.Creature.Boid
 import Dodge.Data
 import Dodge.Base
 import Geometry
-import Geometry.ConvexPoly
+--import Geometry.ConvexPoly
 
 import Control.Monad.Reader
 import Control.Lens

src/Dodge/Item/Weapon/UseEffect.hs

@@ -78,25 +78,23 @@ mvRadar
     -> Point2   -- ^ Center of expanding circle
     -> World -> Particle -> (World, Maybe Particle)
 mvRadar 0 _ w _  = (w, Nothing)
-mvRadar x p w pt = 
-    ( putBlips w
-    , Just $ pt {_ptDraw = const pic ,_ptUpdate = mvRadar (x-1) p }
-    )
-  where 
-    pic = onLayerL [levLayer ShadowLayer, 1] $ pictures sweepPics
-    putBlips = over worldEvents ( over particles (blips ++) . )
-    blips = map (\bp -> blipAt bp (withAlpha (0.5*globalAlpha) red) 50) circPoints
-    circPoints = mapMaybe (\wl -> uncurry collidePointCircCorrect (_wlLine wl) r p)
-        $ map (over wlLine swp) (IM.elems $ wallsAlongCirc p r w)
-                      ++ IM.elems (wallsAlongCirc p r w)
-    swp (a,b) = (b,a)
-    r = fromIntegral (800 - x*16)
-    sweepPics = [--colHelper 0.1 $ uncurry translate p $ thickCircle r 15
-                 --,colHelper 0.06 $ uncurry translate p $ thickCircle (r-5) 5
-                 --,colHelper 0.03 $ uncurry translate p $ thickCircle (r-10) 5
-                ]
-    globalAlpha | x > 10 = 1
-                | otherwise = fromIntegral x / 10
-    --colHelper y = color (withAlpha (y * globalAlpha) red)
-
-    
+mvRadar x p w pt = undefined
+--    ( putBlips w
+--    , Just $ pt {_ptDraw = const pic ,_ptUpdate = mvRadar (x-1) p }
+--    )
+--  where 
+--    pic = onLayerL [levLayer ShadowLayer, 1] $ pictures sweepPics
+--    putBlips = over worldEvents ( over particles (blips ++) . )
+--    blips = map (\bp -> blipAt bp (withAlpha (0.5*globalAlpha) red) 50) circPoints
+--    circPoints = mapMaybe (\wl -> uncurry collidePointCircCorrect (_wlLine wl) r p)
+--        $ map (over wlLine swp) (IM.elems $ wallsAlongCirc p r w)
+--                      ++ IM.elems (wallsAlongCirc p r w)
+--    swp (a,b) = (b,a)
+--    r = fromIntegral (800 - x*16)
+--    sweepPics = [--colHelper 0.1 $ uncurry translate p $ thickCircle r 15
+--                 --,colHelper 0.06 $ uncurry translate p $ thickCircle (r-5) 5
+--                 --,colHelper 0.03 $ uncurry translate p $ thickCircle (r-10) 5
+--                ]
+--    globalAlpha | x > 10 = 1
+--                | otherwise = fromIntegral x / 10
+--    --colHelper y = color (withAlpha (y * globalAlpha) red)

src/Dodge/Layout.hs

@@ -18,7 +18,7 @@ import Dodge.Default.Wall
 import Dodge.Room.Link
 import Dodge.Randify
 import Geometry
-import Geometry.ConvexPoly
+--import Geometry.ConvexPoly
 import qualified IntMapHelp as IM
 import Tile
 import Dodge.RandomHelp

src/Dodge/LevelGen/StaticWalls.hs

@@ -11,7 +11,7 @@ module Dodge.LevelGen.StaticWalls
     )
     where
 import Geometry
-import Geometry.ConvexPoly
+--import Geometry.ConvexPoly
 import FoldableHelp
 
 import Data.List.Extra

src/Dodge/WorldEvent/ThingsHit.hs

@@ -31,8 +31,8 @@ thingsHit sp ep w
   where 
     hitCrs = IM.elems 
         $ IM.filter (\cr -> circOnSeg sp ep (_crPos cr) (_crRad cr))
-    --    $ _creatures w
-        $ creaturesAlongLine sp ep w
+        $ _creatures w
+    --    $ creaturesAlongLine sp ep w
     crPs  = map (\cr -> ssaTriPoint ep (_crPos cr) sp (_crRad cr)) hitCrs
     crs   = zip crPs (map Left hitCrs)
     hitWls   = wallsOnLine sp ep (IM.unions [f b $ f a $ _znObjects $ _wallsZone w | a<-[x-1,x,x+1]
@@ -127,6 +127,7 @@ thingsHitLongLine sp ep w
         $ _creatures w
     --   $ creaturesAlongLine sp ep w
     crPs = map (\cr -> ssaTriPoint ep (_crPos cr) sp (_crRad cr)) hitCrs
+    --crPs = map _crPos hitCrs
     wls = zip (map (fromJust . hitPoint) hitWls) (map Right hitWls)
     --hitWls = wallsOnLine sp ep $ wallsAlongLine sp ep w
     hitWls = wallsOnLine sp ep $ _walls w

src/Geometry.hs

@@ -16,16 +16,18 @@ module Geometry
     , module Geometry.Vector
     , module Geometry.Vector3D
     , module Geometry.LHS
+    , module Geometry.Polygon
     ) where
 import Geometry.Data
+import Geometry.Polygon
 import Geometry.Intersect
 import Geometry.Bezier
 import Geometry.Vector
 import Geometry.Vector3D
 import Geometry.LHS
-import Geometry.ConvexPoly
+--import Geometry.ConvexPoly
 
-import Data.Maybe
+--import Data.Maybe
 import Data.List
 -- | Return a point a distance away from a first point towards a second point.
 -- Does not go past the second point.
@@ -33,65 +35,6 @@ 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
--- 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
--- | 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.
-rectNESW :: Float -> Float -> Float -> Float -> [Point2]
-rectNESW !a !b !c !d = [V2 b a,V2 b c,V2 d c,V2 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 = [V2 w n, V2 w s, V2 e s, V2 e n]
--- | Draw a rectangle around the origin with given height and width
-rectWH :: Float -> Float -> [Point2]
-rectWH w h = rectNSWE h (-h) (-w) w
-
-rectXH :: Float -> Float -> [Point2]
-rectXH x h = rectNSWE h (-h) 0 x
-
-rectXY :: Float -> Float -> [Point2]
-rectXY x y = rectNSWE y 0 0 x
-
-square :: Float -> [Point2]
-square n = rectWH n n
-
-mirrorXAxis :: [Point2] -> [Point2]
-mirrorXAxis ps = orderPolygon $ ps ++ mapMaybe f ps
-  where
-    f (V2 _ 0) = Nothing
-    f (V2 x y) = Just $ V2 x (-y)
-
--- | Test whether a point is in a polygon or on the polygon border.
--- 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])
-pointInOrOnPolygon _ _ = undefined
--- | 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 (x:xs) = all (\l -> uncurry isLHS l p) $ zip (x:xs) (xs ++ [x])
-pointInPolygon _ [] = False
 -- | Debug version of 'pointInPolygon'.
 errorPointInPolygon :: Int -> Point2 -> [Point2] -> Bool
 errorPointInPolygon !i !p xs 
@@ -123,55 +66,6 @@ errorClosestPointOnLineParam :: Int -> Point2 -> Point2 -> Point2 -> Float
 errorClosestPointOnLineParam  _ !x! y! z 
     | x == y    = dist x z
     | otherwise = closestPointOnLineParam x y z
-orderPolygonAround 
-    :: Point2 -- ^ point to order around
-    -> [Point2]
-    -> [Point2]
-orderPolygonAround _ [] = []
-orderPolygonAround cen ps = sortOn (\p -> argV (p -.- cen)) ps
-
-orderAroundFirstReverse :: [Point2] -> [Point2]
-orderAroundFirstReverse [] = []
-orderAroundFirstReverse (a:as) = a : reverse (orderPolygonAround a as)
-
-orderAroundFirst :: [Point2] -> [Point2]
-orderAroundFirst [] = []
-orderAroundFirst (a:as) = a : orderPolygonAround a as
--- | Reorder points to be anticlockwise around their center.
-orderPolygon :: [Point2] -> [Point2]
-orderPolygon [] = []
---orderPolygon ps = orderPolygonAround (1/ fromIntegral (length ps) *.* foldr1 (+.+) ps) ps
-orderPolygon ps = orderPolygonAround (centroid ps) ps
--- | Adds a point to a convex polygon.
--- If the point is inside, returns the original.
--- Points ordered anticlockwise, input not checked.
-addPointPolygon :: Point2 -> [Point2] -> [Point2]
-addPointPolygon p ps
-    | pointInOrOnPolygon p ps = ps
-    | otherwise = orderPolygon $ p : ps
--- | Creates the convex hull of a set of points.
--- Need to verify whether or not this is ordered
-convexHull :: [Point2] -> [Point2]
-convexHull (x:y:z:xs) = grahamScan $ orderAroundFirst $ sortOn (\(V2 a b) -> (b,a)) (x:y:z:xs)
-convexHull _ = error "Tried to create the convex hull of two or fewer points"
--- | Creates the convex hull of a set of points.
--- assumes no repetition of points: try nubbing!
-convexHullSafe :: [Point2] -> [Point2]
---convexHullSafe (x:y:z:xs) = grahamScan $ orderAroundFirst $ sortOn (\(V2 a b) -> (b,a)) (x:y:z:xs)
-convexHullSafe (x:y:z:xs) = grahamScan $ orderAroundFirst $ sortOn (\(V2 a b) -> (b,a)) (x:y:z:xs)
-convexHullSafe _ = []
-
-grahamScan :: [Point2] -> [Point2]
-grahamScan = foldr push []
-  where
-    push point stack = grahamEliminate (point:stack)
--- | Remove second element if top three elements are not counterclockwise.
--- Repeat if necessary. See 
--- https://codereview.stackexchange.com/questions/206019/graham-scan-algorithm-in-haskell
-grahamEliminate :: [Point2] -> [Point2]
-grahamEliminate (x:y:z:xs)
-    | not $ isLHS x y z = grahamEliminate (x:z:xs)
-grahamEliminate xs = xs
 
 -- | Return midpoint between two points.
 pHalf :: Point2 -> Point2 -> Point2
@@ -302,19 +196,14 @@ ssaTriPoint' pa pb pc' bc
         = 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
-    | otherwise                = Nothing
-  where 
-    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
+--ssaTriPointCorrect :: Point2 -> Point2 -> Point2 -> Float -> Maybe Point2
+--ssaTriPointCorrect pa pb pc' bc
+--    | param <= 1 && param >= 0 = Just p
+--    | otherwise                = Nothing
+--  where 
+--    p = ssaTriPoint pa pb pc' bc
+--    param = closestPointOnLineParam pa pc' p
+
 -- | Return Just a point if it is inside a circle, Nothing otherwise.
 pointInCircle :: Point2 -> Float -> Point2 -> Maybe Point2
 pointInCircle p r c 
@@ -335,8 +224,8 @@ 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
+--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.
 -- The base is the line between the first two points.
 heron :: Point2 -> Point2 -> Point2 -> Float

src/Geometry/ConvexPoly.hs

@@ -5,7 +5,7 @@ module Geometry.ConvexPoly
     , cpPoints
     , cpCen
     , cpRad
-    , centroid
+--    , centroid
     , pointsToPoly
     , convexPolysOverlap
     , pointInPolyPoints
@@ -14,9 +14,10 @@ import Geometry.Data
 import Geometry.Vector
 import Geometry.LHS
 import Geometry.Intersect
+import Geometry.Polygon
 
 import Control.Lens
-import qualified Control.Foldl as L
+--import qualified Control.Foldl as L
 data ConvexPoly = ConvexPoly
     { _cpPoints :: [Point2]
     , _cpCen    :: Point2
@@ -68,7 +69,5 @@ pairPolyPointsIntersect a' b' (c':d':xs') = go c' a' b' (c':d':xs')
     go _ _ _ _ = False
 pairPolyPointsIntersect _ _ _ = False
 
-centroid :: Foldable t => t Point2 -> Point2
-centroid = L.fold $ (/) <$> L.Fold (+.+) (V2 0 0) id <*> L.genericLength
 
 makeLenses ''ConvexPoly

src/Geometry/Intersect.hs

@@ -1,13 +1,14 @@
+{-# LANGUAGE BangPatterns #-}
 --{-# LANGUAGE TupleSections #-}
-{-
-Testing for and finding intersection points.
--}
+{- Testing for and finding intersection points.  -}
 module Geometry.Intersect where
 import Geometry.Data
 import Geometry.Vector
 import Geometry.LHS
 import Control.Applicative
 
+import Data.List
+
 import Data.Maybe (isNothing)
 -- | If two lines intersect, return 'Just' that point.
 intersectLineLine' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
@@ -212,3 +213,51 @@ intersectSegPolyFirst :: Point2 -> Point2 -> [Point2] -> Maybe Point2
 intersectSegPolyFirst a b xs = foldr (<|>) Nothing $ zipWith lineColl xs (tail xs ++ [head xs])
   where
     lineColl = intersectSegSeg a b
+
+-- | Given a line and a point return the point on the line closest to the
+-- 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
+-- | 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)
+
+-- | Given a segment and external point, find the closest point on the segment.
+-- clamps to the end of the segment
+closestPointOnSeg :: Point2 -> Point2 -> Point2 -> Point2
+closestPointOnSeg segP1 segP2 p
+    | closestPointOnLineParam segP1 segP2 p <= 0 = segP1
+    | closestPointOnLineParam segP1 segP2 p >= 1 = segP2
+    | otherwise                                  = closestPointOnLine segP1 segP2 p
+
+-- | Given a segment and external point, find the closest point on the segment.
+-- does not return closest points beyond the segment
+orthogonalPointOnSeg :: Point2 -> Point2 -> Point2 -> Maybe Point2
+orthogonalPointOnSeg a b p
+    | param < 0 || param > 1 = Nothing
+    | otherwise              = Just $ a +.+ param *.* (normalizeV $ b -.- a)
+  where
+    param = closestPointOnLineParam a b p
+intersectCircSeg :: Point2 -> Float -> Point2 -> Point2 -> [Point2]
+intersectCircSeg c r a b 
+    | y < 0 = []
+    | otherwise = nub $ filter ( (< dist a b) . dist a ) [ d -.- v, d +.+ c ]
+  where
+    d = closestPointOnLine a b c
+    x = dist d c
+    y = r ** 2 - x ** 2
+    z = sqrt y
+    v = z *.* normalizeV (b -.- a)

src/Geometry/Polygon.hs

@@ -0,0 +1,102 @@
+{-# LANGUAGE BangPatterns #-}
+module Geometry.Polygon where
+import Geometry.Data
+import Geometry.LHS
+import Geometry.Vector
+
+import Data.Maybe
+import Data.List
+import qualified Control.Foldl as L
+
+-- | Draw a rectangle based on maximal N E S W values.
+rectNESW :: Float -> Float -> Float -> Float -> [Point2]
+rectNESW !a !b !c !d = [V2 b a,V2 b c,V2 d c,V2 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 = [V2 w n, V2 w s, V2 e s, V2 e n]
+-- | Draw a rectangle around the origin with given height and width
+rectWH :: Float -> Float -> [Point2]
+rectWH w h = rectNSWE h (-h) (-w) w
+
+rectXH :: Float -> Float -> [Point2]
+rectXH x h = rectNSWE h (-h) 0 x
+
+rectXY :: Float -> Float -> [Point2]
+rectXY x y = rectNSWE y 0 0 x
+
+square :: Float -> [Point2]
+square n = rectWH n n
+
+mirrorXAxis :: [Point2] -> [Point2]
+mirrorXAxis ps = orderPolygon $ ps ++ mapMaybe f ps
+  where
+    f (V2 _ 0) = Nothing
+    f (V2 x y) = Just $ V2 x (-y)
+
+-- | Test whether a point is in a polygon or on the polygon border.
+-- 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])
+pointInOrOnPolygon _ _ = undefined
+-- | 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 (x:xs) = all (\l -> uncurry isLHS l p) $ zip (x:xs) (xs ++ [x])
+pointInPolygon _ [] = False
+
+orderPolygonAround 
+    :: Point2 -- ^ point to order around
+    -> [Point2]
+    -> [Point2]
+orderPolygonAround _ [] = []
+orderPolygonAround cen ps = sortOn (\p -> argV (p -.- cen)) ps
+
+orderAroundFirstReverse :: [Point2] -> [Point2]
+orderAroundFirstReverse [] = []
+orderAroundFirstReverse (a:as) = a : reverse (orderPolygonAround a as)
+
+orderAroundFirst :: [Point2] -> [Point2]
+orderAroundFirst [] = []
+orderAroundFirst (a:as) = a : orderPolygonAround a as
+-- | Reorder points to be anticlockwise around their center.
+orderPolygon :: [Point2] -> [Point2]
+orderPolygon [] = []
+--orderPolygon ps = orderPolygonAround (1/ fromIntegral (length ps) *.* foldr1 (+.+) ps) ps
+orderPolygon ps = orderPolygonAround (centroid ps) ps
+-- | Adds a point to a convex polygon.
+-- If the point is inside, returns the original.
+-- Points ordered anticlockwise, input not checked.
+addPointPolygon :: Point2 -> [Point2] -> [Point2]
+addPointPolygon p ps
+    | pointInOrOnPolygon p ps = ps
+    | otherwise = orderPolygon $ p : ps
+-- | Creates the convex hull of a set of points.
+-- Need to verify whether or not this is ordered
+convexHull :: [Point2] -> [Point2]
+convexHull (x:y:z:xs) = grahamScan $ orderAroundFirst $ sortOn (\(V2 a b) -> (b,a)) (x:y:z:xs)
+convexHull _ = error "Tried to create the convex hull of two or fewer points"
+-- | Creates the convex hull of a set of points.
+-- assumes no repetition of points: try nubbing!
+convexHullSafe :: [Point2] -> [Point2]
+--convexHullSafe (x:y:z:xs) = grahamScan $ orderAroundFirst $ sortOn (\(V2 a b) -> (b,a)) (x:y:z:xs)
+convexHullSafe (x:y:z:xs) = grahamScan $ orderAroundFirst $ sortOn (\(V2 a b) -> (b,a)) (x:y:z:xs)
+convexHullSafe _ = []
+
+grahamScan :: [Point2] -> [Point2]
+grahamScan = foldr push []
+  where
+    push point stack = grahamEliminate (point:stack)
+-- | Remove second element if top three elements are not counterclockwise.
+-- Repeat if necessary. See 
+-- https://codereview.stackexchange.com/questions/206019/graham-scan-algorithm-in-haskell
+grahamEliminate :: [Point2] -> [Point2]
+grahamEliminate (x:y:z:xs)
+    | not $ isLHS x y z = grahamEliminate (x:z:xs)
+grahamEliminate xs = xs
+
+centroid :: Foldable t => t Point2 -> Point2
+centroid = L.fold $ (/) <$> L.Fold (+.+) (V2 0 0) id <*> L.genericLength