From f8fb61e80a231b201041bbcc9bd2f043cb0afbfd Mon Sep 17 00:00:00 2001 From: hasufell Date: Sun, 7 Dec 2014 18:55:49 +0100 Subject: [PATCH] DIAG: consistently use [[PT]] for all Diags Also simplify a few things like needless strokeTrail usage. --- Graphics/Diagram/AlgoDiags.hs | 72 ++++++++++++++++------------------- Graphics/Diagram/Gtk.hs | 18 ++++++--- Graphics/Diagram/Plotter.hs | 4 -- 3 files changed, 46 insertions(+), 48 deletions(-) diff --git a/Graphics/Diagram/AlgoDiags.hs b/Graphics/Diagram/AlgoDiags.hs index afb2bf8..7805fc8 100644 --- a/Graphics/Diagram/AlgoDiags.hs +++ b/Graphics/Diagram/AlgoDiags.hs @@ -15,26 +15,23 @@ import Diagrams.Prelude hiding ((<>)) import Diagrams.TwoD.Layout.Tree import Graphics.Diagram.Core import Parser.PathParser +import Safe -- |Draw the lines of the polygon. polyLines :: Diag polyLines = Diag f where - f _ [] = mempty - f _ (x:y:_) = - strokePoly x <> strokePoly y + f _ = foldl (\x y -> x <> strokePoly y) mempty where - strokePoly x' = (strokeTrail . fromVertices $ x' ++ [head x']) - # moveTo (head x') # lc black - f _ _ = mempty + strokePoly x' = fromVertices $ x' ++ (maybeToList . headMay $ x') -- |Show the intersection points of two polygons as red dots. polyIntersection :: Diag polyIntersection = Diag f where - f p (x:y:_) = drawP vtpi (dotSize p) # fc red # lc red + f p [x, y] = drawP vtpi (dotSize p) # fc red # lc red where vtpi = intersectionPoints . sortLexPolys $ (sortLexPoly x, sortLexPoly y) f _ _ = mempty @@ -44,7 +41,7 @@ polyIntersection = Diag f polyIntersectionText :: Diag polyIntersectionText = Diag f where - f p (x:y:_) + f p [x, y] | showCoordText p = position . zip vtpi $ (pointToTextCoord # fc red <$> vtpi) # translate (r2 (0, 10)) | otherwise = mempty @@ -60,21 +57,20 @@ polyIntersectionText = Diag f convexHP :: Diag convexHP = Diag f where - f p [vt] = drawP (grahamCH vt) (dotSize p) # fc red # lc red - f _ _ = mempty + f p vts = drawP (grahamCH (concat vts)) (dotSize p) # fc red # lc red -- |Show coordinates as text above the convex hull points. convexHPText :: Diag convexHPText = Diag f where - f p [vt] + f p vts | showCoordText p = - position $ zip vtchf (pointToTextCoord <$> vtchf) # translate (r2 (0, 10)) + (position . zip vtch $ (pointToTextCoord <$> vtch)) + # translate (r2 (0, 10)) | otherwise = mempty where - vtchf = grahamCH vt - f _ _ = mempty + vtch = grahamCH (concat vts) -- |Create a diagram which shows the lines along the convex hull @@ -82,10 +78,14 @@ convexHPText = Diag f convexHLs :: Diag convexHLs = Diag f where - f _ [vt] = - (strokeTrail . fromVertices . flip (++) [head $ grahamCH vt] . grahamCH $ vt) - # moveTo (head $ grahamCH vt) # lc red - f _ _ = mempty + f _ vts = + (fromVertices + . flip (++) (maybeToList . headMay . grahamCH $ vt) + . grahamCH + $ vt + ) # lc red + where + vt = mconcat vts -- |Create list of diagrama which describe the lines along points of a half @@ -94,9 +94,7 @@ convexHLs = Diag f convexHStepsLs :: Diag convexHStepsLs = GifDiag f where - f _ col g vt = fmap mkChDiag (g vt) - where - mkChDiag vt' = (strokeTrail . fromVertices $ vt') # moveTo (head vt') # lc col + f _ col g vt = fmap (\x -> fromVertices x # lc col) (g vt) -- |Create a diagram that shows all squares of the RangeSearch algorithm @@ -104,24 +102,23 @@ convexHStepsLs = GifDiag f squares :: Diag squares = Diag f where - f p [vt] = + f p vts = mconcat $ (uncurry rectByDiagonal # lw ultraThin) <$> (quadTreeSquares (xDimension p, yDimension p) - . quadTree vt + . quadTree (mconcat vts) $ (xDimension p, yDimension p)) - f _ _ = mempty -- |Draw the squares of the kd-tree. kdSquares :: Diag kdSquares = Diag f where - f p [vt] = + f p vts = mconcat . fmap (uncurry (~~)) - $ kdLines (kdTree vt Horizontal) (xDimension p, yDimension p) + $ kdLines (kdTree (mconcat vts) Horizontal) (xDimension p, yDimension p) where -- Gets all lines that make up the kdSquares. Every line is -- described by two points, start and end respectively. @@ -141,26 +138,26 @@ kdSquares = Diag f where (_, y') = unp2 pt kdLines _ _ = [] - f _ _ = mempty -- |Draw the range rectangle and highlight the points inside that range. kdRange :: Diag kdRange = Diag f where - f p [vt] = + f p vts = (uncurry rectByDiagonal # lc red) (rangeSquare p) <> drawP ptsInRange (dotSize p) # fc red # lc red where - ptsInRange = fst . rangeSearch (kdTree vt Vertical) $ rangeSquare p - f _ _ = mempty + ptsInRange = fst + . rangeSearch (kdTree (mconcat vts) Vertical) + $ rangeSquare p -- |The kd-tree visualized as binary tree. kdTreeDiag :: Diag kdTreeDiag = Diag f where - f p [vt] = + f p vts = -- HACK: in order to give specific nodes a specific color renderTree (\n -> case n of '*':'*':_ -> (text n # fontSizeL 5.0) @@ -174,10 +171,9 @@ kdTreeDiag = Diag f # scale 2 # alignT # bg white where roseTree = snd - . rangeSearch (kdTree vt Vertical) + . rangeSearch (kdTree (mconcat vts) Vertical) $ rangeSquare p - f _ _ = mempty -- |Get the quad tree corresponding to the given points and diagram properties. @@ -190,16 +186,15 @@ qt vt p = quadTree vt (xDimension p, yDimension p) quadPathSquare :: Diag quadPathSquare = Diag f where - f p [vt] = + f p vts = (uncurry rectByDiagonal # lw thin # lc red) - (getSquare (stringToQuads (quadPath p)) (qt vt p, [])) + (getSquare (stringToQuads (quadPath p)) (qt (mconcat vts) p, [])) where getSquare :: [Either Quad Orient] -> QTZipper PT -> Square getSquare [] z = getSquareByZipper (xDimension p, yDimension p) z getSquare (q:qs) z = case q of Right x -> getSquare qs (fromMaybe z (findNeighbor x z)) Left x -> getSquare qs (fromMaybe z (goQuad x z)) - f _ _ = mempty -- |Create a list of diagrams that show the walk along the given path @@ -224,9 +219,9 @@ gifQuadPath = GifDiag f treePretty :: Diag treePretty = Diag f where - f p [vt] = + f p vts = prettyRoseTree (quadTreeToRoseTree - . flip getCurQT (qt vt p, []) + . flip getCurQT (qt (mconcat vts) p, []) . stringToQuads . quadPath $ p) @@ -247,4 +242,3 @@ treePretty = Diag f (~~) (symmLayout' (with & slHSep .~ 60 & slVSep .~ 40) tree) # scale 2 # alignT # bg white - f _ _ = mempty diff --git a/Graphics/Diagram/Gtk.hs b/Graphics/Diagram/Gtk.hs index 5cb72bb..f29b771 100644 --- a/Graphics/Diagram/Gtk.hs +++ b/Graphics/Diagram/Gtk.hs @@ -54,13 +54,21 @@ 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 p mesh - | algo p == 2 || algo p == 3 = - diag p diagAlgos . fmap (filterValidPT p) . facesToArr $ mesh - | otherwise = diag p diagAlgos . (: []) . filterValidPT p . meshToArr $ mesh +diagS p mesh = + diag p diagAlgos + . fmap (filterValidPT p) + . (\x -> if null x then [meshToArr mesh] else x) + . facesToArr + $ 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 p = diag p diagTreAlgos . (: []) . filterValidPT p . meshToArr +diagTreeS p mesh = + diag p diagTreAlgos + . fmap (filterValidPT p) + . (\x -> if null x then [meshToArr mesh] else x) + . facesToArr + $ mesh + diff --git a/Graphics/Diagram/Plotter.hs b/Graphics/Diagram/Plotter.hs index 2213ea3..54d86ef 100644 --- a/Graphics/Diagram/Plotter.hs +++ b/Graphics/Diagram/Plotter.hs @@ -13,8 +13,6 @@ import Graphics.Diagram.Core coordPoints :: Diag coordPoints = Diag f where - f _ [] = mempty - f p [vt] = drawP vt (dotSize p) # fc black # lc black f p vts = drawP (concat vts) (dotSize p) # fc black # lc black @@ -22,8 +20,6 @@ coordPoints = Diag f coordPointsText :: Diag coordPointsText = Diag f where - f _ [] = mempty - f p [vt] = drawT vt p f p vts = drawT (concat vts) p drawT [] _ = mempty drawT vt p