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:
hasufell 2015-05-21 02:14:15 +02:00
parent 5120a44d0f
commit 984ed40c63
No known key found for this signature in database
GPG Key ID: 220CD1C5BDEED020
15 changed files with 204 additions and 209 deletions

View File

@ -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)

View File

@ -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")

View File

@ -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

View File

@ -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]

View File

@ -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)

View File

@ -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

View File

@ -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

View File

@ -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.

View File

@ -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,

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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)

View File

@ -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

View File

@ -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