Port to diagrams >1.3
# Conflicts: # Algebra/Vector.hs # CG2.cabal # Graphics/Diagram/Core.hs # Graphics/Diagram/Gif.hs # Graphics/Diagram/Gtk.hs # Test/Vector.hs
This commit is contained in:
parent
5120a44d0f
commit
984ed40c63
@ -10,9 +10,9 @@ import MyPrelude
|
|||||||
|
|
||||||
-- |Split a polygon by a given segment which must be vertices of the
|
-- |Split a polygon by a given segment which must be vertices of the
|
||||||
-- polygon (returns empty array otherwise).
|
-- polygon (returns empty array otherwise).
|
||||||
splitPoly :: [P2]
|
splitPoly :: [P2 Double]
|
||||||
-> (P2, P2)
|
-> (P2 Double, P2 Double)
|
||||||
-> [[P2]]
|
-> [[P2 Double]]
|
||||||
splitPoly pts (a, b)
|
splitPoly pts (a, b)
|
||||||
| elem a pts && elem b pts =
|
| elem a pts && elem b pts =
|
||||||
[b : takeWhile (/= b) shiftedPoly, a : dropWhile (/= b) shiftedPoly]
|
[b : takeWhile (/= b) shiftedPoly, a : dropWhile (/= b) shiftedPoly]
|
||||||
@ -22,7 +22,7 @@ splitPoly pts (a, b)
|
|||||||
|
|
||||||
|
|
||||||
-- |Get all edges of a polygon.
|
-- |Get all edges of a polygon.
|
||||||
polySegments :: [P2] -> [(P2, P2)]
|
polySegments :: [P2 Double] -> [(P2 Double, P2 Double)]
|
||||||
polySegments p@(x':_:_:_) = go p ++ [(last p, x')]
|
polySegments p@(x':_:_:_) = go p ++ [(last p, x')]
|
||||||
where
|
where
|
||||||
go (x:y:xs) = (x, y) : go (y:xs)
|
go (x:y:xs) = (x, y) : go (y:xs)
|
||||||
@ -33,7 +33,7 @@ polySegments _ = []
|
|||||||
-- |Check whether the given segment is inside the polygon.
|
-- |Check whether the given segment is inside the polygon.
|
||||||
-- This doesn't check for segments that are completely outside
|
-- This doesn't check for segments that are completely outside
|
||||||
-- of the polygon yet.
|
-- of the polygon yet.
|
||||||
isInsidePoly :: [P2] -> (P2, P2) -> Bool
|
isInsidePoly :: [P2 Double] -> (P2 Double, P2 Double) -> Bool
|
||||||
isInsidePoly pts seg =
|
isInsidePoly pts seg =
|
||||||
null
|
null
|
||||||
. catMaybes
|
. catMaybes
|
||||||
@ -42,21 +42,21 @@ isInsidePoly pts seg =
|
|||||||
|
|
||||||
|
|
||||||
-- |Check whether two points are adjacent vertices of a polygon.
|
-- |Check whether two points are adjacent vertices of a polygon.
|
||||||
adjacent :: P2 -> P2 -> [P2] -> Bool
|
adjacent :: P2 Double -> P2 Double -> [P2 Double] -> Bool
|
||||||
adjacent u v = any (\x -> x == (u, v) || x == (v, u)) . polySegments
|
adjacent u v = any (\x -> x == (u, v) || x == (v, u)) . polySegments
|
||||||
|
|
||||||
|
|
||||||
-- |Check whether the polygon is a triangle polygon.
|
-- |Check whether the polygon is a triangle polygon.
|
||||||
isTrianglePoly :: [P2] -> Bool
|
isTrianglePoly :: [P2 Double] -> Bool
|
||||||
isTrianglePoly [_, _, _] = True
|
isTrianglePoly [_, _, _] = True
|
||||||
isTrianglePoly _ = False
|
isTrianglePoly _ = False
|
||||||
|
|
||||||
|
|
||||||
-- |Get all triangle polygons.
|
-- |Get all triangle polygons.
|
||||||
triangleOnly :: [[P2]] -> [[P2]]
|
triangleOnly :: [[P2 Double]] -> [[P2 Double]]
|
||||||
triangleOnly = filter isTrianglePoly
|
triangleOnly = filter isTrianglePoly
|
||||||
|
|
||||||
|
|
||||||
-- |Get all non-triangle polygons.
|
-- |Get all non-triangle polygons.
|
||||||
nonTriangleOnly :: [[P2]] -> [[P2]]
|
nonTriangleOnly :: [[P2 Double]] -> [[P2 Double]]
|
||||||
nonTriangleOnly = filter (not . isTrianglePoly)
|
nonTriangleOnly = filter (not . isTrianglePoly)
|
||||||
|
@ -30,8 +30,8 @@ dimToSquare (x1, x2) (y1, y2) = ((x1, y1), (x2, y2))
|
|||||||
|
|
||||||
-- |Checks whether the Point is in a given Square.
|
-- |Checks whether the Point is in a given Square.
|
||||||
inRange :: ((Double, Double), (Double, Double)) -- ^ the square: ((xmin, ymin), (xmax, ymax))
|
inRange :: ((Double, Double), (Double, Double)) -- ^ the square: ((xmin, ymin), (xmax, ymax))
|
||||||
-> P2 -- ^ Coordinate
|
-> P2 Double -- ^ Coordinate
|
||||||
-> Bool -- ^ result
|
-> Bool -- ^ result
|
||||||
inRange ((xmin, ymin), (xmax, ymax)) (coords -> x :& y)
|
inRange ((xmin, ymin), (xmax, ymax)) (coords -> x :& y)
|
||||||
= x >= min xmin xmax
|
= x >= min xmin xmax
|
||||||
&& x <= max xmin xmax
|
&& x <= max xmin xmax
|
||||||
@ -40,7 +40,7 @@ inRange ((xmin, ymin), (xmax, ymax)) (coords -> x :& y)
|
|||||||
|
|
||||||
|
|
||||||
-- |Get the angle between two vectors.
|
-- |Get the angle between two vectors.
|
||||||
getAngle :: R2 -> R2 -> Double
|
getAngle :: V2 Double -> V2 Double -> Double
|
||||||
getAngle a b =
|
getAngle a b =
|
||||||
acos
|
acos
|
||||||
. flip (/) (vecLength a * vecLength b)
|
. flip (/) (vecLength a * vecLength b)
|
||||||
@ -49,50 +49,50 @@ getAngle a b =
|
|||||||
|
|
||||||
|
|
||||||
-- |Get the length of a vector.
|
-- |Get the length of a vector.
|
||||||
vecLength :: R2 -> Double
|
vecLength :: V2 Double -> Double
|
||||||
vecLength v = sqrt (x^(2 :: Int) + y^(2 :: Int))
|
vecLength v = sqrt (x^(2 :: Int) + y^(2 :: Int))
|
||||||
where
|
where
|
||||||
(x, y) = unr2 v
|
(x, y) = unr2 v
|
||||||
|
|
||||||
|
|
||||||
-- |Compute the scalar product of two vectors.
|
-- |Compute the scalar product of two vectors.
|
||||||
scalarProd :: R2 -> R2 -> Double
|
scalarProd :: V2 Double -> V2 Double -> Double
|
||||||
scalarProd (R2 a1 a2) (R2 b1 b2) = a1 * b1 + a2 * b2
|
scalarProd (V2 a1 a2) (V2 b1 b2) = a1 * b1 + a2 * b2
|
||||||
|
|
||||||
|
|
||||||
-- |Multiply a scalar with a vector.
|
-- |Multiply a scalar with a vector.
|
||||||
scalarMul :: Double -> R2 -> R2
|
scalarMul :: Double -> V2 Double -> V2 Double
|
||||||
scalarMul d (R2 a b) = R2 (a * d) (b * d)
|
scalarMul d (V2 a b) = V2 (a * d) (b * d)
|
||||||
|
|
||||||
|
|
||||||
-- |Construct a vector that points to a point from the origin.
|
-- |Construct a vector that points to a point from the origin.
|
||||||
pt2Vec :: P2 -> R2
|
pt2Vec :: P2 Double -> V2 Double
|
||||||
pt2Vec = r2 . unp2
|
pt2Vec = r2 . unp2
|
||||||
|
|
||||||
|
|
||||||
-- |Give the point which is at the coordinates the vector
|
-- |Give the point which is at the coordinates the vector
|
||||||
-- points to from the origin.
|
-- points to from the origin.
|
||||||
vec2Pt :: R2 -> P2
|
vec2Pt :: V2 Double -> P2 Double
|
||||||
vec2Pt = p2 . unr2
|
vec2Pt = p2 . unr2
|
||||||
|
|
||||||
|
|
||||||
-- |Construct a vector between two points.
|
-- |Construct a vector between two points.
|
||||||
vp2 :: P2 -- ^ vector origin
|
vp2 :: P2 Double -- ^ vector origin
|
||||||
-> P2 -- ^ vector points here
|
-> P2 Double -- ^ vector points here
|
||||||
-> R2
|
-> V2 Double
|
||||||
vp2 a b = pt2Vec b - pt2Vec a
|
vp2 a b = pt2Vec b - pt2Vec a
|
||||||
|
|
||||||
|
|
||||||
-- |Computes the determinant of 3 points.
|
-- |Computes the determinant of 3 points.
|
||||||
det :: P2 -> P2 -> P2 -> Double
|
det :: P2 Double -> P2 Double -> P2 Double -> Double
|
||||||
det (coords -> ax :& ay) (coords -> bx :& by) (coords -> cx :& cy) =
|
det (coords -> ax :& ay) (coords -> bx :& by) (coords -> cx :& cy) =
|
||||||
(bx - ax) * (cy - ay) - (by - ay) * (cx - ax)
|
(bx - ax) * (cy - ay) - (by - ay) * (cx - ax)
|
||||||
|
|
||||||
|
|
||||||
-- |Get the point where two lines intesect, if any.
|
-- |Get the point where two lines intesect, if any.
|
||||||
intersectSeg' :: (P2, P2) -- ^ first segment
|
intersectSeg' :: (P2 Double, P2 Double) -- ^ first segment
|
||||||
-> (P2, P2) -- ^ second segment
|
-> (P2 Double, P2 Double) -- ^ second segment
|
||||||
-> Maybe P2
|
-> Maybe (P2 Double)
|
||||||
intersectSeg' (a, b) (c, d) =
|
intersectSeg' (a, b) (c, d) =
|
||||||
glossToPt <$> intersectSegSeg (ptToGloss a)
|
glossToPt <$> intersectSegSeg (ptToGloss a)
|
||||||
(ptToGloss b)
|
(ptToGloss b)
|
||||||
@ -105,7 +105,7 @@ intersectSeg' (a, b) (c, d) =
|
|||||||
|
|
||||||
-- |Get the point where two lines intesect, if any. Excludes the
|
-- |Get the point where two lines intesect, if any. Excludes the
|
||||||
-- case of end-points intersecting.
|
-- case of end-points intersecting.
|
||||||
intersectSeg'' :: (P2, P2) -> (P2, P2) -> Maybe P2
|
intersectSeg'' :: (P2 Double, P2 Double) -> (P2 Double, P2 Double) -> Maybe (P2 Double)
|
||||||
intersectSeg'' (a, b) (c, d) = case intersectSeg' (a, b) (c, d) of
|
intersectSeg'' (a, b) (c, d) = case intersectSeg' (a, b) (c, d) of
|
||||||
Just x -> if x `notElem` [a,b,c,d] then Just a else Nothing
|
Just x -> if x `notElem` [a,b,c,d] then Just a else Nothing
|
||||||
Nothing -> Nothing
|
Nothing -> Nothing
|
||||||
@ -115,7 +115,7 @@ intersectSeg'' (a, b) (c, d) = case intersectSeg' (a, b) (c, d) of
|
|||||||
-- * clock-wise
|
-- * clock-wise
|
||||||
-- * counter-clock-wise
|
-- * counter-clock-wise
|
||||||
-- * collinear
|
-- * collinear
|
||||||
getOrient :: P2 -> P2 -> P2 -> Alignment
|
getOrient :: P2 Double -> P2 Double -> P2 Double -> Alignment
|
||||||
getOrient a b c = case compare (det a b c) 0 of
|
getOrient a b c = case compare (det a b c) 0 of
|
||||||
LT -> CW
|
LT -> CW
|
||||||
GT -> CCW
|
GT -> CCW
|
||||||
@ -125,7 +125,7 @@ getOrient a b c = case compare (det a b c) 0 of
|
|||||||
--- |Checks if 3 points a,b,c do not build a clockwise triangle by
|
--- |Checks if 3 points a,b,c do not build a clockwise triangle by
|
||||||
--- connecting a-b-c. This is done by computing the determinant and
|
--- connecting a-b-c. This is done by computing the determinant and
|
||||||
--- checking the algebraic sign.
|
--- checking the algebraic sign.
|
||||||
notcw :: P2 -> P2 -> P2 -> Bool
|
notcw :: P2 Double -> P2 Double -> P2 Double -> Bool
|
||||||
notcw a b c = case getOrient a b c of
|
notcw a b c = case getOrient a b c of
|
||||||
CW -> False
|
CW -> False
|
||||||
_ -> True
|
_ -> True
|
||||||
@ -134,22 +134,22 @@ notcw a b c = case getOrient a b c of
|
|||||||
--- |Checks if 3 points a,b,c do build a clockwise triangle by
|
--- |Checks if 3 points a,b,c do build a clockwise triangle by
|
||||||
--- connecting a-b-c. This is done by computing the determinant and
|
--- connecting a-b-c. This is done by computing the determinant and
|
||||||
--- checking the algebraic sign.
|
--- checking the algebraic sign.
|
||||||
cw :: P2 -> P2 -> P2 -> Bool
|
cw :: P2 Double -> P2 Double -> P2 Double -> Bool
|
||||||
cw a b c = not . notcw a b $ c
|
cw a b c = not . notcw a b $ c
|
||||||
|
|
||||||
|
|
||||||
-- |Sort X and Y coordinates lexicographically.
|
-- |Sort X and Y coordinates lexicographically.
|
||||||
sortedXY :: [P2] -> [P2]
|
sortedXY :: [P2 Double] -> [P2 Double]
|
||||||
sortedXY = fmap p2 . sortLex . fmap unp2
|
sortedXY = fmap p2 . sortLex . fmap unp2
|
||||||
|
|
||||||
|
|
||||||
-- |Sort Y and X coordinates lexicographically.
|
-- |Sort Y and X coordinates lexicographically.
|
||||||
sortedYX :: [P2] -> [P2]
|
sortedYX :: [P2 Double] -> [P2 Double]
|
||||||
sortedYX = fmap p2 . sortLexSwapped . fmap unp2
|
sortedYX = fmap p2 . sortLexSwapped . fmap unp2
|
||||||
|
|
||||||
|
|
||||||
-- |Sort all points according to their X-coordinates only.
|
-- |Sort all points according to their X-coordinates only.
|
||||||
sortedX :: [P2] -> [P2]
|
sortedX :: [P2 Double] -> [P2 Double]
|
||||||
sortedX xs =
|
sortedX xs =
|
||||||
fmap p2
|
fmap p2
|
||||||
. sortBy (\(a1, _) (a2, _) -> compare a1 a2)
|
. sortBy (\(a1, _) (a2, _) -> compare a1 a2)
|
||||||
@ -157,7 +157,7 @@ sortedX xs =
|
|||||||
|
|
||||||
|
|
||||||
-- |Sort all points according to their Y-coordinates only.
|
-- |Sort all points according to their Y-coordinates only.
|
||||||
sortedY :: [P2] -> [P2]
|
sortedY :: [P2 Double] -> [P2 Double]
|
||||||
sortedY xs =
|
sortedY xs =
|
||||||
fmap p2
|
fmap p2
|
||||||
. sortBy (\(_, b1) (_, b2) -> compare b1 b2)
|
. sortBy (\(_, b1) (_, b2) -> compare b1 b2)
|
||||||
@ -165,25 +165,25 @@ sortedY xs =
|
|||||||
|
|
||||||
|
|
||||||
-- |Apply a function on the coordinates of a point.
|
-- |Apply a function on the coordinates of a point.
|
||||||
onPT :: ((Double, Double) -> (Double, Double)) -> P2 -> P2
|
onPT :: ((Double, Double) -> (Double, Double)) -> P2 Double -> P2 Double
|
||||||
onPT f = p2 . f . unp2
|
onPT f = p2 . f . unp2
|
||||||
|
|
||||||
|
|
||||||
-- |Compare the y-coordinate of two points.
|
-- |Compare the y-coordinate of two points.
|
||||||
ptCmpY :: P2 -> P2 -> Ordering
|
ptCmpY :: P2 Double -> P2 Double -> Ordering
|
||||||
ptCmpY (coords -> _ :& y1) (coords -> _ :& y2) =
|
ptCmpY (coords -> _ :& y1) (coords -> _ :& y2) =
|
||||||
compare y1 y2
|
compare y1 y2
|
||||||
|
|
||||||
|
|
||||||
-- |Compare the x-coordinate of two points.
|
-- |Compare the x-coordinate of two points.
|
||||||
ptCmpX :: P2 -> P2 -> Ordering
|
ptCmpX :: P2 Double -> P2 Double -> Ordering
|
||||||
ptCmpX (coords -> x1 :& _) (coords -> x2 :& _) =
|
ptCmpX (coords -> x1 :& _) (coords -> x2 :& _) =
|
||||||
compare x1 x2
|
compare x1 x2
|
||||||
|
|
||||||
|
|
||||||
posInfPT :: P2
|
posInfPT :: P2 Double
|
||||||
posInfPT = p2 (read "Infinity", read "Infinity")
|
posInfPT = p2 (read "Infinity", read "Infinity")
|
||||||
|
|
||||||
|
|
||||||
negInfPT :: P2
|
negInfPT :: P2 Double
|
||||||
negInfPT = p2 (negate . read $ "Infinity", negate . read $ "Infinity")
|
negInfPT = p2 (negate . read $ "Infinity", negate . read $ "Infinity")
|
||||||
|
@ -75,18 +75,18 @@ ys = []
|
|||||||
return [(100, 100), (400, 200)]
|
return [(100, 100), (400, 200)]
|
||||||
=========================================================
|
=========================================================
|
||||||
--}
|
--}
|
||||||
grahamCH :: [P2] -> [P2]
|
grahamCH :: [P2 Double] -> [P2 Double]
|
||||||
grahamCH vs = grahamUCH vs ++ (tailInit . grahamLCH $ vs)
|
grahamCH vs = grahamUCH vs ++ (tailInit . grahamLCH $ vs)
|
||||||
|
|
||||||
|
|
||||||
-- |Get the lower part of the convex hull.
|
-- |Get the lower part of the convex hull.
|
||||||
grahamLCH :: [P2] -> [P2]
|
grahamLCH :: [P2 Double] -> [P2 Double]
|
||||||
grahamLCH vs = uncurry (\x y -> last . scanH x $ y)
|
grahamLCH vs = uncurry (\x y -> last . scanH x $ y)
|
||||||
(first reverse . splitAt 3 . sortedXY $ vs)
|
(first reverse . splitAt 3 . sortedXY $ vs)
|
||||||
|
|
||||||
|
|
||||||
-- |Get the upper part of the convex hull.
|
-- |Get the upper part of the convex hull.
|
||||||
grahamUCH :: [P2] -> [P2]
|
grahamUCH :: [P2 Double] -> [P2 Double]
|
||||||
grahamUCH vs = uncurry (\x y -> last . scanH x $ y)
|
grahamUCH vs = uncurry (\x y -> last . scanH x $ y)
|
||||||
(first reverse . splitAt 3 . reverse . sortedXY $ vs)
|
(first reverse . splitAt 3 . reverse . sortedXY $ vs)
|
||||||
|
|
||||||
@ -96,9 +96,9 @@ grahamUCH vs = uncurry (\x y -> last . scanH x $ y)
|
|||||||
-- If it's the upper or lower half depends on the input.
|
-- If it's the upper or lower half depends on the input.
|
||||||
-- Also, the first list is expected to be reversed since we only care
|
-- Also, the first list is expected to be reversed since we only care
|
||||||
-- about the last 3 elements and want to stay efficient.
|
-- about the last 3 elements and want to stay efficient.
|
||||||
scanH :: [P2] -- ^ the first 3 starting points in reversed order
|
scanH :: [P2 Double] -- ^ the first 3 starting points in reversed order
|
||||||
-> [P2] -- ^ the rest of the points
|
-> [P2 Double] -- ^ the rest of the points
|
||||||
-> [[P2]] -- ^ all convex hull points iterations for the half
|
-> [[P2 Double]] -- ^ all convex hull points iterations for the half
|
||||||
scanH hs@(x:y:z:xs) (r':rs')
|
scanH hs@(x:y:z:xs) (r':rs')
|
||||||
| notcw z y x = hs : scanH (r':hs) rs'
|
| notcw z y x = hs : scanH (r':hs) rs'
|
||||||
| otherwise = hs : scanH (x:z:xs) (r':rs')
|
| otherwise = hs : scanH (x:z:xs) (r':rs')
|
||||||
@ -112,12 +112,12 @@ scanH hs _ = [hs]
|
|||||||
-- |Compute all steps of the graham scan algorithm to allow
|
-- |Compute all steps of the graham scan algorithm to allow
|
||||||
-- visualizing it.
|
-- visualizing it.
|
||||||
-- Whether the upper or lower hull is computed depends on the input.
|
-- Whether the upper or lower hull is computed depends on the input.
|
||||||
grahamCHSteps :: Int -> [P2] -> [P2] -> [[P2]]
|
grahamCHSteps :: Int -> [P2 Double] -> [P2 Double] -> [[P2 Double]]
|
||||||
grahamCHSteps c xs' ys' = take c . scanH xs' $ ys'
|
grahamCHSteps c xs' ys' = take c . scanH xs' $ ys'
|
||||||
|
|
||||||
|
|
||||||
-- |Get all iterations of the upper hull of the graham scan algorithm.
|
-- |Get all iterations of the upper hull of the graham scan algorithm.
|
||||||
grahamUHSteps :: [P2] -> [[P2]]
|
grahamUHSteps :: [P2 Double] -> [[P2 Double]]
|
||||||
grahamUHSteps vs =
|
grahamUHSteps vs =
|
||||||
(++) [getLastX 2 . sortedXY $ vs]
|
(++) [getLastX 2 . sortedXY $ vs]
|
||||||
. rmdups
|
. rmdups
|
||||||
@ -128,7 +128,7 @@ grahamUHSteps vs =
|
|||||||
|
|
||||||
|
|
||||||
-- |Get all iterations of the lower hull of the graham scan algorithm.
|
-- |Get all iterations of the lower hull of the graham scan algorithm.
|
||||||
grahamLHSteps :: [P2] -> [[P2]]
|
grahamLHSteps :: [P2 Double] -> [[P2 Double]]
|
||||||
grahamLHSteps vs =
|
grahamLHSteps vs =
|
||||||
(++) [take 2 . sortedXY $ vs]
|
(++) [take 2 . sortedXY $ vs]
|
||||||
. rmdups
|
. rmdups
|
||||||
|
@ -42,9 +42,9 @@ instance Not Direction where
|
|||||||
|
|
||||||
|
|
||||||
-- |Construct a kd-tree from a list of points in O(n log n).
|
-- |Construct a kd-tree from a list of points in O(n log n).
|
||||||
kdTree :: [P2] -- ^ list of points to construct the kd-tree from
|
kdTree :: [P2 Double] -- ^ list of points to construct the kd-tree from
|
||||||
-> Direction -- ^ initial direction of the root-node
|
-> Direction -- ^ initial direction of the root-node
|
||||||
-> KDTree P2 -- ^ resulting kd-tree
|
-> KDTree (P2 Double) -- ^ resulting kd-tree
|
||||||
kdTree xs' = go (sortedX xs') (sortedY xs')
|
kdTree xs' = go (sortedX xs') (sortedY xs')
|
||||||
where
|
where
|
||||||
go [] _ _ = KTNil
|
go [] _ _ = KTNil
|
||||||
@ -67,10 +67,10 @@ kdTree xs' = go (sortedX xs') (sortedY xs')
|
|||||||
-- If you want to partition against the pivot of X, then you pass
|
-- If you want to partition against the pivot of X, then you pass
|
||||||
-- partition' (pivot xs) (ys, xs)
|
-- partition' (pivot xs) (ys, xs)
|
||||||
-- and get ((y1, y2), (x1, x2)).
|
-- and get ((y1, y2), (x1, x2)).
|
||||||
partition' :: P2 -- ^ the pivot to partition against
|
partition' :: P2 Double -- ^ the pivot to partition against
|
||||||
-> (P2 -> P2 -> Ordering) -- ^ ptCmpY or ptCmpX
|
-> (P2 Double -> P2 Double -> Ordering) -- ^ ptCmpY or ptCmpX
|
||||||
-> ([P2], [P2]) -- ^ both lists (X, Y) or (Y, X)
|
-> ([P2 Double], [P2 Double]) -- ^ both lists (X, Y) or (Y, X)
|
||||||
-> (([P2], [P2]), ([P2], [P2])) -- ^ ((x1, x2), (y1, y2)) or
|
-> (([P2 Double], [P2 Double]), ([P2 Double], [P2 Double])) -- ^ ((x1, x2), (y1, y2)) or
|
||||||
-- ((y1, y2), (x1, x2))
|
-- ((y1, y2), (x1, x2))
|
||||||
partition' piv cmp' (xs, ys) = ((x1, x2), (y1, y2))
|
partition' piv cmp' (xs, ys) = ((x1, x2), (y1, y2))
|
||||||
where
|
where
|
||||||
@ -83,16 +83,16 @@ partition' piv cmp' (xs, ys) = ((x1, x2), (y1, y2))
|
|||||||
-- |Partition two sorted lists of points X and Y against the pivot of
|
-- |Partition two sorted lists of points X and Y against the pivot of
|
||||||
-- Y. This function is unsafe as it does not check if there is a valid
|
-- Y. This function is unsafe as it does not check if there is a valid
|
||||||
-- pivot.
|
-- pivot.
|
||||||
partitionY :: ([P2], [P2]) -- ^ both lists (X, Y)
|
partitionY :: ([P2 Double], [P2 Double]) -- ^ both lists (X, Y)
|
||||||
-> (([P2], [P2]), ([P2], [P2])) -- ^ ((x1, x2), (y1, y2))
|
-> (([P2 Double], [P2 Double]), ([P2 Double], [P2 Double])) -- ^ ((x1, x2), (y1, y2))
|
||||||
partitionY (xs, ys) = partition' (fromJust . pivot $ ys) ptCmpY (xs, ys)
|
partitionY (xs, ys) = partition' (fromJust . pivot $ ys) ptCmpY (xs, ys)
|
||||||
|
|
||||||
|
|
||||||
-- |Partition two sorted lists of points X and Y against the pivot of
|
-- |Partition two sorted lists of points X and Y against the pivot of
|
||||||
-- X. This function is unsafe as it does not check if there is a valid
|
-- X. This function is unsafe as it does not check if there is a valid
|
||||||
-- pivot.
|
-- pivot.
|
||||||
partitionX :: ([P2], [P2]) -- ^ both lists (X, Y)
|
partitionX :: ([P2 Double], [P2 Double]) -- ^ both lists (X, Y)
|
||||||
-> (([P2], [P2]), ([P2], [P2])) -- ^ ((x1, x2), (y1, y2))
|
-> (([P2 Double], [P2 Double]), ([P2 Double], [P2 Double])) -- ^ ((x1, x2), (y1, y2))
|
||||||
partitionX (xs, ys) = (\(x, y) -> (y, x))
|
partitionX (xs, ys) = (\(x, y) -> (y, x))
|
||||||
. partition' (fromJust . pivot $ xs) ptCmpX $ (ys, xs)
|
. partition' (fromJust . pivot $ xs) ptCmpX $ (ys, xs)
|
||||||
|
|
||||||
@ -100,9 +100,9 @@ partitionX (xs, ys) = (\(x, y) -> (y, x))
|
|||||||
-- |Execute a range search in O(log n). It returns a tuple
|
-- |Execute a range search in O(log n). It returns a tuple
|
||||||
-- of the points found in the range and also gives back a pretty
|
-- of the points found in the range and also gives back a pretty
|
||||||
-- rose tree suitable for printing.
|
-- rose tree suitable for printing.
|
||||||
rangeSearch :: KDTree P2 -- ^ tree to search in
|
rangeSearch :: KDTree (P2 Double) -- ^ tree to search in
|
||||||
-> ((Double, Double), (Double, Double)) -- ^ square describing the range
|
-> ((Double, Double), (Double, Double)) -- ^ square describing the range
|
||||||
-> ([P2], Tree String)
|
-> ([P2 Double], Tree String)
|
||||||
rangeSearch kd' sq' = (goPt kd' sq', goTree kd' sq' True)
|
rangeSearch kd' sq' = (goPt kd' sq', goTree kd' sq' True)
|
||||||
where
|
where
|
||||||
-- either y1 or x1 depending on the orientation
|
-- either y1 or x1 depending on the orientation
|
||||||
@ -112,7 +112,7 @@ rangeSearch kd' sq' = (goPt kd' sq', goTree kd' sq' True)
|
|||||||
-- either the second or first of the tuple, depending on the orientation
|
-- either the second or first of the tuple, depending on the orientation
|
||||||
cur' dir = if' (dir == Vertical) snd fst
|
cur' dir = if' (dir == Vertical) snd fst
|
||||||
-- All points in the range.
|
-- All points in the range.
|
||||||
goPt :: KDTree P2 -> ((Double, Double), (Double, Double)) -> [P2]
|
goPt :: KDTree (P2 Double) -> ((Double, Double), (Double, Double)) -> [P2 Double]
|
||||||
goPt KTNil _ = []
|
goPt KTNil _ = []
|
||||||
goPt (KTNode ln pt dir rn) sq =
|
goPt (KTNode ln pt dir rn) sq =
|
||||||
[pt | inRange sq pt]
|
[pt | inRange sq pt]
|
||||||
@ -124,7 +124,7 @@ rangeSearch kd' sq' = (goPt kd' sq', goTree kd' sq' True)
|
|||||||
(goPt rn sq)
|
(goPt rn sq)
|
||||||
[])
|
[])
|
||||||
-- A pretty rose tree suitable for printing.
|
-- A pretty rose tree suitable for printing.
|
||||||
goTree :: KDTree P2 -> ((Double, Double), (Double, Double)) -> Bool -> Tree String
|
goTree :: KDTree (P2 Double) -> ((Double, Double), (Double, Double)) -> Bool -> Tree String
|
||||||
goTree KTNil _ _ = Node "nil" []
|
goTree KTNil _ _ = Node "nil" []
|
||||||
goTree (KTNode ln pt dir rn) sq vis
|
goTree (KTNode ln pt dir rn) sq vis
|
||||||
| ln == KTNil && rn == KTNil = Node treeText []
|
| ln == KTNil && rn == KTNil = Node treeText []
|
||||||
@ -181,7 +181,7 @@ getDirection _ = Nothing
|
|||||||
|
|
||||||
|
|
||||||
-- |Convert a kd-tree to a rose tree, for pretty printing.
|
-- |Convert a kd-tree to a rose tree, for pretty printing.
|
||||||
kdTreeToRoseTree :: KDTree P2 -> Tree String
|
kdTreeToRoseTree :: KDTree (P2 Double) -> Tree String
|
||||||
kdTreeToRoseTree (KTNil) = Node "nil" []
|
kdTreeToRoseTree (KTNil) = Node "nil" []
|
||||||
kdTreeToRoseTree (KTNode ln val _ rn) =
|
kdTreeToRoseTree (KTNode ln val _ rn) =
|
||||||
Node (show . unp2 $ val) [kdTreeToRoseTree ln, kdTreeToRoseTree rn]
|
Node (show . unp2 $ val) [kdTreeToRoseTree ln, kdTreeToRoseTree rn]
|
||||||
|
@ -18,14 +18,14 @@ import QueueEx
|
|||||||
-- successor are saved for convenience.
|
-- successor are saved for convenience.
|
||||||
data PolyPT =
|
data PolyPT =
|
||||||
PolyA {
|
PolyA {
|
||||||
id' :: P2
|
id' :: P2 Double
|
||||||
, pre :: P2
|
, pre :: P2 Double
|
||||||
, suc :: P2
|
, suc :: P2 Double
|
||||||
}
|
}
|
||||||
| PolyB {
|
| PolyB {
|
||||||
id' :: P2
|
id' :: P2 Double
|
||||||
, pre :: P2
|
, pre :: P2 Double
|
||||||
, suc :: P2
|
, suc :: P2 Double
|
||||||
}
|
}
|
||||||
deriving (Show, Eq)
|
deriving (Show, Eq)
|
||||||
|
|
||||||
@ -42,7 +42,7 @@ isPolyB = not . isPolyA
|
|||||||
-- |Shift a list of sorted convex hull points of a polygon so that
|
-- |Shift a list of sorted convex hull points of a polygon so that
|
||||||
-- the first element in the list is the one with the highest y-coordinate.
|
-- the first element in the list is the one with the highest y-coordinate.
|
||||||
-- This is done in O(n).
|
-- This is done in O(n).
|
||||||
sortLexPoly :: [P2] -> [P2]
|
sortLexPoly :: [P2 Double] -> [P2 Double]
|
||||||
sortLexPoly ps = maybe [] (`shiftM` ps) (elemIndex (yMax ps) ps)
|
sortLexPoly ps = maybe [] (`shiftM` ps) (elemIndex (yMax ps) ps)
|
||||||
where
|
where
|
||||||
yMax = foldl1 (\x y -> if ptCmpY x y == GT then x else y)
|
yMax = foldl1 (\x y -> if ptCmpY x y == GT then x else y)
|
||||||
@ -50,8 +50,8 @@ sortLexPoly ps = maybe [] (`shiftM` ps) (elemIndex (yMax ps) ps)
|
|||||||
|
|
||||||
-- |Make a PolyPT list out of a regular list of points, so
|
-- |Make a PolyPT list out of a regular list of points, so
|
||||||
-- the predecessor and successors are all saved.
|
-- the predecessor and successors are all saved.
|
||||||
mkPolyPTList :: (P2 -> P2 -> P2 -> PolyPT) -- ^ PolyA or PolyB function
|
mkPolyPTList :: (P2 Double -> P2 Double -> P2 Double -> PolyPT) -- ^ PolyA or PolyB function
|
||||||
-> [P2] -- ^ polygon points
|
-> [P2 Double] -- ^ polygon points
|
||||||
-> [PolyPT]
|
-> [PolyPT]
|
||||||
mkPolyPTList f' pts@(x':y':_:_) =
|
mkPolyPTList f' pts@(x':y':_:_) =
|
||||||
f' x' (last pts) y' : go f' pts
|
f' x' (last pts) y' : go f' pts
|
||||||
@ -64,7 +64,7 @@ mkPolyPTList _ _ = []
|
|||||||
|
|
||||||
-- |Sort the points of two polygons according to their y-coordinates,
|
-- |Sort the points of two polygons according to their y-coordinates,
|
||||||
-- while saving the origin of that point. This is done in O(n).
|
-- while saving the origin of that point. This is done in O(n).
|
||||||
sortLexPolys :: ([P2], [P2]) -> [PolyPT]
|
sortLexPolys :: ([P2 Double], [P2 Double]) -> [PolyPT]
|
||||||
sortLexPolys (pA'@(_:_), pB'@(_:_)) =
|
sortLexPolys (pA'@(_:_), pB'@(_:_)) =
|
||||||
queueToList $ go (Q.fromList . mkPolyPTList PolyA . sortLexPoly $ pA')
|
queueToList $ go (Q.fromList . mkPolyPTList PolyA . sortLexPoly $ pA')
|
||||||
(Q.fromList . mkPolyPTList PolyB . sortLexPoly $ pB')
|
(Q.fromList . mkPolyPTList PolyB . sortLexPoly $ pB')
|
||||||
@ -104,7 +104,7 @@ sortLexPolys _ = []
|
|||||||
|
|
||||||
-- |Get all points that intersect between both polygons. This is done
|
-- |Get all points that intersect between both polygons. This is done
|
||||||
-- in O(n).
|
-- in O(n).
|
||||||
intersectionPoints :: [PolyPT] -> [P2]
|
intersectionPoints :: [PolyPT] -> [P2 Double]
|
||||||
intersectionPoints xs' = rmdups . go $ xs'
|
intersectionPoints xs' = rmdups . go $ xs'
|
||||||
where
|
where
|
||||||
go [] = []
|
go [] = []
|
||||||
@ -113,7 +113,7 @@ intersectionPoints xs' = rmdups . go $ xs'
|
|||||||
|
|
||||||
-- Get the scan line or in other words the
|
-- Get the scan line or in other words the
|
||||||
-- Segment pairs we are going to check for intersection.
|
-- Segment pairs we are going to check for intersection.
|
||||||
scanLine :: [PolyPT] -> ([(P2, P2)], [(P2, P2)])
|
scanLine :: [PolyPT] -> ([(P2 Double, P2 Double)], [(P2 Double, P2 Double)])
|
||||||
scanLine sp@(_:_) = (,) (getSegment isPolyA) (getSegment isPolyB)
|
scanLine sp@(_:_) = (,) (getSegment isPolyA) (getSegment isPolyB)
|
||||||
where
|
where
|
||||||
getSegment f = fromMaybe []
|
getSegment f = fromMaybe []
|
||||||
@ -124,7 +124,7 @@ intersectionPoints xs' = rmdups . go $ xs'
|
|||||||
-- Gets the actual intersections between the segments of
|
-- Gets the actual intersections between the segments of
|
||||||
-- both polygons we currently examine. This is done in O(1)
|
-- both polygons we currently examine. This is done in O(1)
|
||||||
-- since we have max 4 segments.
|
-- since we have max 4 segments.
|
||||||
segIntersections :: ([(P2, P2)], [(P2, P2)]) -> [P2]
|
segIntersections :: ([(P2 Double, P2 Double)], [(P2 Double, P2 Double)]) -> [P2 Double]
|
||||||
segIntersections (a@(_:_), b@(_:_)) =
|
segIntersections (a@(_:_), b@(_:_)) =
|
||||||
catMaybes
|
catMaybes
|
||||||
. fmap (\[x, y] -> intersectSeg' x y)
|
. fmap (\[x, y] -> intersectSeg' x y)
|
||||||
|
@ -19,12 +19,12 @@ data VCategory = VStart
|
|||||||
|
|
||||||
|
|
||||||
-- |Classify all vertices on a polygon into five categories (see VCategory).
|
-- |Classify all vertices on a polygon into five categories (see VCategory).
|
||||||
classifyList :: [P2] -> [(P2, VCategory)]
|
classifyList :: [P2 Double] -> [(P2 Double, VCategory)]
|
||||||
classifyList p@(x:y:_:_) =
|
classifyList p@(x:y:_:_) =
|
||||||
-- need to handle the first and last element separately
|
-- need to handle the first and last element separately
|
||||||
[classify (last p) x y] ++ go p ++ [classify (last . init $ p) (last p) x]
|
[classify (last p) x y] ++ go p ++ [classify (last . init $ p) (last p) x]
|
||||||
where
|
where
|
||||||
go :: [P2] -> [(P2, VCategory)]
|
go :: [P2 Double] -> [(P2 Double, VCategory)]
|
||||||
go (x':y':z':xs) = classify x' y' z' : go (y':z':xs)
|
go (x':y':z':xs) = classify x' y' z' : go (y':z':xs)
|
||||||
go _ = []
|
go _ = []
|
||||||
classifyList _ = []
|
classifyList _ = []
|
||||||
@ -32,10 +32,10 @@ classifyList _ = []
|
|||||||
|
|
||||||
-- |Classify a vertex on a polygon given it's next and previous vertex
|
-- |Classify a vertex on a polygon given it's next and previous vertex
|
||||||
-- into five categories (see VCategory).
|
-- into five categories (see VCategory).
|
||||||
classify :: P2 -- ^ prev vertex
|
classify :: P2 Double -- ^ prev vertex
|
||||||
-> P2 -- ^ classify this one
|
-> P2 Double -- ^ classify this one
|
||||||
-> P2 -- ^ next vertex
|
-> P2 Double -- ^ next vertex
|
||||||
-> (P2, VCategory)
|
-> (P2 Double, VCategory)
|
||||||
classify prev v next
|
classify prev v next
|
||||||
| isVStart prev v next = (v, VStart)
|
| isVStart prev v next = (v, VStart)
|
||||||
| isVSplit prev v next = (v, VSplit)
|
| isVSplit prev v next = (v, VSplit)
|
||||||
@ -46,9 +46,9 @@ classify prev v next
|
|||||||
|
|
||||||
-- |Whether the vertex, given it's next and previous vertex,
|
-- |Whether the vertex, given it's next and previous vertex,
|
||||||
-- is a start vertex.
|
-- is a start vertex.
|
||||||
isVStart :: P2 -- ^ previous vertex
|
isVStart :: P2 Double -- ^ previous vertex
|
||||||
-> P2 -- ^ vertice to check
|
-> P2 Double -- ^ vertice to check
|
||||||
-> P2 -- ^ next vertex
|
-> P2 Double -- ^ next vertex
|
||||||
-> Bool
|
-> Bool
|
||||||
isVStart prev v next =
|
isVStart prev v next =
|
||||||
ptCmpY next v == LT && ptCmpY prev v == LT && cw next v prev
|
ptCmpY next v == LT && ptCmpY prev v == LT && cw next v prev
|
||||||
@ -56,9 +56,9 @@ isVStart prev v next =
|
|||||||
|
|
||||||
-- |Whether the vertex, given it's next and previous vertex,
|
-- |Whether the vertex, given it's next and previous vertex,
|
||||||
-- is a split vertex.
|
-- is a split vertex.
|
||||||
isVSplit :: P2 -- ^ previous vertex
|
isVSplit :: P2 Double -- ^ previous vertex
|
||||||
-> P2 -- ^ vertice to check
|
-> P2 Double -- ^ vertice to check
|
||||||
-> P2 -- ^ next vertex
|
-> P2 Double -- ^ next vertex
|
||||||
-> Bool
|
-> Bool
|
||||||
isVSplit prev v next =
|
isVSplit prev v next =
|
||||||
ptCmpY prev v == LT && ptCmpY next v == LT && cw prev v next
|
ptCmpY prev v == LT && ptCmpY next v == LT && cw prev v next
|
||||||
@ -66,9 +66,9 @@ isVSplit prev v next =
|
|||||||
|
|
||||||
-- |Whether the vertex, given it's next and previous vertex,
|
-- |Whether the vertex, given it's next and previous vertex,
|
||||||
-- is an end vertex.
|
-- is an end vertex.
|
||||||
isVEnd :: P2 -- ^ previous vertex
|
isVEnd :: P2 Double -- ^ previous vertex
|
||||||
-> P2 -- ^ vertice to check
|
-> P2 Double -- ^ vertice to check
|
||||||
-> P2 -- ^ next vertex
|
-> P2 Double -- ^ next vertex
|
||||||
-> Bool
|
-> Bool
|
||||||
isVEnd prev v next =
|
isVEnd prev v next =
|
||||||
ptCmpY prev v == GT && ptCmpY next v == GT && cw next v prev
|
ptCmpY prev v == GT && ptCmpY next v == GT && cw next v prev
|
||||||
@ -76,9 +76,9 @@ isVEnd prev v next =
|
|||||||
|
|
||||||
-- |Whether the vertex, given it's next and previous vertex,
|
-- |Whether the vertex, given it's next and previous vertex,
|
||||||
-- is a merge vertex.
|
-- is a merge vertex.
|
||||||
isVMerge :: P2 -- ^ previous vertex
|
isVMerge :: P2 Double -- ^ previous vertex
|
||||||
-> P2 -- ^ vertice to check
|
-> P2 Double -- ^ vertice to check
|
||||||
-> P2 -- ^ next vertex
|
-> P2 Double -- ^ next vertex
|
||||||
-> Bool
|
-> Bool
|
||||||
isVMerge prev v next =
|
isVMerge prev v next =
|
||||||
ptCmpY next v == GT && ptCmpY prev v == GT && cw prev v next
|
ptCmpY next v == GT && ptCmpY prev v == GT && cw prev v next
|
||||||
@ -86,9 +86,9 @@ isVMerge prev v next =
|
|||||||
|
|
||||||
-- |Whether the vertex, given it's next and previous vertex,
|
-- |Whether the vertex, given it's next and previous vertex,
|
||||||
-- is a regular vertex.
|
-- is a regular vertex.
|
||||||
isVRegular :: P2 -- ^ previous vertex
|
isVRegular :: P2 Double -- ^ previous vertex
|
||||||
-> P2 -- ^ vertice to check
|
-> P2 Double -- ^ vertice to check
|
||||||
-> P2 -- ^ next vertex
|
-> P2 Double -- ^ next vertex
|
||||||
-> Bool
|
-> Bool
|
||||||
isVRegular prev v next =
|
isVRegular prev v next =
|
||||||
(not . isVStart prev v $ next)
|
(not . isVStart prev v $ next)
|
||||||
@ -99,7 +99,7 @@ isVRegular prev v next =
|
|||||||
|
|
||||||
|
|
||||||
-- |A polygon P is y-monotone, if it has no split and merge vertices.
|
-- |A polygon P is y-monotone, if it has no split and merge vertices.
|
||||||
isYmonotone :: [P2] -> Bool
|
isYmonotone :: [P2 Double] -> Bool
|
||||||
isYmonotone poly =
|
isYmonotone poly =
|
||||||
not
|
not
|
||||||
. any (\x -> x == VSplit || x == VMerge)
|
. any (\x -> x == VSplit || x == VMerge)
|
||||||
@ -108,12 +108,12 @@ isYmonotone poly =
|
|||||||
|
|
||||||
|
|
||||||
-- |Partition P into y-monotone pieces.
|
-- |Partition P into y-monotone pieces.
|
||||||
monotonePartitioning :: [P2] -> [[P2]]
|
monotonePartitioning :: [P2 Double] -> [[P2 Double]]
|
||||||
monotonePartitioning pts
|
monotonePartitioning pts
|
||||||
| isYmonotone pts = [pts]
|
| isYmonotone pts = [pts]
|
||||||
| otherwise = go (monotoneDiagonals pts) pts
|
| otherwise = go (monotoneDiagonals pts) pts
|
||||||
where
|
where
|
||||||
go :: [(P2, P2)] -> [P2] -> [[P2]]
|
go :: [(P2 Double, P2 Double)] -> [P2 Double] -> [[P2 Double]]
|
||||||
go (x:xs) pts'@(_:_)
|
go (x:xs) pts'@(_:_)
|
||||||
| isYmonotone a && isYmonotone b = [a, b]
|
| isYmonotone a && isYmonotone b = [a, b]
|
||||||
| isYmonotone b = b : go xs a
|
| isYmonotone b = b : go xs a
|
||||||
@ -125,37 +125,37 @@ monotonePartitioning pts
|
|||||||
|
|
||||||
-- |Try to eliminate the merge and split vertices by computing the
|
-- |Try to eliminate the merge and split vertices by computing the
|
||||||
-- diagonals we have to use for splitting the polygon.
|
-- diagonals we have to use for splitting the polygon.
|
||||||
monotoneDiagonals :: [P2] -> [(P2, P2)]
|
monotoneDiagonals :: [P2 Double] -> [(P2 Double, P2 Double)]
|
||||||
monotoneDiagonals pts = catMaybes . go $ classifyList pts
|
monotoneDiagonals pts = catMaybes . go $ classifyList pts
|
||||||
where
|
where
|
||||||
go :: [(P2, VCategory)] -> [Maybe (P2, P2)]
|
go :: [(P2 Double, VCategory)] -> [Maybe (P2 Double, P2 Double)]
|
||||||
go (x:xs) = case snd x of
|
go (x:xs) = case snd x of
|
||||||
VMerge -> getSeg (belowS . fst $ x) (fst x) : go xs
|
VMerge -> getSeg (belowS . fst $ x) (fst x) : go xs
|
||||||
VSplit -> getSeg (aboveS . fst $ x) (fst x) : go xs
|
VSplit -> getSeg (aboveS . fst $ x) (fst x) : go xs
|
||||||
_ -> [] ++ go xs
|
_ -> [] ++ go xs
|
||||||
go [] = []
|
go [] = []
|
||||||
getSeg :: [P2] -- all points above/below the current point
|
getSeg :: [P2 Double] -- all points above/below the current point
|
||||||
-> P2 -- current point
|
-> P2 Double -- current point
|
||||||
-> Maybe (P2, P2)
|
-> Maybe (P2 Double, P2 Double)
|
||||||
getSeg [] _ = Nothing
|
getSeg [] _ = Nothing
|
||||||
getSeg (z:zs) pt
|
getSeg (z:zs) pt
|
||||||
| isInsidePoly pts (z, pt) = Just (z, pt)
|
| isInsidePoly pts (z, pt) = Just (z, pt)
|
||||||
| otherwise = getSeg zs pt
|
| otherwise = getSeg zs pt
|
||||||
aboveS :: P2 -> [P2]
|
aboveS :: P2 Double -> [P2 Double]
|
||||||
aboveS pt = tail . dropWhile (/= pt) $ sortedYX pts
|
aboveS pt = tail . dropWhile (/= pt) $ sortedYX pts
|
||||||
belowS :: P2 -> [P2]
|
belowS :: P2 Double -> [P2 Double]
|
||||||
belowS pt = reverse . takeWhile (/= pt) $ sortedYX pts
|
belowS pt = reverse . takeWhile (/= pt) $ sortedYX pts
|
||||||
|
|
||||||
|
|
||||||
-- |Triangulate a y-monotone polygon.
|
-- |Triangulate a y-monotone polygon.
|
||||||
triangulate :: [P2] -> [[P2]]
|
triangulate :: [P2 Double] -> [[P2 Double]]
|
||||||
triangulate pts =
|
triangulate pts =
|
||||||
go pts . A.first reverse . splitAt 3 . reverse . sortedYX $ pts
|
go pts . A.first reverse . splitAt 3 . reverse . sortedYX $ pts
|
||||||
where
|
where
|
||||||
go :: [P2] -- current polygon
|
go :: [P2 Double] -- current polygon
|
||||||
-> ([P2], [P2]) -- (stack of visited vertices, rest)
|
-> ([P2 Double], [P2 Double]) -- (stack of visited vertices, rest)
|
||||||
-- sorted by Y-coordinate
|
-- sorted by Y-coordinate
|
||||||
-> [[P2]]
|
-> [[P2 Double]]
|
||||||
go xs (p@[_, _], r:rs) = go xs (r:p, rs)
|
go xs (p@[_, _], r:rs) = go xs (r:p, rs)
|
||||||
go xs (p@(u:vi:vi1:ys), rs)
|
go xs (p@(u:vi:vi1:ys), rs)
|
||||||
-- case 1 and 3
|
-- case 1 and 3
|
||||||
|
@ -80,9 +80,9 @@ isSEchild _ = False
|
|||||||
-- |Builds a quadtree of a list of points which recursively divides up 2D
|
-- |Builds a quadtree of a list of points which recursively divides up 2D
|
||||||
-- space into quadrants, so that every leaf-quadrant stores either zero or one
|
-- space into quadrants, so that every leaf-quadrant stores either zero or one
|
||||||
-- point.
|
-- point.
|
||||||
quadTree :: [P2] -- ^ the points to divide
|
quadTree :: [P2 Double] -- ^ the points to divide
|
||||||
-> ((Double, Double), (Double, Double)) -- ^ the initial square around the points
|
-> ((Double, Double), (Double, Double)) -- ^ the initial square around the points
|
||||||
-> QuadTree P2 -- ^ the quad tree
|
-> QuadTree (P2 Double) -- ^ the quad tree
|
||||||
quadTree [] _ = TNil
|
quadTree [] _ = TNil
|
||||||
quadTree [pt] _ = TLeaf pt
|
quadTree [pt] _ = TLeaf pt
|
||||||
quadTree pts sq = TNode (quadTree nWPT . nwSq $ sq) (quadTree nEPT . neSq $ sq)
|
quadTree pts sq = TNode (quadTree nWPT . nwSq $ sq) (quadTree nEPT . neSq $ sq)
|
||||||
@ -97,7 +97,7 @@ quadTree pts sq = TNode (quadTree nWPT . nwSq $ sq) (quadTree nEPT . neSq $ sq)
|
|||||||
|
|
||||||
-- |Get all squares of a quad tree.
|
-- |Get all squares of a quad tree.
|
||||||
quadTreeSquares :: ((Double, Double), (Double, Double)) -- ^ the initial square around the points
|
quadTreeSquares :: ((Double, Double), (Double, Double)) -- ^ the initial square around the points
|
||||||
-> QuadTree P2 -- ^ the quad tree
|
-> QuadTree (P2 Double) -- ^ the quad tree
|
||||||
-> [((Double, Double), (Double, Double))] -- ^ all squares of the quad tree
|
-> [((Double, Double), (Double, Double))] -- ^ all squares of the quad tree
|
||||||
quadTreeSquares sq (TNil) = [sq]
|
quadTreeSquares sq (TNil) = [sq]
|
||||||
quadTreeSquares sq (TLeaf _) = [sq]
|
quadTreeSquares sq (TLeaf _) = [sq]
|
||||||
@ -203,7 +203,7 @@ lookupByNeighbors :: [Orient] -> QTZipper a -> Maybe (QTZipper a)
|
|||||||
lookupByNeighbors = flip (foldlM (flip findNeighbor))
|
lookupByNeighbors = flip (foldlM (flip findNeighbor))
|
||||||
|
|
||||||
|
|
||||||
quadTreeToRoseTree :: QTZipper P2 -> Tree String
|
quadTreeToRoseTree :: QTZipper (P2 Double) -> Tree String
|
||||||
quadTreeToRoseTree z' = go (rootNode z')
|
quadTreeToRoseTree z' = go (rootNode z')
|
||||||
where
|
where
|
||||||
go z = case z of
|
go z = case z of
|
||||||
|
42
CG2.cabal
42
CG2.cabal
@ -76,21 +76,20 @@ executable Gtk
|
|||||||
|
|
||||||
-- Other library packages from which modules are imported.
|
-- Other library packages from which modules are imported.
|
||||||
build-depends: attoparsec >= 0.12.1.1,
|
build-depends: attoparsec >= 0.12.1.1,
|
||||||
base >=4.6 && <4.8,
|
base >=4.6,
|
||||||
bytestring >= 0.10.4.0,
|
bytestring >= 0.10.4.0,
|
||||||
containers >= 0.5.0.0,
|
containers >= 0.5.0.0,
|
||||||
dequeue >= 0.1.5,
|
dequeue >= 0.1.5,
|
||||||
diagrams-lib >=1.2 && <1.3,
|
diagrams-lib >=1.3,
|
||||||
diagrams-cairo >=1.2 && <1.3,
|
diagrams-cairo >=1.3,
|
||||||
diagrams-contrib >= 1.1.2.1,
|
diagrams-contrib >= 1.3.0.0,
|
||||||
directory >=1.2 && <1.3,
|
directory >=1.2,
|
||||||
filepath >= 1.3.0.2,
|
filepath >= 1.3.0.2,
|
||||||
glade >=0.12 && <0.13,
|
glade >=0.12,
|
||||||
gloss >= 1.2.0.1,
|
gloss >= 1.2.0.1,
|
||||||
gtk >=0.12 && <0.13,
|
gtk >=0.12,
|
||||||
multiset-comb >= 0.2.1,
|
|
||||||
safe >= 0.3.8,
|
safe >= 0.3.8,
|
||||||
transformers >=0.4 && <0.5
|
transformers >=0.4
|
||||||
|
|
||||||
-- Directories containing source files.
|
-- Directories containing source files.
|
||||||
-- hs-source-dirs:
|
-- hs-source-dirs:
|
||||||
@ -126,18 +125,17 @@ executable Gif
|
|||||||
|
|
||||||
-- Other library packages from which modules are imported.
|
-- Other library packages from which modules are imported.
|
||||||
build-depends: attoparsec >= 0.12.1.1,
|
build-depends: attoparsec >= 0.12.1.1,
|
||||||
base >=4.6 && <4.8,
|
base >=4.6,
|
||||||
bytestring >= 0.10.4.0,
|
bytestring >= 0.10.4.0,
|
||||||
containers >= 0.5.0.0,
|
containers >= 0.5.0.0,
|
||||||
dequeue >= 0.1.5,
|
dequeue >= 0.1.5,
|
||||||
diagrams-lib >=1.2 && <1.3,
|
diagrams-lib >=1.3,
|
||||||
diagrams-cairo >=1.2 && <1.3,
|
diagrams-cairo >=1.3,
|
||||||
diagrams-contrib >= 1.1.2.1,
|
diagrams-contrib >= 1.3.0.0,
|
||||||
gloss >= 1.2.0.1,
|
gloss >= 1.2.0.1,
|
||||||
JuicyPixels >= 3.1.7.1,
|
JuicyPixels >= 3.1.7.1,
|
||||||
multiset-comb >= 0.2.1,
|
safe >= 0.3.8,
|
||||||
transformers >=0.4 && <0.5,
|
transformers >=0.4
|
||||||
safe >= 0.3.8
|
|
||||||
|
|
||||||
-- Directories containing source files.
|
-- Directories containing source files.
|
||||||
-- hs-source-dirs:
|
-- hs-source-dirs:
|
||||||
@ -175,18 +173,14 @@ executable Test
|
|||||||
|
|
||||||
-- Other library packages from which modules are imported.
|
-- Other library packages from which modules are imported.
|
||||||
build-depends: attoparsec >= 0.12.1.1,
|
build-depends: attoparsec >= 0.12.1.1,
|
||||||
base >=4.6 && <4.8,
|
base >=4.6,
|
||||||
bytestring >= 0.10.4.0,
|
bytestring >= 0.10.4.0,
|
||||||
containers >= 0.5.0.0,
|
containers >= 0.5.0.0,
|
||||||
dequeue >= 0.1.5,
|
diagrams-lib >=1.3,
|
||||||
diagrams-lib >=1.2 && <1.3,
|
diagrams-cairo >=1.3,
|
||||||
diagrams-cairo >=1.2 && <1.3,
|
diagrams-contrib >= 1.3.0.0,
|
||||||
diagrams-contrib >= 1.1.2.1,
|
|
||||||
gloss >= 1.2.0.1,
|
gloss >= 1.2.0.1,
|
||||||
JuicyPixels >= 3.1.7.1,
|
|
||||||
multiset-comb >= 0.2.1,
|
|
||||||
QuickCheck >= 2.4.2,
|
QuickCheck >= 2.4.2,
|
||||||
transformers >=0.4 && <0.5,
|
|
||||||
safe >= 0.3.8
|
safe >= 0.3.8
|
||||||
|
|
||||||
-- Directories containing source files.
|
-- Directories containing source files.
|
||||||
|
@ -63,9 +63,9 @@ data MyGUI = MkMyGUI {
|
|||||||
-- |Path entry widget for the quad tree.
|
-- |Path entry widget for the quad tree.
|
||||||
quadPathEntry :: Entry,
|
quadPathEntry :: Entry,
|
||||||
-- |Horizontal box containing the path entry widget.
|
-- |Horizontal box containing the path entry widget.
|
||||||
vbox7 :: Box,
|
vbox7 :: Graphics.UI.Gtk.Box,
|
||||||
-- |Horizontal box containing the Rang search entry widgets.
|
-- |Horizontal box containing the Rang search entry widgets.
|
||||||
vbox10 :: Box,
|
vbox10 :: Graphics.UI.Gtk.Box,
|
||||||
-- |Range entry widget for lower x bound
|
-- |Range entry widget for lower x bound
|
||||||
rangeXminEntry :: Entry,
|
rangeXminEntry :: Entry,
|
||||||
-- |Range entry widget for upper x bound
|
-- |Range entry widget for upper x bound
|
||||||
@ -299,9 +299,9 @@ saveAndDrawDiag fp fps mygui =
|
|||||||
renderDiag winWidth winHeight buildDiag =
|
renderDiag winWidth winHeight buildDiag =
|
||||||
renderDia Cairo
|
renderDia Cairo
|
||||||
(CairoOptions fps
|
(CairoOptions fps
|
||||||
(Dims (fromIntegral winWidth) (fromIntegral winHeight))
|
(mkSizeSpec2D (Just $ fromIntegral winWidth) (Just $ fromIntegral winHeight))
|
||||||
SVG False)
|
SVG False)
|
||||||
(buildDiag (def{
|
(buildDiag (MyPrelude.def{
|
||||||
dotSize = scaleVal,
|
dotSize = scaleVal,
|
||||||
xDimension = fromMaybe (0, 500) xDim,
|
xDimension = fromMaybe (0, 500) xDim,
|
||||||
yDimension = fromMaybe (0, 500) yDim,
|
yDimension = fromMaybe (0, 500) yDim,
|
||||||
|
@ -123,9 +123,9 @@ kdSquares = Diag f
|
|||||||
where
|
where
|
||||||
-- Gets all lines that make up the kdSquares. Every line is
|
-- Gets all lines that make up the kdSquares. Every line is
|
||||||
-- described by two points, start and end respectively.
|
-- described by two points, start and end respectively.
|
||||||
kdLines :: KDTree P2
|
kdLines :: KDTree (P2 Double)
|
||||||
-> ((Double, Double), (Double, Double)) -- ^ square
|
-> ((Double, Double), (Double, Double)) -- ^ square
|
||||||
-> [(P2, P2)]
|
-> [(P2 Double, P2 Double)]
|
||||||
kdLines (KTNode ln pt Horizontal rn) ((xmin, ymin), (xmax, ymax)) =
|
kdLines (KTNode ln pt Horizontal rn) ((xmin, ymin), (xmax, ymax)) =
|
||||||
(\(x, _) -> [(p2 (x, ymin), p2 (x, ymax))])
|
(\(x, _) -> [(p2 (x, ymin), p2 (x, ymax))])
|
||||||
(unp2 pt)
|
(unp2 pt)
|
||||||
@ -180,7 +180,7 @@ kdTreeDiag = Diag f
|
|||||||
|
|
||||||
|
|
||||||
-- |Get the quad tree corresponding to the given points and diagram properties.
|
-- |Get the quad tree corresponding to the given points and diagram properties.
|
||||||
qt :: [P2] -> DiagProp -> QuadTree P2
|
qt :: [P2 Double] -> DiagProp -> QuadTree (P2 Double)
|
||||||
qt vt p = quadTree vt (diagDimSquare p)
|
qt vt p = quadTree vt (diagDimSquare p)
|
||||||
|
|
||||||
|
|
||||||
@ -194,7 +194,7 @@ quadPathSquare = Diag f
|
|||||||
(getSquare (stringToQuads (quadPath p)) (qt (mconcat vts) p, []))
|
(getSquare (stringToQuads (quadPath p)) (qt (mconcat vts) p, []))
|
||||||
where
|
where
|
||||||
getSquare :: [Either Quad Orient]
|
getSquare :: [Either Quad Orient]
|
||||||
-> QTZipper P2
|
-> QTZipper (P2 Double)
|
||||||
-> ((Double, Double), (Double, Double))
|
-> ((Double, Double), (Double, Double))
|
||||||
getSquare [] z = getSquareByZipper (diagDimSquare p) z
|
getSquare [] z = getSquareByZipper (diagDimSquare p) z
|
||||||
getSquare (q:qs) z = case q of
|
getSquare (q:qs) z = case q of
|
||||||
@ -212,7 +212,7 @@ gifQuadPath = GifDiag f
|
|||||||
<$> getSquares (stringToQuads (quadPath p)) (qt vt p, [])
|
<$> getSquares (stringToQuads (quadPath p)) (qt vt p, [])
|
||||||
where
|
where
|
||||||
getSquares :: [Either Quad Orient]
|
getSquares :: [Either Quad Orient]
|
||||||
-> QTZipper P2
|
-> QTZipper (P2 Double)
|
||||||
-> [((Double, Double), (Double, Double))]
|
-> [((Double, Double), (Double, Double))]
|
||||||
getSquares [] z = [getSquareByZipper (diagDimSquare p) z]
|
getSquares [] z = [getSquareByZipper (diagDimSquare p) z]
|
||||||
getSquares (q:qs) z = case q of
|
getSquares (q:qs) z = case q of
|
||||||
@ -233,12 +233,12 @@ treePretty = Diag f
|
|||||||
. quadPath
|
. quadPath
|
||||||
$ p)
|
$ p)
|
||||||
where
|
where
|
||||||
getCurQT :: [Either Quad Orient] -> QTZipper P2 -> QTZipper P2
|
getCurQT :: [Either Quad Orient] -> QTZipper (P2 Double) -> QTZipper (P2 Double)
|
||||||
getCurQT [] z = z
|
getCurQT [] z = z
|
||||||
getCurQT (q:qs) z = case q of
|
getCurQT (q:qs) z = case q of
|
||||||
Right x -> getCurQT qs (fromMaybe z (findNeighbor x z))
|
Right x -> getCurQT qs (fromMaybe z (findNeighbor x z))
|
||||||
Left x -> getCurQT qs (fromMaybe z (goQuad x z))
|
Left x -> getCurQT qs (fromMaybe z (goQuad x z))
|
||||||
prettyRoseTree :: Tree String -> Diagram Cairo R2
|
prettyRoseTree :: Tree String -> Diagram Cairo
|
||||||
prettyRoseTree tree =
|
prettyRoseTree tree =
|
||||||
-- HACK: in order to give specific nodes a specific color
|
-- HACK: in order to give specific nodes a specific color
|
||||||
renderTree (\n -> case head n of
|
renderTree (\n -> case head n of
|
||||||
|
@ -15,18 +15,18 @@ data Diag =
|
|||||||
Diag
|
Diag
|
||||||
{
|
{
|
||||||
mkDiag :: DiagProp
|
mkDiag :: DiagProp
|
||||||
-> [[P2]]
|
-> [[P2 Double]]
|
||||||
-> Diagram Cairo R2
|
-> Diagram Cairo
|
||||||
}
|
}
|
||||||
| GifDiag
|
| GifDiag
|
||||||
{
|
{
|
||||||
mkGifDiag :: DiagProp
|
mkGifDiag :: DiagProp
|
||||||
-> Colour Double
|
-> Colour Double
|
||||||
-> ([P2] -> [[P2]])
|
-> ([P2 Double] -> [[P2 Double]])
|
||||||
-> [P2]
|
-> [P2 Double]
|
||||||
-> [Diagram Cairo R2]
|
-> [Diagram Cairo]
|
||||||
}
|
}
|
||||||
| EmptyDiag (Diagram Cairo R2)
|
| EmptyDiag (Diagram Cairo)
|
||||||
|
|
||||||
|
|
||||||
-- |Holds the properties for a Diagram, like thickness of 2d points etc.
|
-- |Holds the properties for a Diagram, like thickness of 2d points etc.
|
||||||
@ -134,7 +134,7 @@ maybeDiag b d
|
|||||||
| otherwise = mempty
|
| otherwise = mempty
|
||||||
|
|
||||||
|
|
||||||
filterValidPT :: DiagProp -> [P2] -> [P2]
|
filterValidPT :: DiagProp -> [P2 Double] -> [P2 Double]
|
||||||
filterValidPT =
|
filterValidPT =
|
||||||
filter
|
filter
|
||||||
. inRange
|
. inRange
|
||||||
@ -146,21 +146,21 @@ diagDimSquare p = dimToSquare (xDimension p) $ yDimension p
|
|||||||
|
|
||||||
|
|
||||||
-- |Draw a list of points.
|
-- |Draw a list of points.
|
||||||
drawP :: [P2] -- ^ the points to draw
|
drawP :: [P2 Double] -- ^ the points to draw
|
||||||
-> Double -- ^ dot size
|
-> Double -- ^ dot size
|
||||||
-> Diagram Cairo R2 -- ^ the resulting diagram
|
-> Diagram Cairo -- ^ the resulting diagram
|
||||||
drawP [] _ = mempty
|
drawP [] _ = mempty
|
||||||
drawP vt ds =
|
drawP vt ds =
|
||||||
position (zip vt (repeat dot))
|
position (zip vt (repeat dot))
|
||||||
where
|
where
|
||||||
dot = circle ds :: Diagram Cairo R2
|
dot = circle ds :: Diagram Cairo
|
||||||
|
|
||||||
|
|
||||||
-- |Create a rectangle around a diagonal line, which has sw
|
-- |Create a rectangle around a diagonal line, which has sw
|
||||||
-- as startpoint and nw as endpoint.
|
-- as startpoint and nw as endpoint.
|
||||||
rectByDiagonal :: (Double, Double) -- ^ sw point
|
rectByDiagonal :: (Double, Double) -- ^ sw point
|
||||||
-> (Double, Double) -- ^ nw point
|
-> (Double, Double) -- ^ nw point
|
||||||
-> Diagram Cairo R2
|
-> Diagram Cairo
|
||||||
rectByDiagonal (xmin, ymin) (xmax, ymax) =
|
rectByDiagonal (xmin, ymin) (xmax, ymax) =
|
||||||
fromVertices [p2 (xmin, ymin)
|
fromVertices [p2 (xmin, ymin)
|
||||||
, p2 (xmax, ymin)
|
, p2 (xmax, ymin)
|
||||||
@ -172,7 +172,7 @@ rectByDiagonal (xmin, ymin) (xmax, ymax) =
|
|||||||
|
|
||||||
-- |Creates a Diagram from a point that shows the coordinates
|
-- |Creates a Diagram from a point that shows the coordinates
|
||||||
-- in text format, such as "(1.0, 2.0)".
|
-- in text format, such as "(1.0, 2.0)".
|
||||||
pointToTextCoord :: P2 -> Diagram Cairo R2
|
pointToTextCoord :: P2 Double -> Diagram Cairo
|
||||||
pointToTextCoord pt =
|
pointToTextCoord pt =
|
||||||
text ("(" ++ (show . trim') x ++ ", " ++ (show . trim') y ++ ")") # scale 10
|
text ("(" ++ (show . trim') x ++ ", " ++ (show . trim') y ++ ")") # scale 10
|
||||||
where
|
where
|
||||||
|
@ -2,7 +2,7 @@
|
|||||||
|
|
||||||
module Graphics.Diagram.Gif where
|
module Graphics.Diagram.Gif where
|
||||||
|
|
||||||
import Algebra.Vector(PT)
|
import Algebra.Vector
|
||||||
import Algorithms.GrahamScan
|
import Algorithms.GrahamScan
|
||||||
import Codec.Picture.Gif
|
import Codec.Picture.Gif
|
||||||
import qualified Data.ByteString.Char8 as B
|
import qualified Data.ByteString.Char8 as B
|
||||||
@ -16,7 +16,7 @@ import Parser.Meshparser
|
|||||||
|
|
||||||
|
|
||||||
-- |Return a list of tuples used by 'gifMain' to generate an animated gif.
|
-- |Return a list of tuples used by 'gifMain' to generate an animated gif.
|
||||||
gifDiag :: DiagProp -> [PT] -> [(Diagram Cairo R2, GifDelay)]
|
gifDiag :: DiagProp -> [P2 Double] -> [(Diagram Cairo, GifDelay)]
|
||||||
gifDiag p xs =
|
gifDiag p xs =
|
||||||
fmap ((\x -> (x, 50)) . (<> nonChDiag))
|
fmap ((\x -> (x, 50)) . (<> nonChDiag))
|
||||||
(upperHullList
|
(upperHullList
|
||||||
@ -35,5 +35,5 @@ gifDiag p xs =
|
|||||||
|
|
||||||
-- |Same as gifDiag, except that it takes a string containing the
|
-- |Same as gifDiag, except that it takes a string containing the
|
||||||
-- mesh file content instead of the the points.
|
-- mesh file content instead of the the points.
|
||||||
gifDiagS :: DiagProp -> B.ByteString -> [(Diagram Cairo R2, GifDelay)]
|
gifDiagS :: DiagProp -> B.ByteString -> [(Diagram Cairo, GifDelay)]
|
||||||
gifDiagS p = gifDiag p . filterValidPT p . meshToArr
|
gifDiagS p = gifDiag p . filterValidPT p . meshToArr
|
||||||
|
@ -2,6 +2,7 @@
|
|||||||
|
|
||||||
module Graphics.Diagram.Gtk where
|
module Graphics.Diagram.Gtk where
|
||||||
|
|
||||||
|
import Algebra.Vector
|
||||||
import qualified Data.ByteString.Char8 as B
|
import qualified Data.ByteString.Char8 as B
|
||||||
import Data.List(find)
|
import Data.List(find)
|
||||||
import Diagrams.Backend.Cairo
|
import Diagrams.Backend.Cairo
|
||||||
@ -45,7 +46,7 @@ diagTreAlgos =
|
|||||||
|
|
||||||
|
|
||||||
-- |Create the Diagram from the points.
|
-- |Create the Diagram from the points.
|
||||||
diag :: DiagProp -> [DiagAlgo] -> [[P2]] -> Diagram Cairo R2
|
diag :: DiagProp -> [DiagAlgo] -> [[P2 Double]] -> Diagram Cairo
|
||||||
diag p das vts = maybe mempty (\x -> mkDiag x p vts)
|
diag p das vts = maybe mempty (\x -> mkDiag x p vts)
|
||||||
$ mconcat
|
$ mconcat
|
||||||
-- get the actual [Diag] array
|
-- get the actual [Diag] array
|
||||||
@ -57,7 +58,7 @@ diag p das vts = maybe mempty (\x -> mkDiag x p vts)
|
|||||||
|
|
||||||
-- |Create the Diagram from a String which is supposed to be the contents
|
-- |Create the Diagram from a String which is supposed to be the contents
|
||||||
-- of an obj file.
|
-- of an obj file.
|
||||||
diagS :: DiagProp -> B.ByteString -> Diagram Cairo R2
|
diagS :: DiagProp -> B.ByteString -> Diagram Cairo
|
||||||
diagS p mesh =
|
diagS p mesh =
|
||||||
diag p diagAlgos
|
diag p diagAlgos
|
||||||
. fmap (filterValidPT p)
|
. fmap (filterValidPT p)
|
||||||
@ -68,7 +69,7 @@ diagS p mesh =
|
|||||||
|
|
||||||
-- |Create the tree diagram from a String which is supposed to be the contents
|
-- |Create the tree diagram from a String which is supposed to be the contents
|
||||||
-- of an obj file.
|
-- of an obj file.
|
||||||
diagTreeS :: DiagProp -> B.ByteString -> Diagram Cairo R2
|
diagTreeS :: DiagProp -> B.ByteString -> Diagram Cairo
|
||||||
diagTreeS p mesh =
|
diagTreeS p mesh =
|
||||||
diag p diagTreAlgos
|
diag p diagTreAlgos
|
||||||
. fmap (filterValidPT p)
|
. fmap (filterValidPT p)
|
||||||
|
@ -11,7 +11,7 @@ import Diagrams.TwoD.Types
|
|||||||
|
|
||||||
-- |Convert a text String with multiple vertices and faces into
|
-- |Convert a text String with multiple vertices and faces into
|
||||||
-- a list of vertices, ordered by the faces specification.
|
-- a list of vertices, ordered by the faces specification.
|
||||||
facesToArr :: B.ByteString -> [[P2]]
|
facesToArr :: B.ByteString -> [[P2 Double]]
|
||||||
facesToArr str = fmap (fmap (\y -> meshToArr str !! (fromIntegral y - 1)))
|
facesToArr str = fmap (fmap (\y -> meshToArr str !! (fromIntegral y - 1)))
|
||||||
(faces str)
|
(faces str)
|
||||||
where
|
where
|
||||||
@ -21,7 +21,7 @@ facesToArr str = fmap (fmap (\y -> meshToArr str !! (fromIntegral y - 1)))
|
|||||||
-- |Convert a text String with multiple vertices into
|
-- |Convert a text String with multiple vertices into
|
||||||
-- an array of float tuples.
|
-- an array of float tuples.
|
||||||
meshToArr :: B.ByteString -- ^ the string to convert
|
meshToArr :: B.ByteString -- ^ the string to convert
|
||||||
-> [P2] -- ^ the resulting vertice table
|
-> [P2 Double] -- ^ the resulting vertice table
|
||||||
meshToArr =
|
meshToArr =
|
||||||
fmap p2
|
fmap p2
|
||||||
. rights
|
. rights
|
||||||
|
@ -21,19 +21,19 @@ newtype PosRoundDouble = PosRoundDouble { getPRD :: Double }
|
|||||||
deriving (Eq, Ord, Show, Read)
|
deriving (Eq, Ord, Show, Read)
|
||||||
|
|
||||||
|
|
||||||
newtype RoundR2 = RoundR2 { getRR2 :: R2 }
|
newtype RoundR2 = RoundR2 { getRR2 :: V2 Double }
|
||||||
deriving (Eq, Ord, Show, Read)
|
deriving (Eq, Ord, Show, Read)
|
||||||
|
|
||||||
|
|
||||||
newtype PosRoundR2 = PosRoundR2 { getPRR2 :: R2 }
|
newtype PosRoundR2 = PosRoundR2 { getPRR2 :: V2 Double }
|
||||||
deriving (Eq, Ord, Show, Read)
|
deriving (Eq, Ord, Show, Read)
|
||||||
|
|
||||||
|
|
||||||
newtype RoundP2 = RoundP2 { getRP2 :: P2 }
|
newtype RoundP2 = RoundP2 { getRP2 :: P2 Double }
|
||||||
deriving (Eq, Ord, Show, Read)
|
deriving (Eq, Ord, Show, Read)
|
||||||
|
|
||||||
|
|
||||||
newtype PosRoundP2 = PosRoundP2 { getPRP2 :: P2 }
|
newtype PosRoundP2 = PosRoundP2 { getPRP2 :: P2 Double }
|
||||||
deriving (Eq, Ord, Show, Read)
|
deriving (Eq, Ord, Show, Read)
|
||||||
|
|
||||||
|
|
||||||
@ -72,11 +72,11 @@ instance Arbitrary PosRoundP2 where
|
|||||||
<*> (arbitrary :: Gen PosRoundDouble)
|
<*> (arbitrary :: Gen PosRoundDouble)
|
||||||
|
|
||||||
|
|
||||||
instance Arbitrary R2 where
|
instance Arbitrary (V2 Double) where
|
||||||
arbitrary = curry r2 <$> arbitrary <*> arbitrary
|
arbitrary = curry r2 <$> arbitrary <*> arbitrary
|
||||||
|
|
||||||
|
|
||||||
instance Arbitrary P2 where
|
instance Arbitrary (P2 Double) where
|
||||||
arbitrary = curry p2 <$> arbitrary <*> arbitrary
|
arbitrary = curry p2 <$> arbitrary <*> arbitrary
|
||||||
|
|
||||||
|
|
||||||
@ -126,51 +126,51 @@ inRangeProp6 sq@((x1, y1), (x2, y2)) (Positive a) (Positive b) =
|
|||||||
|
|
||||||
|
|
||||||
-- apply id function on the point
|
-- apply id function on the point
|
||||||
onPTProp1 :: P2 -> Bool
|
onPTProp1 :: P2 Double -> Bool
|
||||||
onPTProp1 pt = onPT id pt == pt
|
onPTProp1 pt = onPT id pt == pt
|
||||||
|
|
||||||
|
|
||||||
-- add a random value to the point coordinates
|
-- add a random value to the point coordinates
|
||||||
onPTProp2 :: P2 -> Positive R2 -> Bool
|
onPTProp2 :: P2 Double -> Positive (V2 Double) -> Bool
|
||||||
onPTProp2 pt (Positive (R2 rx ry))
|
onPTProp2 pt (Positive (V2 rx ry))
|
||||||
= onPT (\(x, y) -> (x + rx, y + ry)) pt /= pt
|
= onPT (\(x, y) -> (x + rx, y + ry)) pt /= pt
|
||||||
|
|
||||||
|
|
||||||
-- angle between two vectors both on the x-axis must be 0
|
-- angle between two vectors both on the x-axis must be 0
|
||||||
getAngleProp1 :: Positive R2 -> Positive R2 -> Bool
|
getAngleProp1 :: Positive (V2 Double) -> Positive (V2 Double) -> Bool
|
||||||
getAngleProp1 (Positive (R2 x1 _)) (Positive (R2 x2 _))
|
getAngleProp1 (Positive (V2 x1 _)) (Positive (V2 x2 _))
|
||||||
= getAngle (R2 x1 0) (R2 x2 0) == 0
|
= getAngle (V2 x1 0) (V2 x2 0) == 0
|
||||||
|
|
||||||
|
|
||||||
-- angle between two vectors both on the y-axis must be 0
|
-- angle between two vectors both on the y-axis must be 0
|
||||||
getAngleProp2 :: Positive R2 -> Positive R2 -> Bool
|
getAngleProp2 :: Positive (V2 Double) -> Positive (V2 Double) -> Bool
|
||||||
getAngleProp2 (Positive (R2 _ y1)) (Positive (R2 _ y2))
|
getAngleProp2 (Positive (V2 _ y1)) (Positive (V2 _ y2))
|
||||||
= getAngle (R2 0 y1) (R2 0 y2) == 0
|
= getAngle (V2 0 y1) (V2 0 y2) == 0
|
||||||
|
|
||||||
|
|
||||||
-- angle between two vectors both on the x-axis but with opposite direction
|
-- angle between two vectors both on the x-axis but with opposite direction
|
||||||
-- must be pi
|
-- must be pi
|
||||||
getAngleProp3 :: Positive R2 -> Positive R2 -> Bool
|
getAngleProp3 :: Positive (V2 Double) -> Positive (V2 Double) -> Bool
|
||||||
getAngleProp3 (Positive (R2 x1 _)) (Positive (R2 x2 _))
|
getAngleProp3 (Positive (V2 x1 _)) (Positive (V2 x2 _))
|
||||||
= getAngle (R2 (negate x1) 0) (R2 x2 0) == pi
|
= getAngle (V2 (negate x1) 0) (V2 x2 0) == pi
|
||||||
|
|
||||||
|
|
||||||
-- angle between two vectors both on the y-axis but with opposite direction
|
-- angle between two vectors both on the y-axis but with opposite direction
|
||||||
-- must be pi
|
-- must be pi
|
||||||
getAngleProp4 :: Positive R2 -> Positive R2 -> Bool
|
getAngleProp4 :: Positive (V2 Double) -> Positive (V2 Double) -> Bool
|
||||||
getAngleProp4 (Positive (R2 _ y1)) (Positive (R2 _ y2))
|
getAngleProp4 (Positive (V2 _ y1)) (Positive (V2 _ y2))
|
||||||
= getAngle (R2 0 (negate y1)) (R2 0 y2) == pi
|
= getAngle (V2 0 (negate y1)) (V2 0 y2) == pi
|
||||||
|
|
||||||
|
|
||||||
-- angle between vector in x-axis direction and y-axis direction must be
|
-- angle between vector in x-axis direction and y-axis direction must be
|
||||||
-- p/2
|
-- p/2
|
||||||
getAngleProp5 :: Positive R2 -> Positive R2 -> Bool
|
getAngleProp5 :: Positive (V2 Double) -> Positive (V2 Double) -> Bool
|
||||||
getAngleProp5 (Positive (R2 x1 _)) (Positive (R2 _ y2))
|
getAngleProp5 (Positive (V2 x1 _)) (Positive (V2 _ y2))
|
||||||
= getAngle (R2 x1 0) (R2 0 y2) == pi / 2
|
= getAngle (V2 x1 0) (V2 0 y2) == pi / 2
|
||||||
|
|
||||||
|
|
||||||
-- commutative
|
-- commutative
|
||||||
getAngleProp6 :: Positive R2 -> Positive R2 -> Bool
|
getAngleProp6 :: Positive (V2 Double) -> Positive (V2 Double) -> Bool
|
||||||
getAngleProp6 (Positive v1) (Positive v2)
|
getAngleProp6 (Positive v1) (Positive v2)
|
||||||
= getAngle v1 v2 == getAngle v2 v1
|
= getAngle v1 v2 == getAngle v2 v1
|
||||||
|
|
||||||
@ -183,7 +183,7 @@ getAngleProp7 (PosRoundR2 v)
|
|||||||
|
|
||||||
|
|
||||||
-- commutative
|
-- commutative
|
||||||
scalarProdProp1 :: R2 -> R2 -> Bool
|
scalarProdProp1 :: (V2 Double) -> (V2 Double) -> Bool
|
||||||
scalarProdProp1 v1 v2 = v1 `scalarProd` v2 == v2 `scalarProd` v1
|
scalarProdProp1 v1 v2 = v1 `scalarProd` v2 == v2 `scalarProd` v1
|
||||||
|
|
||||||
|
|
||||||
@ -212,9 +212,9 @@ scalarProdProp4 (RoundDouble s1) (RoundDouble s2) (RoundR2 v1) (RoundR2 v2)
|
|||||||
|
|
||||||
|
|
||||||
-- orthogonal
|
-- orthogonal
|
||||||
scalarProdProp5 :: Positive R2 -> Positive R2 -> Bool
|
scalarProdProp5 :: Positive (V2 Double) -> Positive (V2 Double) -> Bool
|
||||||
scalarProdProp5 (Positive (R2 x1 _)) (Positive (R2 _ y2))
|
scalarProdProp5 (Positive (V2 x1 _)) (Positive (V2 _ y2))
|
||||||
= scalarProd (R2 x1 0) (R2 0 y2) == 0
|
= scalarProd (V2 x1 0) (V2 0 y2) == 0
|
||||||
|
|
||||||
|
|
||||||
-- this is almost the same as the function definition
|
-- this is almost the same as the function definition
|
||||||
@ -226,49 +226,49 @@ dimToSquareProp1 (x1, x2) (y1, y2) =
|
|||||||
-- multiply scalar with result of vecLength or with the vector itself...
|
-- multiply scalar with result of vecLength or with the vector itself...
|
||||||
-- both results must be the same. We can't check against 0
|
-- both results must be the same. We can't check against 0
|
||||||
-- because of sqrt in vecLength.
|
-- because of sqrt in vecLength.
|
||||||
vecLengthProp1 :: PosRoundDouble -> R2 -> Bool
|
vecLengthProp1 :: PosRoundDouble -> (V2 Double) -> Bool
|
||||||
vecLengthProp1 (PosRoundDouble r) v
|
vecLengthProp1 (PosRoundDouble r) v
|
||||||
= abs (vecLength v * r - vecLength (scalarMul r v)) < 0.0001
|
= abs (vecLength v * r - vecLength (scalarMul r v)) < 0.0001
|
||||||
|
|
||||||
|
|
||||||
-- convert to vector and back again
|
-- convert to vector and back again
|
||||||
pt2VecProp1 :: P2 -> Bool
|
pt2VecProp1 :: P2 Double -> Bool
|
||||||
pt2VecProp1 pt = (vec2Pt . pt2Vec $ pt) == pt
|
pt2VecProp1 pt = (vec2Pt . pt2Vec $ pt) == pt
|
||||||
|
|
||||||
|
|
||||||
-- unbox coordinates and check if equal
|
-- unbox coordinates and check if equal
|
||||||
pt2VecProp2 :: P2 -> Bool
|
pt2VecProp2 :: P2 Double -> Bool
|
||||||
pt2VecProp2 pt = (unr2 . pt2Vec $ pt) == unp2 pt
|
pt2VecProp2 pt = (unr2 . pt2Vec $ pt) == unp2 pt
|
||||||
|
|
||||||
|
|
||||||
-- convert to point and back again
|
-- convert to point and back again
|
||||||
vec2PtProp1 :: R2 -> Bool
|
vec2PtProp1 :: V2 Double -> Bool
|
||||||
vec2PtProp1 v = (pt2Vec . vec2Pt $ v) == v
|
vec2PtProp1 v = (pt2Vec . vec2Pt $ v) == v
|
||||||
|
|
||||||
|
|
||||||
-- unbox coordinates and check if equal
|
-- unbox coordinates and check if equal
|
||||||
vec2PtProp2 :: R2 -> Bool
|
vec2PtProp2 :: V2 Double -> Bool
|
||||||
vec2PtProp2 v = (unp2 . vec2Pt $ v) == unr2 v
|
vec2PtProp2 v = (unp2 . vec2Pt $ v) == unr2 v
|
||||||
|
|
||||||
|
|
||||||
-- vector from a to b must not be the same as b to a
|
-- vector from a to b must not be the same as b to a
|
||||||
vp2Prop1 :: P2 -> P2 -> Bool
|
vp2Prop1 :: P2 Double -> P2 Double -> Bool
|
||||||
vp2Prop1 p1' p2'
|
vp2Prop1 p1' p2'
|
||||||
| p1' == origin && p2' == origin = True
|
| p1' == origin && p2' == origin = True
|
||||||
| otherwise = vp2 p1' p2' /= vp2 p2' p1'
|
| otherwise = vp2 p1' p2' /= vp2 p2' p1'
|
||||||
|
|
||||||
|
|
||||||
-- negating vector from a to be must be the same as vector b to a
|
-- negating vector from a to be must be the same as vector b to a
|
||||||
vp2Prop2 :: P2 -> P2 -> Bool
|
vp2Prop2 :: P2 Double -> P2 Double -> Bool
|
||||||
vp2Prop2 p1' p2'
|
vp2Prop2 p1' p2'
|
||||||
| p1' == origin && p2' == origin = True
|
| p1' == origin && p2' == origin = True
|
||||||
| otherwise = vp2 p1' p2' == (\(R2 x y) -> negate x ^& negate y)
|
| otherwise = vp2 p1' p2' == (\(V2 x y) -> negate x ^& negate y)
|
||||||
(vp2 p2' p1')
|
(vp2 p2' p1')
|
||||||
&&
|
&&
|
||||||
vp2 p2' p1' == (\(R2 x y) -> negate x ^& negate y)
|
vp2 p2' p1' == (\(V2 x y) -> negate x ^& negate y)
|
||||||
(vp2 p1' p2')
|
(vp2 p1' p2')
|
||||||
|
|
||||||
|
|
||||||
-- determinant of the 3 same points is always 0
|
-- determinant of the 3 same points is always 0
|
||||||
detProp1 :: P2 -> Bool
|
detProp1 :: P2 Double -> Bool
|
||||||
detProp1 pt' = det pt' pt' pt' == 0
|
detProp1 pt' = det pt' pt' pt' == 0
|
||||||
|
Loading…
Reference in New Issue
Block a user