2014-10-06 21:14:23 +00:00
|
|
|
{-# 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.ConvexHull.GrahamScan
|
2014-11-15 13:24:24 +00:00
|
|
|
import Algorithms.QuadTree.QuadTree
|
2014-11-29 18:21:17 +00:00
|
|
|
import Algorithms.KDTree.KDTree
|
2014-10-25 01:15:38 +00:00
|
|
|
import Algorithms.PolygonIntersection.Core
|
2014-11-14 20:28:56 +00:00
|
|
|
import Data.Maybe
|
2014-10-14 19:24:21 +00:00
|
|
|
import Data.Monoid
|
2014-11-15 02:58:38 +00:00
|
|
|
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 ((<>))
|
2014-11-15 02:58:38 +00:00
|
|
|
import Diagrams.TwoD.Layout.Tree
|
2014-10-10 15:40:08 +00:00
|
|
|
import Graphics.Diagram.Types
|
2014-11-14 20:28:56 +00:00
|
|
|
import Parser.PathParser
|
2014-10-10 13:40:56 +00:00
|
|
|
|
|
|
|
|
2014-10-08 17:23:40 +00:00
|
|
|
-- |Creates a Diagram that shows the coordinates from the points
|
|
|
|
-- as dots. The points and thickness of the dots can be controlled
|
2014-10-06 19:11:28 +00:00
|
|
|
-- via DiagProp.
|
2014-10-09 15:19:58 +00:00
|
|
|
coordPoints :: Diag
|
2014-10-09 22:42:15 +00:00
|
|
|
coordPoints = Diag cp
|
2014-10-06 19:11:28 +00:00
|
|
|
where
|
2014-10-25 13:40:10 +00:00
|
|
|
cp p (Object vt) = drawP vt p
|
|
|
|
cp p (Objects vts) = drawP (concat vts) p
|
|
|
|
drawP [] _ = mempty
|
|
|
|
drawP vt p =
|
2014-11-16 15:44:26 +00:00
|
|
|
position (zip vt (repeat dot))
|
2014-10-09 22:19:05 +00:00
|
|
|
where
|
2014-11-15 23:10:57 +00:00
|
|
|
dot = (circle $ dotSize p :: Diagram Cairo R2) # fc black
|
2014-10-06 19:11:28 +00:00
|
|
|
|
|
|
|
|
2014-10-10 13:34:18 +00:00
|
|
|
-- |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 =
|
2014-10-25 22:19:58 +00:00
|
|
|
text ("(" ++ (show . trim') x ++ ", " ++ (show . trim') y ++ ")") # scale 10
|
2014-10-10 13:34:18 +00:00
|
|
|
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))
|
2014-10-10 13:34:18 +00:00
|
|
|
(x, y) = unp2 pt
|
|
|
|
|
|
|
|
|
2014-10-10 13:34:38 +00:00
|
|
|
-- |Show coordinates as text above all points.
|
2014-10-10 13:03:12 +00:00
|
|
|
coordPointsText :: Diag
|
|
|
|
coordPointsText = Diag cpt
|
|
|
|
where
|
2014-10-25 13:40:10 +00:00
|
|
|
cpt p (Object vt) = drawT vt p
|
|
|
|
cpt p (Objects vts) = drawT (concat vts) p
|
|
|
|
drawT [] _ = mempty
|
|
|
|
drawT vt p
|
2014-11-15 23:10:57 +00:00
|
|
|
| showCoordText p =
|
2014-11-16 03:37:34 +00:00
|
|
|
position
|
2014-11-16 15:44:26 +00:00
|
|
|
$ zip vt (pointToTextCoord <$> vt)
|
2014-11-16 03:37:34 +00:00
|
|
|
# translate (r2 (0, 10))
|
2014-10-25 13:40:10 +00:00
|
|
|
| otherwise = mempty
|
2014-10-10 13:03:12 +00:00
|
|
|
|
|
|
|
|
2014-10-25 01:15:38 +00:00
|
|
|
-- |Draw the lines of the polygon.
|
|
|
|
polyLines :: Diag
|
|
|
|
polyLines = Diag pp
|
|
|
|
where
|
2014-10-25 13:40:10 +00:00
|
|
|
pp _ (Objects []) = mempty
|
2014-11-16 15:44:26 +00:00
|
|
|
pp _ (Objects (x:y:_)) =
|
2014-10-25 13:40:10 +00:00
|
|
|
strokePoly x <> strokePoly y
|
2014-10-25 01:15:38 +00:00
|
|
|
where
|
2014-10-25 13:40:10 +00:00
|
|
|
strokePoly x' =
|
2014-11-16 03:37:34 +00:00
|
|
|
(strokeTrail
|
|
|
|
. fromVertices
|
2014-11-16 15:44:26 +00:00
|
|
|
$ x' ++ [head x'])
|
2014-11-16 03:37:34 +00:00
|
|
|
# moveTo (head x') # lc black
|
2014-10-25 13:40:10 +00:00
|
|
|
pp _ _ = mempty
|
2014-10-25 01:15:38 +00:00
|
|
|
|
|
|
|
|
|
|
|
-- |Show the intersection points of two polygons as red dots.
|
2014-10-25 13:40:10 +00:00
|
|
|
polyIntersection :: Diag
|
|
|
|
polyIntersection = Diag pi'
|
2014-10-25 01:15:38 +00:00
|
|
|
where
|
2014-10-25 13:40:10 +00:00
|
|
|
pi' p (Objects (x:y:_)) = position (zip vtpi (repeat dot))
|
|
|
|
where
|
2014-11-15 23:10:57 +00:00
|
|
|
dot = (circle $ dotSize p :: Diagram Cairo R2) # fc red # lc red
|
2014-10-25 13:40:10 +00:00
|
|
|
vtpi = intersectionPoints
|
2014-11-16 03:37:34 +00:00
|
|
|
. sortLexPolys
|
2014-11-16 15:44:26 +00:00
|
|
|
$ (sortLexPoly x,
|
|
|
|
sortLexPoly y)
|
2014-10-25 13:40:10 +00:00
|
|
|
pi' _ _ = mempty
|
2014-10-25 01:15:38 +00:00
|
|
|
|
|
|
|
|
2014-11-16 03:37:34 +00:00
|
|
|
-- |Show the coordinate text of the intersection points of two polygons.
|
2014-10-25 13:40:10 +00:00
|
|
|
polyIntersectionText :: Diag
|
|
|
|
polyIntersectionText = Diag pit'
|
2014-10-25 01:15:38 +00:00
|
|
|
where
|
2014-10-25 13:40:10 +00:00
|
|
|
pit' p (Objects (x:y:_))
|
2014-11-15 23:10:57 +00:00
|
|
|
| showCoordText p =
|
2014-11-16 03:37:34 +00:00
|
|
|
position
|
|
|
|
. zip vtpi
|
|
|
|
$ (pointToTextCoord # fc red <$> vtpi)
|
|
|
|
# translate (r2 (0, 10))
|
2014-10-25 13:40:10 +00:00
|
|
|
| otherwise = mempty
|
|
|
|
where
|
|
|
|
vtpi = intersectionPoints
|
|
|
|
. sortLexPolys
|
2014-11-16 15:44:26 +00:00
|
|
|
$ (sortLexPoly x,
|
|
|
|
sortLexPoly y)
|
2014-10-25 13:40:10 +00:00
|
|
|
pit' _ _ = mempty
|
2014-10-25 01:15:38 +00:00
|
|
|
|
|
|
|
|
2014-10-08 14:39:46 +00:00
|
|
|
-- |Create a diagram which shows the points of the convex hull.
|
2014-10-13 18:14:50 +00:00
|
|
|
convexHP :: Diag
|
|
|
|
convexHP = Diag chp
|
2014-10-08 14:39:46 +00:00
|
|
|
where
|
2014-10-25 13:40:10 +00:00
|
|
|
chp p (Object vt) =
|
2014-10-14 08:56:06 +00:00
|
|
|
position (zip vtch
|
2014-10-09 22:19:05 +00:00
|
|
|
(repeat dot))
|
|
|
|
where
|
2014-11-15 23:10:57 +00:00
|
|
|
dot = (circle $ dotSize p :: Diagram Cairo R2) # fc red # lc red
|
2014-11-16 15:44:26 +00:00
|
|
|
vtch = grahamCH vt
|
2014-10-25 13:40:10 +00:00
|
|
|
chp _ _ = mempty
|
2014-10-08 14:39:46 +00:00
|
|
|
|
|
|
|
|
2014-10-10 13:34:38 +00:00
|
|
|
-- |Show coordinates as text above the convex hull points.
|
2014-10-13 18:14:50 +00:00
|
|
|
convexHPText :: Diag
|
|
|
|
convexHPText = Diag chpt
|
2014-10-10 13:03:12 +00:00
|
|
|
where
|
2014-10-25 13:40:10 +00:00
|
|
|
chpt p (Object vt)
|
2014-11-15 23:10:57 +00:00
|
|
|
| showCoordText p =
|
2014-10-25 13:40:10 +00:00
|
|
|
position $
|
|
|
|
zip vtchf
|
|
|
|
(pointToTextCoord <$> vtchf) # translate (r2 (0, 10))
|
|
|
|
| otherwise = mempty
|
2014-10-10 13:03:12 +00:00
|
|
|
where
|
2014-11-16 15:44:26 +00:00
|
|
|
vtchf = grahamCH vt
|
2014-10-25 13:40:10 +00:00
|
|
|
chpt _ _ = mempty
|
2014-10-10 13:03:12 +00:00
|
|
|
|
|
|
|
|
2014-10-09 01:10:21 +00:00
|
|
|
-- |Create a diagram which shows the lines along the convex hull
|
|
|
|
-- points.
|
2014-10-13 18:14:50 +00:00
|
|
|
convexHLs :: Diag
|
|
|
|
convexHLs = Diag chl
|
2014-10-08 17:31:55 +00:00
|
|
|
where
|
2014-10-25 13:40:10 +00:00
|
|
|
chl _ (Object []) = mempty
|
2014-11-16 15:44:26 +00:00
|
|
|
chl _ (Object vt) =
|
2014-11-16 03:37:34 +00:00
|
|
|
(strokeTrail
|
|
|
|
. fromVertices
|
2014-11-16 15:44:26 +00:00
|
|
|
. flip (++) [head $ grahamCH vt]
|
2014-11-16 03:37:34 +00:00
|
|
|
. grahamCH
|
2014-11-16 15:44:26 +00:00
|
|
|
$ vt)
|
|
|
|
# moveTo (head $ grahamCH vt) # lc red
|
2014-10-25 13:40:10 +00:00
|
|
|
chl _ _ = mempty
|
2014-10-08 17:31:55 +00:00
|
|
|
|
|
|
|
|
2014-10-13 18:14:50 +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.
|
2014-10-25 21:54:07 +00:00
|
|
|
convexHStepsLs :: Diag
|
|
|
|
convexHStepsLs = GifDiag chs
|
2014-10-09 22:19:05 +00:00
|
|
|
where
|
2014-11-16 16:25:58 +00:00
|
|
|
chs _ col f vt =
|
2014-11-16 15:44:26 +00:00
|
|
|
fmap mkChDiag (f vt)
|
2014-10-25 21:54:07 +00:00
|
|
|
where
|
|
|
|
mkChDiag vt' =
|
|
|
|
(strokeTrail . fromVertices $ vt') # moveTo (head vt') # lc col
|
2014-10-09 01:10:21 +00:00
|
|
|
|
|
|
|
|
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-11-15 23:49:05 +00:00
|
|
|
$ (\((xmin, xmax), (ymin, ymax)) -> rect (xmax - xmin) (ymax - ymin)
|
|
|
|
# moveTo (p2 ((xmax + xmin) / 2, (ymax + ymin) / 2)) # lw ultraThin)
|
2014-11-16 03:37:34 +00:00
|
|
|
<$> (quadTreeSquares (xDimension p, yDimension p)
|
2014-11-16 15:44:26 +00:00
|
|
|
. quadTree vt
|
2014-11-16 03:37:34 +00:00
|
|
|
$ (xDimension p, yDimension p))
|
2014-11-13 22:05:56 +00:00
|
|
|
f _ _ = mempty
|
|
|
|
|
|
|
|
|
2014-11-29 18:21:17 +00:00
|
|
|
-- |Draw the squares of the kd-tree.
|
|
|
|
kdSquares:: Diag
|
|
|
|
kdSquares = Diag f
|
|
|
|
where
|
|
|
|
f _ (Object []) = mempty
|
|
|
|
f p (Object vt) =
|
|
|
|
mconcat
|
|
|
|
. fmap fromVertices
|
|
|
|
$ drawAll (kdTree vt Horizontal) (xDimension p, yDimension p)
|
|
|
|
where
|
|
|
|
drawAll :: KDTree PT -> Square -> [[PT]]
|
|
|
|
drawAll (KTNode ln pt Horizontal rn) ((xmin, xmax), (ymin, ymax)) =
|
|
|
|
(\(x, _) -> [[p2 (x, ymin), p2 (x, ymax)]])
|
|
|
|
(unp2 pt)
|
|
|
|
++ drawAll ln ((xmin, x'), (ymin, ymax))
|
|
|
|
++ drawAll rn ((x', xmax), (ymin, ymax))
|
|
|
|
where
|
|
|
|
(x', _) = unp2 pt
|
|
|
|
drawAll (KTNode ln pt Vertical rn) ((xmin, xmax), (ymin, ymax)) =
|
|
|
|
(\(_, y) -> [[p2 (xmin, y), p2 (xmax, y)]])
|
|
|
|
(unp2 pt)
|
|
|
|
++ drawAll ln ((xmin, xmax), (ymin, y'))
|
|
|
|
++ drawAll rn ((xmin, xmax), (y', ymax))
|
|
|
|
where
|
|
|
|
(_, y') = unp2 pt
|
|
|
|
drawAll _ _ = [[]]
|
|
|
|
f _ _ = mempty
|
|
|
|
|
2014-11-15 22:20:05 +00:00
|
|
|
|
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
|
2014-11-16 15:44:26 +00:00
|
|
|
qt vt p = quadTree vt (xDimension p, yDimension p)
|
2014-11-15 22:20:05 +00:00
|
|
|
|
|
|
|
|
2014-11-14 20:28:56 +00:00
|
|
|
-- |Create a diagram that shows a single square of the RangeSearch algorithm
|
2014-11-15 23:10:57 +00:00
|
|
|
-- from the quad tree in red, according to the given path in quadPath.
|
2014-11-14 20:28:56 +00:00
|
|
|
quadPathSquare :: Diag
|
|
|
|
quadPathSquare = Diag f
|
|
|
|
where
|
2014-11-15 22:20:05 +00:00
|
|
|
f _ (Object []) = mempty
|
2014-11-14 20:28:56 +00:00
|
|
|
f p (Object vt) =
|
2014-11-15 23:49:05 +00:00
|
|
|
(\((xmin, xmax), (ymin, ymax)) -> rect (xmax - xmin) (ymax - ymin)
|
|
|
|
# moveTo (p2 ((xmax + xmin) / 2,(ymax + ymin) / 2)) # lw thin # lc red)
|
2014-11-16 03:37:34 +00:00
|
|
|
(getSquare (stringToQuads (quadPath p)) (qt vt p, []))
|
2014-11-14 20:28:56 +00:00
|
|
|
where
|
2014-11-14 21:58:21 +00:00
|
|
|
getSquare :: [Either Quad Orient] -> Zipper PT -> Square
|
2014-11-15 23:10:57 +00:00
|
|
|
getSquare [] z = getSquareByZipper (xDimension p, yDimension p) z
|
2014-11-14 20:28:56 +00:00
|
|
|
getSquare (q:qs) z = case q of
|
2014-11-14 21:58:21 +00:00
|
|
|
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 20:28:56 +00:00
|
|
|
|
|
|
|
|
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-11-15 23:49:05 +00:00
|
|
|
(\((xmin, xmax), (ymin, ymax)) -> rect (xmax - xmin) (ymax - ymin)
|
|
|
|
# moveTo (p2 ((xmax + xmin) / 2,(ymax + ymin) / 2)) # 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
|
2014-11-14 21:58:21 +00:00
|
|
|
getSquares :: [Either Quad Orient] -> Zipper PT -> [Square]
|
2014-11-15 23:10:57 +00:00
|
|
|
getSquares [] z = [getSquareByZipper (xDimension p, yDimension p) z]
|
2014-11-14 21:19:14 +00:00
|
|
|
getSquares (q:qs) z = case q of
|
2014-11-15 23:10:57 +00:00
|
|
|
Right x -> getSquareByZipper (xDimension p, yDimension p) z :
|
2014-11-14 21:58:21 +00:00
|
|
|
getSquares qs (fromMaybe z (findNeighbor x z))
|
2014-11-15 23:10:57 +00:00
|
|
|
Left x -> getSquareByZipper (xDimension p, yDimension p) z :
|
2014-11-14 21:58:21 +00:00
|
|
|
getSquares qs (fromMaybe z (goQuad x z))
|
2014-11-14 21:19:14 +00:00
|
|
|
|
|
|
|
|
2014-11-15 02:58:38 +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
|
2014-11-15 14:26:43 +00:00
|
|
|
f p (Object vt) =
|
2014-11-16 03:37:34 +00:00
|
|
|
prettyRoseTree (quadTreeToRoseTree
|
|
|
|
. flip getCurQT (qt vt p, [])
|
|
|
|
. stringToQuads
|
|
|
|
. quadPath
|
|
|
|
$ p)
|
2014-11-15 02:58:38 +00:00
|
|
|
where
|
2014-11-15 14:26:43 +00:00
|
|
|
getCurQT :: [Either Quad Orient] -> Zipper PT -> Zipper 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))
|
2014-11-15 02:58:38 +00:00
|
|
|
prettyRoseTree :: Tree String -> Diagram Cairo R2
|
2014-11-15 22:20:05 +00:00
|
|
|
prettyRoseTree tree =
|
2014-11-15 14:26:43 +00:00
|
|
|
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 02:58:38 +00:00
|
|
|
(~~)
|
2014-11-15 22:20:05 +00:00
|
|
|
(symmLayout' (with & slHSep .~ 60 & slVSep .~ 40) tree)
|
2014-11-15 02:58:38 +00:00
|
|
|
# scale 2 # alignT # bg white
|
2014-11-15 22:20:05 +00:00
|
|
|
f _ _ = mempty
|
2014-11-15 02:58:38 +00:00
|
|
|
|
|
|
|
|
2014-10-06 19:11:28 +00:00
|
|
|
-- |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.
|
2014-10-09 15:19:58 +00:00
|
|
|
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
|
2014-10-06 19:11:28 +00:00
|
|
|
where
|
2014-10-09 22:19:05 +00:00
|
|
|
hRule p _ =
|
2014-11-15 23:10:57 +00:00
|
|
|
arrowAt (p2 (diagXmin p, if diagYmin p <= 0 then 0 else diagYmin p))
|
|
|
|
(r2 (diagWidth p, 0))
|
2014-10-09 22:19:05 +00:00
|
|
|
segments p _ =
|
2014-11-15 23:10:57 +00:00
|
|
|
hcat' (with & sep .~ squareSize p)
|
|
|
|
(replicate (floor . (/) (diagWidth p) $ squareSize p)
|
2014-11-16 03:37:34 +00:00
|
|
|
(vrule 10))
|
|
|
|
# moveTo (p2 (diagXmin p, if diagYmin p <= 0 then 0 else diagYmin p))
|
2014-10-09 19:37:45 +00:00
|
|
|
labels p _ =
|
2014-10-09 22:19:05 +00:00
|
|
|
position $
|
|
|
|
zip (mkPoint <$> xs)
|
2014-10-10 21:28:01 +00:00
|
|
|
((\x -> (text . show $ x) # scale 10) <$> xs)
|
2014-10-09 22:19:05 +00:00
|
|
|
where
|
|
|
|
xs :: [Int]
|
2014-11-15 23:10:57 +00:00
|
|
|
xs = take (floor . (/) (diagWidth p) $ squareSize p)
|
|
|
|
(iterate (+(floor . squareSize $ p)) (floor . diagXmin $ p))
|
2014-10-11 11:49:53 +00:00
|
|
|
mkPoint x = p2 (fromIntegral x,
|
2014-11-15 23:10:57 +00:00
|
|
|
-15 + (if diagYmin p <= 0 then 0 else diagYmin p))
|
2014-10-06 19:11:28 +00:00
|
|
|
|
|
|
|
|
|
|
|
-- |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.
|
2014-10-09 15:19:58 +00:00
|
|
|
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
|
2014-10-06 19:11:28 +00:00
|
|
|
where
|
2014-10-09 22:19:05 +00:00
|
|
|
vRule p _ =
|
2014-11-15 23:10:57 +00:00
|
|
|
arrowAt (p2 (if diagXmin p <= 0 then 0 else diagXmin p, diagYmin p))
|
|
|
|
(r2 (0, diagHeight p))
|
2014-10-09 22:19:05 +00:00
|
|
|
segments p _ =
|
2014-11-15 23:10:57 +00:00
|
|
|
vcat' (with & sep .~ squareSize p)
|
|
|
|
(replicate (floor . (/) (diagHeight p) $ squareSize p)
|
2014-11-16 03:37:34 +00:00
|
|
|
(hrule 10))
|
|
|
|
# alignB
|
|
|
|
# moveTo (p2 (if diagXmin p <= 0 then 0 else diagXmin p, diagYmin p))
|
2014-10-09 19:37:45 +00:00
|
|
|
labels p _ =
|
2014-10-09 22:19:05 +00:00
|
|
|
position $
|
|
|
|
zip (mkPoint <$> ys)
|
2014-10-10 21:28:01 +00:00
|
|
|
((\x -> (text . show $ x) # scale 10) <$> ys)
|
2014-10-09 19:37:45 +00:00
|
|
|
where
|
|
|
|
ys :: [Int]
|
2014-11-15 23:10:57 +00:00
|
|
|
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),
|
2014-10-11 11:49:53 +00:00
|
|
|
fromIntegral y)
|
2014-10-06 19:11:28 +00:00
|
|
|
|
|
|
|
|
|
|
|
-- |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.
|
2014-10-09 15:19:58 +00:00
|
|
|
whiteRectB :: Diag
|
2014-10-09 22:42:15 +00:00
|
|
|
whiteRectB = Diag rect'
|
2014-10-06 19:11:28 +00:00
|
|
|
where
|
2014-10-11 01:59:21 +00:00
|
|
|
rect' p _ =
|
2014-11-16 03:37:34 +00:00
|
|
|
whiteRect (diagWidth p + (diagWidth p / 10))
|
|
|
|
(diagHeight p + (diagHeight p / 10))
|
|
|
|
# moveTo (p2 (diagWidthOffset p, diagHeightOffset p))
|
2014-10-08 17:23:15 +00:00
|
|
|
where
|
2014-10-11 01:59:21 +00:00
|
|
|
|
2014-10-06 19:11:28 +00:00
|
|
|
|
2014-10-05 16:41:41 +00:00
|
|
|
-- |Create a white rectangle with the given width and height.
|
2014-10-06 19:22:32 +00:00
|
|
|
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
|
2014-10-25 13:40:10 +00:00
|
|
|
yGrid p _
|
2014-11-15 23:10:57 +00:00
|
|
|
| haveGrid p =
|
|
|
|
hcat' (with & sep .~ squareSize p)
|
|
|
|
(replicate (floor . (/) (diagWidth p) $ squareSize p)
|
2014-11-16 03:37:34 +00:00
|
|
|
(vrule $ diagHeight p))
|
|
|
|
# moveTo (p2 (diagXmin p, diagHeightOffset p)) # lw ultraThin
|
2014-10-25 13:40:10 +00:00
|
|
|
| otherwise = mempty
|
|
|
|
xGrid p _
|
2014-11-15 23:10:57 +00:00
|
|
|
| haveGrid p =
|
|
|
|
vcat' (with & sep .~ squareSize p)
|
|
|
|
(replicate (floor . (/) (diagHeight p) $ squareSize p)
|
2014-11-16 03:37:34 +00:00
|
|
|
(hrule $ diagWidth p))
|
|
|
|
# alignB # moveTo (p2 (diagWidthOffset p, diagYmin p)) # lw ultraThin
|
2014-10-25 13:40:10 +00:00
|
|
|
| otherwise = mempty
|
|
|
|
|
|
|
|
|
|
|
|
plotterBG :: Diag
|
|
|
|
plotterBG = mconcat [xAxis, yAxis, grid, whiteRectB]
|