cga/Graphics/Diagram/Plotter.hs

197 lines
5.6 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.Vector
import Algebra.VectorTypes
import Algorithms.ConvexHull.GrahamScan
2014-09-30 22:05:29 +00:00
import Diagrams.Backend.Cairo
import Diagrams.Prelude
2014-10-10 15:40:08 +00:00
import Graphics.Diagram.Types
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
-- via DiagProp.
coordPoints :: Diag
2014-10-09 22:42:15 +00:00
coordPoints = Diag cp
where
2014-10-09 22:42:15 +00:00
cp p vt =
2014-10-11 01:59:21 +00:00
position (zip (filter (inRange (dX p) (dY p)) vt)
2014-10-09 22:19:05 +00:00
(repeat dot))
where
dot = (circle $ t p :: Diagram Cairo R2) # fc 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 x ++ ", " ++ show y ++ ")") # scale 10
where
(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 vt =
position $
zip vtf (pointToTextCoord <$> vtf) # translate (r2 (0, 10))
where
vtf = filter (inRange (dX p) (dY p)) vt
-- |Create a diagram which shows the points of the convex hull.
convexHullPoints :: Diag
2014-10-09 22:42:15 +00:00
convexHullPoints = Diag chp
where
2014-10-09 22:42:15 +00:00
chp p vt =
2014-10-11 01:59:21 +00:00
position (zip (filter (inRange (dX p) (dY p)) vtch)
2014-10-09 22:19:05 +00:00
(repeat dot))
where
dot = (circle $ t p :: Diagram Cairo R2) # fc red # lc red
vtch = grahamGetCH vt
2014-10-10 13:34:38 +00:00
-- |Show coordinates as text above the convex hull points.
convexHullPointsText :: Diag
convexHullPointsText = Diag chpt
where
chpt p vt =
position $
zip vtchf
(pointToTextCoord <$> vtchf) # translate (r2 (0, 10))
where
vtchf = grahamGetCH . filter (inRange (dX p) (dY p)) $ vt
-- |Create a diagram which shows the lines along the convex hull
-- points.
convexHullLines :: Diag
2014-10-09 22:42:15 +00:00
convexHullLines = Diag chl
2014-10-08 17:31:55 +00:00
where
2014-10-09 22:42:15 +00:00
chl _ [] = mempty
chl p vt =
2014-10-09 22:19:05 +00:00
(strokeTrail .
fromVertices .
flip (++) [head $ grahamGetCH vtf] .
grahamGetCH $
vtf) #
moveTo (head $ grahamGetCH vtf) #
lc red
where
vtf = filter (inRange (dX p) (dY p)) vt
2014-10-08 17:31:55 +00:00
-- |Same as showConvexHullLines, except that it returns an array
-- of diagrams with each step of the algorithm.
2014-10-09 15:20:14 +00:00
-- Unfortunately this is very difficult to implement as a Diag (TODO).
convexHullLinesInterval :: DiagProp -> [PT] -> [Diagram Cairo R2]
convexHullLinesInterval p xs =
2014-10-09 22:42:15 +00:00
fmap mkChDiag (grahamGetCHSteps xs)
2014-10-09 22:19:05 +00:00
where
2014-10-09 22:42:15 +00:00
mkChDiag vt =
2014-10-09 22:19:05 +00:00
(strokeTrail .
fromVertices $
vtf) #
moveTo (head vtf) #
lc red
where
vtf = filter (inRange (dX p) (dY p)) vt
-- |Creates a Diagram that shows an XAxis which is bound
-- by the dimensions given in xD from DiagProp.
xAxis :: Diag
2014-10-09 22:19:05 +00:00
xAxis =
2014-10-11 01:59:21 +00:00
Diag hRule `mappend`
Diag segments `mappend`
Diag labels
where
2014-10-09 22:19:05 +00:00
hRule p _ =
arrowAt (p2 (xmin p, if ymin p <= 0 then 0 else ymin p))
2014-10-11 01:59:21 +00:00
(r2 (w' p, 0))
2014-10-09 22:19:05 +00:00
segments p _ =
2014-10-11 01:59:21 +00:00
hcat' (with & sep .~ sqS p)
(replicate (floor . (/) (w' p) $ sqS p)
(vrule 10)) #
moveTo (p2 (xmin p, if ymin p <= 0 then 0 else ymin 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-10-11 01:59:21 +00:00
xs = take (floor . (/) (w' p) $ sqS p)
(iterate (+(floor . sqS $ p)) (floor . xmin $ p))
mkPoint x = p2 (fromIntegral x,
-15 + (if ymin p <= 0 then 0 else ymin p))
-- |Creates a Diagram that shows an YAxis which is bound
-- by the dimensions given in yD from DiagProp.
yAxis :: Diag
2014-10-09 22:19:05 +00:00
yAxis =
2014-10-11 01:59:21 +00:00
Diag vRule `mappend`
Diag segments `mappend`
Diag labels
where
2014-10-09 22:19:05 +00:00
vRule p _ =
arrowAt (p2 (if xmin p <= 0 then 0 else xmin p, ymin p))
2014-10-11 01:59:21 +00:00
(r2 (0, h' p))
2014-10-09 22:19:05 +00:00
segments p _ =
2014-10-11 01:59:21 +00:00
vcat' (with & sep .~ sqS p)
(replicate (floor . (/) (h' p) $ sqS p)
(hrule 10)) #
2014-10-09 22:19:05 +00:00
alignB #
moveTo (p2 (if xmin p <= 0 then 0 else xmin p, ymin 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-10-11 01:59:21 +00:00
ys = take (floor . (/) (h' p) $ sqS p)
(iterate (+(floor . sqS $ p)) (floor . ymin $ p))
mkPoint y = p2 (-15 + (if xmin p <= 0 then 0 else xmin 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-10-11 01:59:21 +00:00
rect' p _ =
whiteRect (w' p + 50) (h' p + 50) #
moveTo (p2 (wOff p, hOff 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-09 22:42:15 +00:00
grid = Diag xGrid `mappend` Diag yGrid
2014-10-09 16:45:37 +00:00
where
2014-10-09 22:42:15 +00:00
yGrid p _ =
hcat' (with & sep .~ sqS p)
2014-10-11 01:59:21 +00:00
(replicate (floor . (/) (w' p) $ sqS p)
(vrule $ h' p)) #
moveTo (p2 (xmin p, hOff p)) #
2014-10-09 22:19:05 +00:00
lw ultraThin
2014-10-09 22:42:15 +00:00
xGrid p _ =
vcat' (with & sep .~ sqS p)
2014-10-11 01:59:21 +00:00
(replicate (floor . (/) (h' p) $ sqS p)
(hrule $ w' p)) #
alignB #
moveTo (p2 (wOff p, ymin p)) #
2014-10-09 22:19:05 +00:00
lw ultraThin
2014-10-11 01:59:21 +00:00
where