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