From 55e2ddd50040663f7810b81864acaa31757c3d25 Mon Sep 17 00:00:00 2001 From: hasufell Date: Sat, 25 Oct 2014 23:54:07 +0200 Subject: [PATCH] DIAGRAM: small refactor Update Diag type to play more nicely with GifDiags. --- Graphics/Diagram/Gif.hs | 28 ++++++++----------- Graphics/Diagram/Plotter.hs | 54 ++++++++++++------------------------- Graphics/Diagram/Types.hs | 44 ++++++++++++++++++++++++------ 3 files changed, 64 insertions(+), 62 deletions(-) diff --git a/Graphics/Diagram/Gif.hs b/Graphics/Diagram/Gif.hs index 80c3ecb..ff494cd 100644 --- a/Graphics/Diagram/Gif.hs +++ b/Graphics/Diagram/Gif.hs @@ -3,6 +3,7 @@ module Graphics.Diagram.Gif where import Algebra.VectorTypes +import Algorithms.ConvexHull.GrahamScan import Codec.Picture.Gif import Data.Monoid import Diagrams.Backend.Cairo @@ -15,26 +16,19 @@ import Parser.Meshparser -- |Return a list of tuples used by 'gifMain' to generate an animated gif. gifDiag :: DiagProp -> [PT] -> [(Diagram Cairo R2, GifDelay)] gifDiag p xs = - fmap ((\x -> (x, 100)) . (<> nonChDiag)) . - flip (++) - [mkDiag (convexHPText <> - convexHP) - p xs <> lastUpperHull <> lastLowerHull] $ - (lowerHullList ++ ((<> lastLowerHull) <$> upperHullList)) + fmap ((\x -> (x, 50)) . (<> nonChDiag)) + (upperHullList + <> fmap (<> last upperHullList) lowerHullList + <> [mkDiag (mconcat [convexHPText, convexHP, convexHLs]) + p{ ct = True } (Object xs)]) where - upperHullList = convexUHStepsLs p xs - lastUpperHull = last upperHullList - lowerHullList = convexLHStepsLs p xs - lastLowerHull = last lowerHullList + upperHullList = mkGifDiag convexHStepsLs p purple grahamUHSteps xs + lowerHullList = mkGifDiag convexHStepsLs p orange grahamLHSteps xs -- add the x-axis and the other default stuff nonChDiag = - mconcat . - fmap (\x -> mkDiag x p xs) $ - [coordPoints, - xAxis, - yAxis, - grid, - whiteRectB] + mconcat . + fmap (\x -> mkDiag x p (Object xs)) $ + [coordPoints, plotterBG] -- |Same as gifDiag, except that it takes a string containing the diff --git a/Graphics/Diagram/Plotter.hs b/Graphics/Diagram/Plotter.hs index 7d9b753..4f11d08 100644 --- a/Graphics/Diagram/Plotter.hs +++ b/Graphics/Diagram/Plotter.hs @@ -2,7 +2,6 @@ module Graphics.Diagram.Plotter where -import Algebra.Vector import Algebra.VectorTypes import Algorithms.ConvexHull.GrahamScan import Algorithms.PolygonIntersection.Core @@ -22,7 +21,7 @@ coordPoints = Diag cp cp p (Objects vts) = drawP (concat vts) p drawP [] _ = mempty drawP vt p = - position (zip (filter (inRange (dX p) (dY p)) vt) + position (zip (filterValidPT p vt) (repeat dot)) where dot = (circle $ t p :: Diagram Cairo R2) # fc black @@ -50,7 +49,7 @@ coordPointsText = Diag cpt zip vtf (pointToTextCoord <$> vtf) # translate (r2 (0, 10)) | otherwise = mempty where - vtf = filter (inRange (dX p) (dY p)) vt + vtf = filterValidPT p vt -- |Draw the lines of the polygon. @@ -67,7 +66,7 @@ polyLines = Diag pp vtf x' ++ [head . vtf $ x']) # moveTo (head x') # lc black - vtf = filter (inRange (dX p) (dY p)) + vtf = filterValidPT p pp _ _ = mempty @@ -77,8 +76,8 @@ polyIntersection = Diag pi' where pi' p (Objects (x:y:_)) = position (zip vtpi (repeat dot)) where - paF = filter (inRange (dX p) (dY p)) x - pbF = filter (inRange (dX p) (dY p)) y + paF = filterValidPT p x + pbF = filterValidPT p y dot = (circle $ t p :: Diagram Cairo R2) # fc red # lc red vtpi = intersectionPoints . sortLexPolys @@ -97,8 +96,8 @@ polyIntersectionText = Diag pit' (pointToTextCoord # fc red <$> vtpi) # translate (r2 (0, 10)) | otherwise = mempty where - paF = filter (inRange (dX p) (dY p)) x - pbF = filter (inRange (dX p) (dY p)) y + paF = filterValidPT p x + pbF = filterValidPT p y vtpi = intersectionPoints . sortLexPolys $ (sortLexPoly paF, sortLexPoly pbF) @@ -114,7 +113,7 @@ convexHP = Diag chp (repeat dot)) where dot = (circle $ t p :: Diagram Cairo R2) # fc red # lc red - vtch = grahamCH $ filter (inRange (dX p) (dY p)) vt + vtch = grahamCH $ filterValidPT p vt chp _ _ = mempty @@ -129,7 +128,7 @@ convexHPText = Diag chpt (pointToTextCoord <$> vtchf) # translate (r2 (0, 10)) | otherwise = mempty where - vtchf = grahamCH . filter (inRange (dX p) (dY p)) $ vt + vtchf = grahamCH . filterValidPT p $ vt chpt _ _ = mempty @@ -148,40 +147,21 @@ convexHLs = Diag chl moveTo (head $ grahamCH vtf) # lc red where - vtf = filter (inRange (dX p) (dY p)) vt + vtf = filterValidPT p vt chl _ _ = mempty -- |Create list of diagrama which describe the lines along points of a half -- convex hull, for each iteration of the algorithm. Which half is chosen -- depends on the input. -convexHStepsLs :: Colour Double - -> ([PT] -> [[PT]]) - -> DiagProp - -> [PT] - -> [Diagram Cairo R2] -convexHStepsLs col f p xs = - fmap mkChDiag (f xs') +convexHStepsLs :: Diag +convexHStepsLs = GifDiag chs where - xs' = filter (inRange (dX p) (dY p)) xs - mkChDiag vt = - (strokeTrail . - fromVertices $ - vt) # - moveTo (head vt) # - lc col - - --- |Create list of diagrama which describe the lines along the lower --- convex hull points, for each iteration of the algorithm. -convexLHStepsLs :: DiagProp -> [PT] -> [Diagram Cairo R2] -convexLHStepsLs = convexHStepsLs orange grahamLHSteps - - --- |Create list of diagrama which describe the lines along the upper --- convex hull points, for each iteration of the algorithm. -convexUHStepsLs :: DiagProp -> [PT] -> [Diagram Cairo R2] -convexUHStepsLs = convexHStepsLs purple grahamUHSteps + chs p col f vt = + fmap mkChDiag (f . filterValidPT p $ vt) + where + mkChDiag vt' = + (strokeTrail . fromVertices $ vt') # moveTo (head vt') # lc col -- |Creates a Diagram that shows an XAxis which is bound diff --git a/Graphics/Diagram/Types.hs b/Graphics/Diagram/Types.hs index 6e732fc..df02049 100644 --- a/Graphics/Diagram/Types.hs +++ b/Graphics/Diagram/Types.hs @@ -2,6 +2,7 @@ module Graphics.Diagram.Types where +import Algebra.Vector import Algebra.VectorTypes import Diagrams.Backend.Cairo import Diagrams.Prelude @@ -14,11 +15,22 @@ type MeshString = String -- |Represents a Cairo Diagram. This allows us to create multiple -- diagrams with different algorithms but based on the same -- coordinates and common properties. -data Diag = Diag { - mkDiag :: DiagProp - -> Object - -> Diagram Cairo R2 -} +data Diag = + Diag + { + mkDiag :: DiagProp + -> Object + -> Diagram Cairo R2 + } + | GifDiag + { + mkGifDiag :: DiagProp + -> Colour Double + -> ([PT] -> [[PT]]) + -> [PT] + -> [Diagram Cairo R2] + } + | EmptyDiag (Diagram Cairo R2) data Object = Object [PT] @@ -50,10 +62,22 @@ instance Def DiagProp where instance Monoid Diag where - mempty = Diag (\_ _ -> mempty) - mappend d1 d2 = Diag g + mempty = EmptyDiag mempty + mappend d1@(Diag {}) d2@(Diag {}) = Diag g where - g p vt = mkDiag d1 p vt <> mkDiag d2 p vt + g p obj = mkDiag d1 p obj <> mkDiag d2 p obj + mappend d1@(GifDiag {}) d2@(Diag {}) = GifDiag g + where + g p col f vt = mkGifDiag d1 p col f vt ++ [mkDiag d2 p (Object vt)] + mappend d1@(Diag {}) d2@(GifDiag {}) = GifDiag g + where + g p col f vt = mkDiag d2 p (Object vt) : mkGifDiag d1 p col f vt + mappend d1@(GifDiag {}) d2@(GifDiag {}) = GifDiag g + where + g p col f vt = mkGifDiag d1 p col f vt ++ mkGifDiag d2 p col f vt + mappend (EmptyDiag _) g = g + mappend g (EmptyDiag _) = g + mconcat = foldr mappend mempty @@ -111,3 +135,7 @@ maybeDiag :: Bool -> Diag -> Diag maybeDiag b d | b = d | otherwise = mempty + + +filterValidPT :: DiagProp -> [PT] -> [PT] +filterValidPT p = filter (inRange (dX p) (dY p))