cga/Graphics/Diagram/Plotter.hs

142 lines
4.1 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-14 19:24:21 +00:00
import Data.Monoid
import Diagrams.Prelude hiding ((<>))
import Graphics.Diagram.Core
2014-12-02 18:00:50 +00:00
2014-12-07 19:30:51 +00:00
-- |All x coordinates separated by the squareSize on DiagProp.
xAxisPoints :: DiagProp -> [Double]
xAxisPoints p = takeWhile (< diagXmax p)
. iterate (+ squareSize p)
$ diagXmin p
2014-12-07 19:30:51 +00:00
-- |All y coordinates separated by the squareSize on DiagProp.
yAxisPoints :: DiagProp -> [Double]
yAxisPoints p = takeWhile (< diagYmax p)
. iterate (+ squareSize p)
$ diagYmin p
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 f
2014-12-02 18:00:50 +00:00
where
f p vts = drawP (concat vts) (relDotSize p) # fc black # lc black
relDotSize p = dotSize p / 500 * ((diagWidth p + diagHeight p) / 2)
2014-10-10 13:34:38 +00:00
-- |Show coordinates as text above all points.
coordPointsText :: Diag
coordPointsText = Diag f
where
f p 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
-- |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
hRule p _ =
arrowAt (p2 (diagXmin p, diagYminPos p))
(r2 (diagWidth p, 0))
segments p _ =
mconcat
. fmap (\x -> p2 (x, diagYminPos p - segY)
~~ p2 (x, diagYminPos p + segY))
$ xAxisPoints p
2014-10-09 22:19:05 +00:00
where
segY = diagWidth p / 100
labels p _ =
position
. zip (mkPoint <$> xAxisPoints p)
$ ((\x -> (text . show . floor $ x) # scale labelScale)
<$> xAxisPoints p)
where
mkPoint x =
p2 (x, labelOffset + diagYminPos p)
labelScale = diagWidth p / 50
labelOffset = negate (diagWidth p / 50 * 2)
diagYminPos p = 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
vRule p _ =
arrowAt (p2 (diagXminPos p, diagYmin p))
(r2 (0, diagHeight p))
segments p _ =
mconcat
. fmap (\y -> p2 (diagXminPos p - segX, y)
~~ p2 (diagXminPos p + segX, y))
$ yAxisPoints p
where
segX = diagHeight p / 100
labels p _ =
position
. zip (mkPoint <$> yAxisPoints p)
$ ((\x -> (text . show . floor $ x) # scale labelScale)
<$> yAxisPoints p)
2014-10-09 19:37:45 +00:00
where
mkPoint y =
p2 (labelOffset + diagXminPos p, y)
labelScale = diagHeight p / 50
labelOffset = negate (diagHeight p / 50 * 2)
diagXminPos p = if diagXmin p <= 0 then 0 else diagXmin p
-- |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
rect' p _ = rect (diagWidth p + (diagWidth p / 10))
(diagHeight p + (diagHeight p / 10))
# lwG 0.00
# bg white
2014-12-03 20:20:46 +00:00
# moveTo (p2 (diagWidthOffset p, diagHeightOffset p))
2014-10-11 01:59:21 +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 _
| haveGrid p =
mconcat
. fmap (\x -> p2 (x, diagYmin p)
~~ p2 (x, diagYmax p) # lw ultraThin)
$ xAxisPoints p
| otherwise = mempty
xGrid p _
| haveGrid p =
mconcat
. fmap (\y -> p2 (diagXmin p, y)
~~ p2 (diagXmax p, y) # lw ultraThin)
$ yAxisPoints p
| otherwise = mempty
plotterBG :: Diag
plotterBG = mconcat [xAxis, yAxis, grid, whiteRectB]