----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Chart.Drawing -- Copyright : (c) Tim Docker 2006, 2014 -- License : BSD-style (see chart/COPYRIGHT) -- -- This module contains basic types and functions used for drawing. -- -- Note that Template Haskell is used to derive accessor functions -- (see 'Control.Lens') for each field of the following data types: -- -- * 'PointStyle' -- -- These accessors are not shown in this API documentation. They have -- the same name as the field, but with the trailing underscore -- dropped. Hence for data field @f_::F@ in type @D@, they have type -- -- @ -- f :: Control.Lens.Lens' D F -- @ -- {-# LANGUAGE TemplateHaskell #-} module Graphics.Rendering.Chart.Drawing ( -- * Point Types and Drawing PointShape(..) , PointStyle(..) , drawPoint -- * Alignments and Paths , alignPath , alignFillPath , alignStrokePath , alignFillPoints , alignStrokePoints , alignFillPoint , alignStrokePoint , strokePointPath , fillPointPath -- * Transformation and Style Helpers , withRotation , withTranslation , withScale , withScaleX, withScaleY , withPointStyle , withDefaultStyle -- * Text Drawing , drawTextA , drawTextR , drawTextsR , textDrawRect , textDimension -- * Style Helpers , defaultColorSeq , solidLine , dashedLine , filledCircles , hollowCircles , filledPolygon , hollowPolygon , plusses , exes , stars , arrows , solidFillStyle -- * Backend and general Types , module Graphics.Rendering.Chart.Backend -- * Accessors , point_color , point_border_color , point_border_width , point_radius , point_shape ) where import Data.Default.Class -- lens < 4 includes Control.Lens.Zipper.moveTo which clashes -- with Graphics.Rendering.Chart.Geometry.moveTo (so you get -- -Wall notices). This would suggest a 'hiding (moveTo)' in -- the import, but it's been removed in lens-4.0 and I don't -- feel it's worth the use of conditional compilation. This does -- lead to the qualified Geometry import below. import Control.Lens import Data.Colour import Data.Colour.Names import Data.List (unfoldr) import Data.Monoid import Graphics.Rendering.Chart.Backend import Graphics.Rendering.Chart.Geometry hiding (moveTo) import qualified Graphics.Rendering.Chart.Geometry as G -- ----------------------------------------------------------------------- -- Transformation helpers -- ----------------------------------------------------------------------- -- | Apply a local rotation. The angle is given in radians. withRotation :: Double -> ChartBackend a -> ChartBackend a withRotation angle = withTransform (rotate angle 1) -- | Apply a local translation. withTranslation :: Point -> ChartBackend a -> ChartBackend a withTranslation p = withTransform (translate (pointToVec p) 1) -- | Apply a local scale. withScale :: Vector -> ChartBackend a -> ChartBackend a withScale v = withTransform (scale v 1) -- | Apply a local scale on the x-axis. withScaleX :: Double -> ChartBackend a -> ChartBackend a withScaleX x = withScale (Vector x 1) -- | Apply a local scale on the y-axis. withScaleY :: Double -> ChartBackend a -> ChartBackend a withScaleY y = withScale (Vector 1 y) -- | Changes the 'LineStyle' and 'FillStyle' to comply with -- the given 'PointStyle'. withPointStyle :: PointStyle -> ChartBackend a -> ChartBackend a withPointStyle (PointStyle cl bcl bw _ _) m = withLineStyle (def { _line_color = bcl, _line_width = bw }) $ withFillStyle (solidFillStyle cl) m withDefaultStyle :: ChartBackend a -> ChartBackend a withDefaultStyle = withLineStyle def . withFillStyle def . withFontStyle def -- ----------------------------------------------------------------------- -- Alignment Helpers -- ----------------------------------------------------------------------- -- | Align the path by applying the given function on all points. alignPath :: (Point -> Point) -> Path -> Path alignPath f = foldPath (G.moveTo . f) (lineTo . f) (arc . f) (arcNeg . f) close -- | Align the path using the environment's alignment function for points. -- This is generally useful when stroking. -- See 'alignPath' and 'getPointAlignFn'. alignStrokePath :: Path -> ChartBackend Path alignStrokePath p = do f <- getPointAlignFn return $ alignPath f p -- | Align the path using the environment's alignment function for coordinates. -- This is generally useful when filling. -- See 'alignPath' and 'getCoordAlignFn'. alignFillPath :: Path -> ChartBackend Path alignFillPath p = do f <- getCoordAlignFn return $ alignPath f p -- | The points will be aligned by the 'getPointAlignFn', so that -- when drawing bitmaps, 1 pixel wide lines will be centred on the -- pixels. alignStrokePoints :: [Point] -> ChartBackend [Point] alignStrokePoints p = do f <- getPointAlignFn return $ fmap f p -- | The points will be aligned by the 'getCoordAlignFn', so that -- when drawing bitmaps, the edges of the region will fall between -- pixels. alignFillPoints :: [Point] -> ChartBackend [Point] alignFillPoints p = do f <- getCoordAlignFn return $ fmap f p -- | Align the point using the environment's alignment function for points. -- See 'getPointAlignFn'. alignStrokePoint :: Point -> ChartBackend Point alignStrokePoint p = do alignfn <- getPointAlignFn return (alignfn p) -- | Align the point using the environment's alignment function for coordinates. -- See 'getCoordAlignFn'. alignFillPoint :: Point -> ChartBackend Point alignFillPoint p = do alignfn <- getCoordAlignFn return (alignfn p) -- | Create a path by connecting all points with a line. -- The path is not closed. stepPath :: [Point] -> Path stepPath (p:ps) = G.moveTo p <> mconcat (map lineTo ps) stepPath [] = mempty -- | Draw lines between the specified points. strokePointPath :: [Point] -> ChartBackend () strokePointPath pts = strokePath $ stepPath pts -- | Fill the region with the given corners. fillPointPath :: [Point] -> ChartBackend () fillPointPath pts = fillPath $ stepPath pts -- ----------------------------------------------------------------------- -- Text Drawing -- ----------------------------------------------------------------------- -- | Draw a line of text that is aligned at a different anchor point. -- See 'drawText'. drawTextA :: HTextAnchor -> VTextAnchor -> Point -> String -> ChartBackend () drawTextA hta vta = drawTextR hta vta 0 {- The following is useful for checking out the bounding-box calculation. At present it looks okay for PNG/Cairo but is a bit off for SVG/Diagrams; this may well be down to differences in how fonts are rendered in the two backends drawTextA hta vta p txt = drawTextR hta vta 0 p txt >> withLineStyle (solidLine 1 (opaque red)) (textDrawRect hta vta p txt >>= \rect -> alignStrokePath (rectPath rect) >>= strokePath) -} -- | Draw a textual label anchored by one of its corners -- or edges, with rotation. Rotation angle is given in degrees, -- rotation is performed around anchor point. -- See 'drawText'. drawTextR :: HTextAnchor -> VTextAnchor -> Double -> Point -> String -> ChartBackend () drawTextR hta vta angle p s = withTranslation p $ withRotation theta $ do ts <- textSize s drawText (adjustText hta vta ts) s where theta = angle*pi/180.0 -- | Draw a multi-line textual label anchored by one of its corners -- or edges, with rotation. Rotation angle is given in degrees, -- rotation is performed around anchor point. -- See 'drawText'. drawTextsR :: HTextAnchor -> VTextAnchor -> Double -> Point -> String -> ChartBackend () drawTextsR hta vta angle p s = case num of 0 -> return () 1 -> drawTextR hta vta angle p s _ -> withTranslation p $ withRotation theta $ do tss <- mapM textSize ss let ts = head tss let -- widths = map textSizeWidth tss -- maxw = maximum widths maxh = maximum (map textSizeYBearing tss) gap = maxh / 2 -- half-line spacing totalHeight = fromIntegral num*maxh + (fromIntegral num-1)*gap ys = take num (unfoldr (\y-> Just (y, y-gap-maxh)) (yinit vta ts totalHeight)) xs = map (adjustTextX hta) tss sequence_ (zipWith3 drawT xs ys ss) where ss = lines s num = length ss drawT x y = drawText (Point x y) theta = angle*pi/180.0 yinit VTA_Top ts _ = textSizeAscent ts yinit VTA_BaseLine _ _ = 0 yinit VTA_Centre ts height = height / 2 + textSizeAscent ts yinit VTA_Bottom ts height = height + textSizeAscent ts -- | Calculate the correct offset to align the text anchor. adjustText :: HTextAnchor -> VTextAnchor -> TextSize -> Point adjustText hta vta ts = Point (adjustTextX hta ts) (adjustTextY vta ts) -- | Calculate the correct offset to align the horizontal anchor. adjustTextX :: HTextAnchor -> TextSize -> Double adjustTextX HTA_Left _ = 0 adjustTextX HTA_Centre ts = - (textSizeWidth ts / 2) adjustTextX HTA_Right ts = - textSizeWidth ts -- | Calculate the correct offset to align the vertical anchor. adjustTextY :: VTextAnchor -> TextSize -> Double adjustTextY VTA_Top ts = textSizeAscent ts adjustTextY VTA_Centre ts = - textSizeYBearing ts / 2 adjustTextY VTA_BaseLine _ = 0 adjustTextY VTA_Bottom ts = - textSizeDescent ts -- | Return the bounding rectangle for a text string positioned -- where it would be drawn by 'drawText'. -- See 'textSize'. textDrawRect :: HTextAnchor -> VTextAnchor -> Point -> String -> ChartBackend Rect textDrawRect hta vta (Point x y) s = do ts <- textSize s -- This does not account for the pixel width of the label; e.g. -- with a label "bread" and a large-enough foint size (e.g. 36) -- I have seen the right-hand edge of the bounding box go through -- the vertical part of the 'd' character (see chart-tests/tests/Test8.hs -- and bump up the label size). let (w,h,dh) = (textSizeWidth ts, textSizeHeight ts, textSizeDescent ts) lx = adjustTextX hta ts ly = adjustTextY vta ts (x',y') = (x + lx, y + ly + dh) p1 = Point x' (y' - h) p2 = Point (x' + w) y' return $ Rect p1 p2 -- | Get the width and height of the string when rendered. -- See 'textSize'. textDimension :: String -> ChartBackend RectSize textDimension s = do ts <- textSize s return (textSizeWidth ts, textSizeHeight ts) -- ----------------------------------------------------------------------- -- Point Types and Drawing -- ----------------------------------------------------------------------- -- | The different shapes a point can have. data PointShape = PointShapeCircle -- ^ A circle. | PointShapePolygon Int Bool -- ^ Number of vertices and is right-side-up? | PointShapePlus -- ^ A plus sign. | PointShapeCross -- ^ A cross. | PointShapeStar -- ^ Combination of a cross and a plus. | PointShapeArrowHead Double -- | Abstract data type for the style of a plotted point. data PointStyle = PointStyle { _point_color :: AlphaColour Double -- ^ The color to fill the point with. , _point_border_color :: AlphaColour Double -- ^ The color to stroke the outline with. , _point_border_width :: Double -- ^ The width of the outline. , _point_radius :: Double -- ^ The radius of the tightest surrounding circle of the point. , _point_shape :: PointShape -- ^ The shape. } -- | Default style to use for points. instance Default PointStyle where def = PointStyle { _point_color = opaque black , _point_border_color = transparent , _point_border_width = 0 , _point_radius = 1 , _point_shape = PointShapeCircle } -- | Draw a single point at the given location. drawPoint :: PointStyle -- ^ Style to use when rendering the point. -> Point -- ^ Position of the point to render. -> ChartBackend () drawPoint ps@(PointStyle cl _ _ r shape) p = withPointStyle ps $ do p'@(Point x y) <- alignStrokePoint p case shape of PointShapeCircle -> do let path = arc p' r 0 (2*pi) fillPath path strokePath path PointShapePolygon sides isrot -> do let intToAngle n = if isrot then fromIntegral n * 2*pi/fromIntegral sides else (0.5 + fromIntegral n)*2*pi/fromIntegral sides angles = map intToAngle [0 .. sides-1] (p1:p1s) = map (\a -> Point (x + r * sin a) (y + r * cos a)) angles let path = G.moveTo p1 <> mconcat (map lineTo p1s) <> lineTo p1 fillPath path strokePath path PointShapeArrowHead theta -> withTranslation p $ withRotation (theta - pi/2) $ drawPoint (filledPolygon r 3 True cl) (Point 0 0) PointShapePlus -> strokePath $ moveTo' (x+r) y <> lineTo' (x-r) y <> moveTo' x (y-r) <> lineTo' x (y+r) PointShapeCross -> do let rad = r / sqrt 2 strokePath $ moveTo' (x+rad) (y+rad) <> lineTo' (x-rad) (y-rad) <> moveTo' (x+rad) (y-rad) <> lineTo' (x-rad) (y+rad) PointShapeStar -> do let rad = r / sqrt 2 strokePath $ moveTo' (x+r) y <> lineTo' (x-r) y <> moveTo' x (y-r) <> lineTo' x (y+r) <> moveTo' (x+rad) (y+rad) <> lineTo' (x-rad) (y-rad) <> moveTo' (x+rad) (y-rad) <> lineTo' (x-rad) (y+rad) -- ----------------------------------------------------------------------- -- Style Helpers -- ----------------------------------------------------------------------- -- | The default sequence of colours to use when plotings different data sets -- in a graph. defaultColorSeq :: [AlphaColour Double] defaultColorSeq = cycle $ map opaque [blue, red, green, yellow, cyan, magenta] -- | Create a solid line style (not dashed). solidLine :: Double -- ^ Width of line. -> AlphaColour Double -- ^ Colour of line. -> LineStyle solidLine w cl = LineStyle w cl [] LineCapButt LineJoinMiter -- | Create a dashed line style. dashedLine :: Double -- ^ Width of line. -> [Double] -- ^ The dash pattern in device coordinates. -> AlphaColour Double -- ^ Colour of line. -> LineStyle dashedLine w ds cl = LineStyle w cl ds LineCapButt LineJoinMiter -- | Style for filled circle points. filledCircles :: Double -- ^ Radius of circle. -> AlphaColour Double -- ^ Fill colour. -> PointStyle filledCircles radius cl = PointStyle cl transparent 0 radius PointShapeCircle -- | Style for stroked circle points. hollowCircles :: Double -- ^ Radius of circle. -> Double -- ^ Thickness of line. -> AlphaColour Double -- Colour of line. -> PointStyle hollowCircles radius w cl = PointStyle transparent cl w radius PointShapeCircle -- | Style for stroked polygon points. hollowPolygon :: Double -- ^ Radius of circle. -> Double -- ^ Thickness of line. -> Int -- ^ Number of vertices. -> Bool -- ^ Is right-side-up? -> AlphaColour Double -- ^ Colour of line. -> PointStyle hollowPolygon radius w sides isrot cl = PointStyle transparent cl w radius (PointShapePolygon sides isrot) -- | Style for filled polygon points. filledPolygon :: Double -- ^ Radius of circle. -> Int -- ^ Number of vertices. -> Bool -- ^ Is right-side-up? -> AlphaColour Double -- ^ Fill color. -> PointStyle filledPolygon radius sides isrot cl = PointStyle cl transparent 0 radius (PointShapePolygon sides isrot) -- | Plus sign point style. plusses :: Double -- ^ Radius of tightest surrounding circle. -> Double -- ^ Thickness of line. -> AlphaColour Double -- ^ Color of line. -> PointStyle plusses radius w cl = PointStyle transparent cl w radius PointShapePlus -- | Cross point style. exes :: Double -- ^ Radius of circle. -> Double -- ^ Thickness of line. -> AlphaColour Double -- ^ Color of line. -> PointStyle exes radius w cl = PointStyle transparent cl w radius PointShapeCross -- | Combination of plus and cross point style. stars :: Double -- ^ Radius of circle. -> Double -- ^ Thickness of line. -> AlphaColour Double -- ^ Color of line. -> PointStyle stars radius w cl = PointStyle transparent cl w radius PointShapeStar arrows :: Double -- ^ Radius of circle. -> Double -- ^ Rotation (Tau) -> Double -- ^ Thickness of line. -> AlphaColour Double -- ^ Color of line. -> PointStyle arrows radius angle w cl = PointStyle transparent cl w radius (PointShapeArrowHead angle) -- | Fill style that fill everything this the given colour. solidFillStyle :: AlphaColour Double -> FillStyle solidFillStyle = FillStyleSolid $( makeLenses ''PointStyle )