cga/Graphics/Diagram/Plotter.hs

402 lines
13 KiB
Haskell
Raw Normal View History

{-# OPTIONS_HADDOCK ignore-exports #-}
2014-10-10 15:40:08 +00:00
module Graphics.Diagram.Plotter where
2014-09-30 22:05:29 +00:00
2014-10-10 15:40:08 +00:00
import Algebra.VectorTypes
import Algorithms.GrahamScan
import Algorithms.QuadTree
import Algorithms.KDTree
import Algorithms.PolygonIntersection
import Data.Maybe
2014-10-14 19:24:21 +00:00
import Data.Monoid
import Data.Tree
2014-09-30 22:05:29 +00:00
import Diagrams.Backend.Cairo
2014-10-14 19:24:21 +00:00
import Diagrams.Prelude hiding ((<>))
import Diagrams.TwoD.Layout.Tree
2014-10-10 15:40:08 +00:00
import Graphics.Diagram.Types
import Parser.PathParser
-- |Draw a list of points.
drawP :: [PT] -- ^ the points to draw
-> Double -- ^ dot size
-> Diagram Cairo R2 -- ^ the resulting diagram
2014-12-02 18:00:50 +00:00
drawP [] _ = mempty
drawP vt ds =
position (zip vt (repeat dot))
where
2014-12-03 00:36:12 +00:00
dot = circle ds :: Diagram Cairo R2
2014-12-02 18:00:50 +00:00
-- |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
rectByDiagonal (xmin, xmax) (ymin, ymax) =
rect (xmax - xmin) (ymax - ymin)
2014-12-03 00:36:12 +00:00
# moveTo (p2 ((xmax + xmin) / 2, (ymax + ymin) / 2))
2014-12-02 18:00:50 +00:00
-- |Creates a Diagram that shows the coordinates from the points
-- as dots. The points and thickness of the dots can be controlled
-- via DiagProp.
coordPoints :: Diag
coordPoints = Diag cp
where
cp p (Object vt) = drawP vt (dotSize p) # fc black # lc black
cp p (Objects vts) = drawP (concat vts) (dotSize p) # fc black # lc black
-- |Creates a Diagram from a point that shows the coordinates
-- in text format, such as "(1.0, 2.0)".
pointToTextCoord :: PT -> Diagram Cairo R2
pointToTextCoord pt =
text ("(" ++ (show . trim') x ++ ", " ++ (show . trim') y ++ ")") # scale 10
where
2014-11-13 22:05:56 +00:00
trim' :: Double -> Double
2014-11-15 22:20:05 +00:00
trim' x' = fromInteger . round $ x' * (10^(2 :: Int)) /
(10.0^^(2 :: Int))
(x, y) = unp2 pt
2014-10-10 13:34:38 +00:00
-- |Show coordinates as text above all points.
coordPointsText :: Diag
coordPointsText = Diag cpt
where
cpt p (Object vt) = drawT vt p
cpt p (Objects vts) = drawT (concat vts) p
drawT [] _ = mempty
drawT vt p
2014-12-03 00:36:12 +00:00
| showCoordText p = position $ zip vt (pointToTextCoord <$> vt)
2014-11-16 03:37:34 +00:00
# translate (r2 (0, 10))
| otherwise = mempty
-- |Draw the lines of the polygon.
polyLines :: Diag
polyLines = Diag pp
where
pp _ (Objects []) = mempty
pp _ (Objects (x:y:_)) =
strokePoly x <> strokePoly y
where
2014-12-03 00:36:12 +00:00
strokePoly x' = (strokeTrail . fromVertices $ x' ++ [head x'])
2014-11-16 03:37:34 +00:00
# moveTo (head x') # lc black
pp _ _ = mempty
-- |Show the intersection points of two polygons as red dots.
polyIntersection :: Diag
polyIntersection = Diag pi'
where
2014-12-02 18:00:50 +00:00
pi' p (Objects (x:y:_)) = drawP vtpi (dotSize p) # fc red # lc red
where
2014-12-03 00:36:12 +00:00
vtpi = intersectionPoints . sortLexPolys $ (sortLexPoly x, sortLexPoly y)
pi' _ _ = mempty
2014-11-16 03:37:34 +00:00
-- |Show the coordinate text of the intersection points of two polygons.
polyIntersectionText :: Diag
polyIntersectionText = Diag pit'
where
pit' p (Objects (x:y:_))
2014-12-03 00:36:12 +00:00
| showCoordText p = position . zip vtpi $ (pointToTextCoord # fc red <$> vtpi)
2014-11-16 03:37:34 +00:00
# translate (r2 (0, 10))
| otherwise = mempty
where
vtpi = intersectionPoints
. sortLexPolys
$ (sortLexPoly x,
sortLexPoly y)
pit' _ _ = mempty
-- |Create a diagram which shows the points of the convex hull.
convexHP :: Diag
convexHP = Diag chp
where
2014-12-02 18:00:50 +00:00
chp p (Object vt) = drawP (grahamCH vt) (dotSize p) # fc red # lc red
chp _ _ = mempty
2014-10-10 13:34:38 +00:00
-- |Show coordinates as text above the convex hull points.
convexHPText :: Diag
convexHPText = Diag chpt
where
chpt p (Object vt)
| showCoordText p =
2014-12-03 00:36:12 +00:00
position $ zip vtchf (pointToTextCoord <$> vtchf) # translate (r2 (0, 10))
| otherwise = mempty
where
vtchf = grahamCH vt
chpt _ _ = mempty
-- |Create a diagram which shows the lines along the convex hull
-- points.
convexHLs :: Diag
convexHLs = Diag chl
2014-10-08 17:31:55 +00:00
where
chl _ (Object []) = mempty
chl _ (Object vt) =
2014-12-03 00:36:12 +00:00
(strokeTrail . fromVertices . flip (++) [head $ grahamCH vt] . grahamCH $ vt)
# moveTo (head $ grahamCH vt) # lc red
chl _ _ = mempty
2014-10-08 17:31:55 +00:00
-- |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 :: Diag
convexHStepsLs = GifDiag chs
2014-10-09 22:19:05 +00:00
where
2014-12-03 00:36:12 +00:00
chs _ col f vt = fmap mkChDiag (f vt)
where
2014-12-03 00:36:12 +00:00
mkChDiag vt' = (strokeTrail . fromVertices $ vt') # moveTo (head vt') # lc col
2014-11-14 20:29:10 +00:00
-- |Create a diagram that shows all squares of the RangeSearch algorithm
-- from the quad tree.
2014-11-13 22:05:56 +00:00
squares :: Diag
squares = Diag f
where
2014-11-15 22:20:05 +00:00
f _ (Object []) = mempty
2014-11-13 22:05:56 +00:00
f p (Object vt) =
mconcat
2014-12-02 18:00:50 +00:00
$ (uncurry rectByDiagonal # lw ultraThin)
2014-12-03 00:36:12 +00:00
<$>
(quadTreeSquares (xDimension p, yDimension p)
. quadTree vt
$ (xDimension p, yDimension p))
2014-11-13 22:05:56 +00:00
f _ _ = mempty
-- |Draw the squares of the kd-tree.
kdSquares :: Diag
kdSquares = Diag f
where
f _ (Object []) = mempty
f p (Object vt) =
mconcat
. fmap (uncurry (~~))
$ kdLines (kdTree vt 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.
kdLines :: KDTree PT -> Square -> [(PT, PT)]
kdLines (KTNode ln pt Horizontal rn) ((xmin, xmax), (ymin, ymax)) =
(\(x, _) -> [(p2 (x, ymin), p2 (x, ymax))])
(unp2 pt)
++ kdLines ln ((xmin, x'), (ymin, ymax))
++ kdLines rn ((x', xmax), (ymin, ymax))
where
(x', _) = unp2 pt
kdLines (KTNode ln pt Vertical rn) ((xmin, xmax), (ymin, ymax)) =
(\(_, y) -> [(p2 (xmin, y), p2 (xmax, y))])
(unp2 pt)
++ kdLines ln ((xmin, xmax), (ymin, y'))
++ kdLines rn ((xmin, xmax), (y', ymax))
where
(_, y') = unp2 pt
kdLines _ _ = []
f _ _ = mempty
2014-11-15 22:20:05 +00:00
-- |Draw the range rectangle and highlight the points inside that range.
kdRange :: Diag
kdRange = Diag f
where
f _ (Object []) = mempty
f p (Object vt) =
2014-12-02 18:00:50 +00:00
(uncurry rectByDiagonal # lc red) (rangeSquare p)
2014-12-03 00:36:12 +00:00
<> drawP ptsInRange (dotSize p) # fc red # lc red
where
ptsInRange = fst . rangeSearch (kdTree vt Vertical) $ rangeSquare p
f _ _ = mempty
-- |The kd-tree visualized as binary tree.
kdTreeDiag :: Diag
kdTreeDiag = Diag f
where
f _ (Object []) = mempty
f p (Object vt) =
2014-12-03 20:20:34 +00:00
-- HACK: in order to give specific nodes a specific color
renderTree (\n -> case n of
'*':'*':_ -> (text n # fontSizeL 5.0)
<> rect 50.0 20.0 # fc green
'*':_ -> (text n # fontSizeL 5.0)
<> rect 50.0 20.0 # fc red
_ -> (text n # fontSizeL 5.0)
<> rect 50.0 20.0 # fc white)
(~~)
(symmLayout' (with & slHSep .~ 60 & slVSep .~ 40) roseTree)
# scale 2 # alignT # bg white
where
roseTree = snd
. rangeSearch (kdTree vt Vertical)
$ rangeSquare p
f _ _ = mempty
2014-11-15 22:22:56 +00:00
-- |Get the quad tree corresponding to the given points and diagram properties.
2014-11-15 22:20:05 +00:00
qt :: [PT] -> DiagProp -> QuadTree PT
qt vt p = quadTree vt (xDimension p, yDimension p)
2014-11-15 22:20:05 +00:00
-- |Create a diagram that shows a single square of the RangeSearch algorithm
-- from the quad tree in red, according to the given path in quadPath.
quadPathSquare :: Diag
quadPathSquare = Diag f
where
2014-11-15 22:20:05 +00:00
f _ (Object []) = mempty
f p (Object vt) =
2014-12-02 18:00:50 +00:00
(uncurry rectByDiagonal # lw thin # lc red)
2014-11-16 03:37:34 +00:00
(getSquare (stringToQuads (quadPath p)) (qt vt 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))
2014-11-15 22:20:05 +00:00
f _ _ = mempty
2014-11-14 21:19:14 +00:00
-- |Create a list of diagrams that show the walk along the given path
-- through the quad tree.
gifQuadPath :: Diag
gifQuadPath = GifDiag f
where
f p col _ vt =
2014-12-02 18:00:50 +00:00
(uncurry rectByDiagonal # lw thick # lc col)
2014-11-16 03:37:34 +00:00
<$> getSquares (stringToQuads (quadPath p)) (qt vt p, [])
2014-11-14 21:19:14 +00:00
where
getSquares :: [Either Quad Orient] -> QTZipper PT -> [Square]
getSquares [] z = [getSquareByZipper (xDimension p, yDimension p) z]
2014-11-14 21:19:14 +00:00
getSquares (q:qs) z = case q of
Right x -> getSquareByZipper (xDimension p, yDimension p) z :
getSquares qs (fromMaybe z (findNeighbor x z))
Left x -> getSquareByZipper (xDimension p, yDimension p) z :
getSquares qs (fromMaybe z (goQuad x z))
2014-11-14 21:19:14 +00:00
-- |A diagram that shows the full Quad Tree with nodes.
treePretty :: Diag
treePretty = Diag f
where
2014-11-15 22:20:05 +00:00
f _ (Object []) = mempty
f p (Object vt) =
2014-11-16 03:37:34 +00:00
prettyRoseTree (quadTreeToRoseTree
. flip getCurQT (qt vt p, [])
. stringToQuads
. quadPath
$ p)
where
getCurQT :: [Either Quad Orient] -> QTZipper PT -> QTZipper PT
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
2014-11-15 22:20:05 +00:00
prettyRoseTree tree =
2014-12-03 20:20:34 +00:00
-- HACK: in order to give specific nodes a specific color
renderTree (\n -> case head n of
2014-11-16 03:37:34 +00:00
'*' -> (text n # fontSizeL 5.0)
<> rect 50.0 20.0 # fc red
_ -> (text n # fontSizeL 5.0)
<> rect 50.0 20.0 # fc white)
(~~)
2014-11-15 22:20:05 +00:00
(symmLayout' (with & slHSep .~ 60 & slVSep .~ 40) tree)
# scale 2 # alignT # bg white
2014-11-15 22:20:05 +00:00
f _ _ = mempty
-- |Creates a Diagram that shows an XAxis which is bound
2014-11-15 23:49:20 +00:00
-- by the dimensions given in xDimension from DiagProp.
xAxis :: Diag
2014-10-09 22:19:05 +00:00
xAxis =
2014-11-16 15:45:51 +00:00
Diag hRule
<> Diag segments
<> Diag labels
where
2014-12-03 00:36:12 +00:00
hRule p _ = arrowAt (p2 (diagXmin p, if diagYmin p <= 0 then 0 else diagYmin p))
(r2 (diagWidth p, 0))
segments p _ = hcat' (with & sep .~ squareSize p)
(replicate (floor . (/) (diagWidth p) $ squareSize p)
(vrule 10))
2014-11-16 03:37:34 +00:00
# moveTo (p2 (diagXmin p, if diagYmin p <= 0 then 0 else diagYmin p))
2014-12-03 20:20:46 +00:00
labels p _ = position . zip (mkPoint <$> xs)
$ ((\x -> (text . show $ x) # scale 10) <$> xs)
2014-10-09 22:19:05 +00:00
where
xs :: [Int]
xs = take (floor . (/) (diagWidth p) $ squareSize p)
(iterate (+(floor . squareSize $ p)) (floor . diagXmin $ p))
mkPoint x = p2 (fromIntegral x,
-15 + (if diagYmin p <= 0 then 0 else diagYmin p))
-- |Creates a Diagram that shows an YAxis which is bound
2014-11-15 23:49:20 +00:00
-- by the dimensions given in yDimension from DiagProp.
yAxis :: Diag
2014-10-09 22:19:05 +00:00
yAxis =
2014-11-16 15:45:51 +00:00
Diag vRule
<> Diag segments
<> Diag labels
where
2014-12-03 20:20:46 +00:00
vRule p _ = arrowAt (p2 (if diagXmin p <= 0 then 0 else diagXmin p, diagYmin p))
(r2 (0, diagHeight p))
segments p _ = vcat' (with & sep .~ squareSize p)
(replicate (floor . (/) (diagHeight p) $ squareSize p)
(hrule 10))
2014-11-16 03:37:34 +00:00
# alignB
# moveTo (p2 (if diagXmin p <= 0 then 0 else diagXmin p, diagYmin p))
2014-12-03 20:20:46 +00:00
labels p _ = position . zip (mkPoint <$> ys)
$ ((\x -> (text . show $ x) # scale 10) <$> ys)
2014-10-09 19:37:45 +00:00
where
ys :: [Int]
ys = take (floor . (/) (diagHeight p) $ squareSize p)
(iterate (+(floor . squareSize $ p)) (floor . diagYmin $ p))
mkPoint y = p2 (-15 + (if diagXmin p <= 0 then 0 else diagXmin p),
fromIntegral y)
-- |Creates a Diagram that shows a white rectangle which is a little
2014-10-10 15:40:08 +00:00
-- bit bigger than both X and Y axis dimensions from DiagProp.
whiteRectB :: Diag
2014-10-09 22:42:15 +00:00
whiteRectB = Diag rect'
where
2014-12-03 20:20:46 +00:00
rect' p _ = whiteRect (diagWidth p + (diagWidth p / 10))
(diagHeight p + (diagHeight p / 10))
# moveTo (p2 (diagWidthOffset p, diagHeightOffset p))
where
2014-10-11 01:59:21 +00:00
-- |Create a white rectangle with the given width and height.
whiteRect :: Double -> Double -> Diagram Cairo R2
whiteRect x y = rect x y # lwG 0.00 # bg white
2014-10-09 16:45:37 +00:00
2014-10-09 23:08:53 +00:00
-- |Create a grid across the whole diagram with squares of the
-- given size in DiagProp.
2014-10-09 16:45:37 +00:00
grid :: Diag
2014-10-14 19:24:21 +00:00
grid = Diag xGrid <> Diag yGrid
2014-10-09 16:45:37 +00:00
where
yGrid p _
2014-12-03 00:36:12 +00:00
| haveGrid p = hcat' (with & sep .~ squareSize p)
(replicate (floor . (/) (diagWidth p) $ squareSize p)
(vrule $ diagHeight p))
2014-11-16 03:37:34 +00:00
# moveTo (p2 (diagXmin p, diagHeightOffset p)) # lw ultraThin
| otherwise = mempty
xGrid p _
2014-12-03 00:36:12 +00:00
| haveGrid p = vcat' (with & sep .~ squareSize p)
(replicate (floor . (/) (diagHeight p) $ squareSize p)
(hrule $ diagWidth p))
2014-11-16 03:37:34 +00:00
# alignB # moveTo (p2 (diagWidthOffset p, diagYmin p)) # lw ultraThin
| otherwise = mempty
plotterBG :: Diag
plotterBG = mconcat [xAxis, yAxis, grid, whiteRectB]