hasufell/cga
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Port to diagrams >1.3

Browse Source 
# 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
15 changed files with 204 additions and 209 deletions
Download Patch File Download Diff File Expand all files Collapse all files

18
Algorithms/GrahamScan.hs
View File

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

30
Algorithms/KDTree.hs
View File

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

26
Algorithms/PolygonIntersection.hs
View File

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

70
Algorithms/PolygonTriangulation.hs
View File

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

8
Algorithms/QuadTree.hs
View File

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