justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Make anti-clockwise what were clockwise shapes, cleanup flash module-ing

Browse Source
This commit is contained in:
justin
2024-10-04 00:59:08 +01:00
parent ac550bc6a4
commit 075429088b
18 changed files with 128 additions and 156 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Geometry/Polygon.hs
+59 -47
View File
@@ -1,37 +1,36 @@
{-# LANGUAGE BangPatterns #-}
module Geometry.Polygon where
import qualified Control.Foldl as L
import Data.Maybe
import Geometry.Data
import Geometry.LHS
import Geometry.Vector
import ListHelp
import Data.Maybe
--import Data.List
import qualified Control.Foldl as L
-- | Draw an anticlockwise 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 an anticlockwise 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 an anticlockwise rectangle around the origin with given height and width
rectWH :: Float -> Float -> [Point2]
rectWH w h = rectNSWE h (-h) (-w) w
rectWH w h = rectNSWE h (- h) (- w) w
isotriBWH :: Point2 -> Float -> Float -> [Point2]
isotriBWH (V2 x y) w h = [V2 (x-w) y, V2 (x+w) y, V2 x (y+h)]
isotriBWH (V2 x y) w h = [V2 (x - w) y, V2 (x + w) y, V2 x (y + h)]
-- trapezion
trapezionBWHW :: Point2 -> Float -> Float -> Float -> [Point2]
trapezionBWHW (V2 x y) w1 h w2 =
[ V2 (x-w1) y
, V2 (x+w1) y
, V2 (x+w2) (y+h)
, V2 (x-w2) (y+h)]
trapezionBWHW (V2 x y) w1 h w2 =
[ V2 (x - w1) y
, V2 (x + w1) y
, V2 (x + w2) (y + h)
, V2 (x - w2) (y + h)
]
rectXH :: Float -> Float -> [Point2]
rectXH x h = rectNSWE h (-h) 0 x
rectXH x h = rectNSWE h (- h) 0 x
rectXY :: Float -> Float -> [Point2]
rectXY x y = rectNSWE y 0 0 x
@@ -43,80 +42,93 @@ mirrorXAxis :: [Point2] -> [Point2]
mirrorXAxis ps = orderPolygon $ ps ++ mapMaybe f ps
where
f (V2 _ 0) = Nothing
f (V2 x y) = Just $ V2 x (-y)
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.
{- | 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 !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.
{- | 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 !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 ::
-- | point to order around
Point2 ->
[Point2] ->
[Point2]
orderPolygonAround _ [] = []
orderPolygonAround cen ps = sortOn (\p -> argV (p -.- cen)) ps
orderAroundFirstReverse :: [Point2] -> [Point2]
orderAroundFirstReverse [] = []
orderAroundFirstReverse (a:as) = a : reverse (orderPolygonAround a as)
orderAroundFirstReverse (a : as) = a : reverse (orderPolygonAround a as)
orderAroundFirst :: [Point2] -> [Point2]
orderAroundFirst [] = []
orderAroundFirst (a:as) = a : orderPolygonAround a as
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.
{- | 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
{- | 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 (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!
{- | 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 (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
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 (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
centroidNum :: (Fractional a ,Foldable t) => t a -> a
centroidNum :: (Fractional a, Foldable t) => t a -> a
centroidNum = L.fold $ (/) <$> L.Fold (+) 0 id <*> L.genericLength
shrinkPolyOnEdges :: Float -> [Point2] -> [Point2]
shrinkPolyOnEdges x (p:q:ps) = map (shrinkVert x) . slideWindow 3 $ (p:q:ps) ++ [p,q]
shrinkPolyOnEdges x (p : q : ps) = map (shrinkVert x) . slideWindow 3 $ (p : q : ps) ++ [p, q]
shrinkPolyOnEdges _ _ = error "too few vertices in polygon"
shrinkVert :: Float -> [Point2] -> Point2
shrinkVert d [x,y,z] = x +.+ (d *.* normalizeV (x -.- y)) +.+ (d *.* normalizeV (z -.- y))
shrinkVert d [x, y, z] = x +.+ (d *.* normalizeV (x -.- y)) +.+ (d *.* normalizeV (z -.- y))
shrinkVert _ _ = error "wrong number of vertices"