{-
Below codes are redundance, no efficient and some are 'duplicate'.
Maybe come back later to clean up.
The main idea is to 'convert' a concave polygon to a convex polygn.
F* For example: polygone ABCDEF = polygon ABCF - triangle CDE - triangle CEF
/| Note:
/ * E After first time convert: polygon ABCDEF = polygon ABCEF - triangle CDE
/ / the polygon ABCEF is still not convex. (need re-convert again)
A* *-----* C
\ D / Polygon and triangle 'share' the same border:
\ / for example: polygon ABCF and triangle CEF share line CF
\ / To make it easier, I try to test the point on initial polygon border first.
* B
-}
(Polygon pts) `containsS` p
| inBorder = True
| isSelfCrossing (pointsToRays pts) = error "This algorithm is not good for self-crossing polygon"
| isConvex pts' =
let isLeftOfp p' = isLeftOf p p'
in and $ map isLeftOfp (pointsToRays pts')
| otherwise =
let (ps, triangles) = toConvex pts' []
in ((Polygon ps) `containsS` p) && not (or $ map (`containsS` p) triangles)
where
inBorder = or $ map (pointInRay p) (pointsToRays pts)
pts' = if isAntiClockwiseOrder pts then pts else reverse pts
isLeftOf :: Coordinate -> Ray -> Bool
(px, py) `isLeftOf` ((ax, ay), (bx, by))
= let (s, t) = (px - ax, py - ay)
(u, v) = (px - bx, py - by)
in s * v >= t * u
toConvex :: [Coordinate] -> [Shape] -> ([Coordinate], [Shape])
toConvex ps ts -- ps must in anti-clockwise order
| isConvex ps = (ps, ts)
| otherwise = let (ps', ts') = toConvex' (ps++[head ps]) ts
in toConvex (init ps') ts'
toConvex' :: [Coordinate] -> [Shape] -> ([Coordinate], [Shape])
toConvex' (p1:p2:p3:ps) triangles
| crossProductZscalar (p1, p2) (p2, p3) > 0
= let (ps', triangles') = toConvex (p2:p3:ps) triangles
in ((p1:ps'), triangles')
| otherwise
= ((p1:p3:ps), Polygon [p1, p2, p3]:triangles)
toConvex' ps ts = (ps, ts)
crossProductZscalar :: Ray -> Ray -> Float
crossProductZscalar ((x1, y1), (x2, y2)) ((x3, y3), (x4, y4))
= (x2-x1)*(y4-y3) - (x4-x3)*(y2-y1)
isAntiClockwiseOrder :: [Coordinate] -> Bool
isAntiClockwiseOrder (p1:p2:p3:_) = crossProductZscalar (p1, p2) (p2, p3) >= 0
isAntiClockwiseOrder _ = False
isConvex :: [Coordinate] -> Bool -- anti-clockwise order and convex
isConvex [] = False
isConvex cs = all (>=0) zScalars -- || all (<=0) zScalars
where
rays = pointsToRays cs
zScalars = zipWith crossProductZscalar rays (tail (cycle rays))
isSelfCrossing :: [Ray] -> Bool
isSelfCrossing [] = False
isSelfCrossing (r:rs) = isSelfCrossing rs || or (zipWith twoRaysCross rs (repeat r))
pointsToRays :: [Coordinate] -> [Ray]
pointsToRays cs = zip cs (tail (cycle cs))
{- Reference: http://mathworld.wolfram.com/Line-LineIntersection.html -}
twoRaysCross :: Ray -> Ray -> Bool
twoRaysCross ray1@((x1, y1), (x2, y2)) ray2@((x3, y3), (x4, y4))
| twoRaysJoin ray1 ray2 = False
| otherwise =
if det == 0
then if x_det == 0 && y_det == 0 -- same lines
then if pointInRay (x1, y1) ray2 || pointInRay (x2, y2) ray2
then True -- 2 rays same slope and cross
else False -- 2 rays like *----* *----* same slope but not cross
else False -- 2 rays are parallel
else let x = x_det / det
y = y_det / det
in pointInRay (x,y) ray1 && pointInRay (x,y) ray2
where
det = (x1-x2) * (y3-y4) - (x3-x4) * (y1-y2)
x_det = (x1*y2-x2*y1)*(x3-x4) - (x3*y4-x4*y3)*(x1-x2)
y_det = (x1*y2-x2*y1)*(y3-y4) - (x3*y4-x4*y3)*(y1-y2)
twoRaysJoin :: Ray -> Ray -> Bool
twoRaysJoin ray1@(p1, p2) ray2@(p3, p4)
= (p1 == p3 && not (pointInRay p4 ray1) && not (pointInRay p2 ray2))
|| (p1 == p4 && not (pointInRay p3 ray1) && not (pointInRay p2 ray2))
|| (p2 == p3 && not (pointInRay p4 ray1) && not (pointInRay p1 ray2))
|| (p2 == p4 && not (pointInRay p3 ray1) && not (pointInRay p1 ray2))
pointInRay :: Coordinate -> Ray -> Bool
pointInRay (x, y) ((x1, y1), (x2, y2))
= (x-x1) * (y2-y1) == (y-y1) * (x2-x1)
&& (min x1 x2) <= x && x <= (max x1 x2)
&& (min y1 y2) <= y && y <= (max y1 y2)
----- same tests -----
main = do
putStrLn $ show $ containsS (Polygon [(0,0), (1,0), (0,1)]) (0.5, 0.5)
putStrLn $ show $ containsS (Polygon [(0,0), (0,1), (1,0)]) (0.5, 0.5)
putStrLn $ show $ containsS (Polygon [(0,0), (2,0), (2,2),(1,1),(0,2)]) (1, 1.5)
putStrLn $ show $ toConvex [(0,0), (2,0), (2,2),(1,1),(0,2)] []
putStrLn $ show $ toConvex [(-2,0), (0,-2), (2,0), (-1, 0), (0,1), (0,2)] []
putStrLn $ show $ containsS (Polygon [(-2,0), (0,2), (0,1), (-1,0), (2,0), (0,-2)]) (0.5, 0.5)
-- self-crossing example: (0,0), (0,0) => line has the same start and end points.
-- putStrLn $ show $ containsS (Polygon [(0,0), (0,0), (0,1), (1,0)]) (5,5)
-- self-crossing exmaple: (1,1), (5,5), (0,0) => lines overlap.
-- putStrLn $ show $ containsS (Polygon [(0,0), (-5,5), (1,-1), (0,1), (1,0)]) (5,5)
----- type/data used in this exercise -----
type Coordinate = (Float, Float)
type Ray = (Coordinate, Coordinate)
data Shape = Polygon [Coordinate] deriving Show
This entry was posted
on Monday, June 4th, 2007 at 7:12 am and is filed under Haskell - SOE.
You can follow any responses to this entry through the RSS 2.0 feed.
You can leave a response, or trackback from your own site.