Reorganise geometry modules slightly

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