diff --git a/Chart.cabal b/Chart.cabal --- a/Chart.cabal +++ b/Chart.cabal @@ -1,5 +1,5 @@ Name: Chart -Version: 1.8.3 +Version: 1.9 License: BSD3 License-file: LICENSE Copyright: Tim Docker, 2006-2014 @@ -27,6 +27,9 @@ , mtl >= 2.0 && < 2.3 , operational >= 0.2.2 && < 0.3 , vector >=0.9 && <0.13 + + if !impl(ghc >= 8.0) + build-depends: semigroups >= 0.18.4 && <0.19 Ghc-options: -Wall -fno-warn-orphans diff --git a/Graphics/Rendering/Chart/Geometry.hs b/Graphics/Rendering/Chart/Geometry.hs --- a/Graphics/Rendering/Chart/Geometry.hs +++ b/Graphics/Rendering/Chart/Geometry.hs @@ -53,7 +53,8 @@ import qualified Prelude import Prelude hiding ((^)) -import Data.Monoid +import Data.Monoid (Monoid (..)) +import Data.Semigroup (Semigroup(..)) -- The homomorphic version to avoid casts inside the code. (^) :: Num a => a -> Integer -> a @@ -196,14 +197,17 @@ -- | Paths are monoids. After a path is closed you can not append -- anything to it anymore. The empty path is open. -- Use 'close' to close a path. -instance Monoid Path where - mappend p1 p2 = case p1 of - MoveTo p path -> MoveTo p $ mappend path p2 - LineTo p path -> LineTo p $ mappend path p2 - Arc p r a1 a2 path -> Arc p r a1 a2 $ mappend path p2 - ArcNeg p r a1 a2 path -> ArcNeg p r a1 a2 $ mappend path p2 +instance Semigroup Path where + p1 <> p2 = case p1 of + MoveTo p path -> MoveTo p $ path <> p2 + LineTo p path -> LineTo p $ path <> p2 + Arc p r a1 a2 path -> Arc p r a1 a2 $ path <> p2 + ArcNeg p r a1 a2 path -> ArcNeg p r a1 a2 $ path <> p2 End -> p2 Close -> Close + +instance Monoid Path where + mappend = (<>) mempty = End -- | Move the paths pointer to the given location. @@ -265,10 +269,10 @@ foldPath moveTo_ lineTo_ arc_ arcNeg_ close_ path = let restF = foldPath moveTo_ lineTo_ arc_ arcNeg_ close_ in case path of - MoveTo p rest -> moveTo_ p <> restF rest - LineTo p rest -> lineTo_ p <> restF rest - Arc p r a1 a2 rest -> arc_ p r a1 a2 <> restF rest - ArcNeg p r a1 a2 rest -> arcNeg_ p r a1 a2 <> restF rest + MoveTo p rest -> moveTo_ p `mappend` restF rest + LineTo p rest -> lineTo_ p `mappend` restF rest + Arc p r a1 a2 rest -> arc_ p r a1 a2 `mappend` restF rest + ArcNeg p r a1 a2 rest -> arcNeg_ p r a1 a2 `mappend` restF rest End -> mempty Close -> close_ diff --git a/Graphics/Rendering/Chart/Plot/Annotation.hs b/Graphics/Rendering/Chart/Plot/Annotation.hs --- a/Graphics/Rendering/Chart/Plot/Annotation.hs +++ b/Graphics/Rendering/Chart/Plot/Annotation.hs @@ -15,12 +15,14 @@ plot_annotation_vanchor, plot_annotation_angle, plot_annotation_style, + plot_annotation_background, plot_annotation_values ) where import Control.Lens import Graphics.Rendering.Chart.Geometry import Graphics.Rendering.Chart.Drawing +import Graphics.Rendering.Chart.Renderable import Graphics.Rendering.Chart.Plot.Types import Data.Default.Class @@ -34,6 +36,10 @@ _plot_annotation_angle :: Double, -- ^ Angle, in degrees, to rotate the annotation about the anchor point. _plot_annotation_style :: FontStyle, + _plot_annotation_background :: Rectangle, + -- ^ Rectangle which style determines the background of the annotation + -- text and which '_rect_minsize' determines the additional width and + -- height of the background area _plot_annotation_values :: [(x,y,String)] } @@ -49,15 +55,31 @@ renderAnnotation :: PlotAnnotation x y -> PointMapFn x y -> BackendProgram () -renderAnnotation p pMap = withFontStyle style $ +renderAnnotation p pMap = withFontStyle style $ do + mapM_ drawRect values mapM_ drawOne values where hta = _plot_annotation_hanchor p vta = _plot_annotation_vanchor p values = _plot_annotation_values p angle = _plot_annotation_angle p style = _plot_annotation_style p - drawOne (x,y,s) = drawTextsR hta vta angle point s - where point = pMap (LValue x, LValue y) + rectangle = _plot_annotation_background p + (x1,y1) = _rect_minsize rectangle + drawRect (x,y,s) = do + ts <- textSize s + let (x2,y2) = (textSizeWidth ts, textSizeHeight ts) + Point x3 y3 = point x y + -- position of top-left vertex of the rectangle + xvp HTA_Left = x3 - x1 / 2 + xvp HTA_Centre = x3 - (x1 + x2) / 2 + xvp HTA_Right = x3 - x2 - x1 / 2 + yvp VTA_Top = y3 - y1 / 2 + yvp VTA_Centre = y3 - (y1 + y2) / 2 + yvp VTA_Bottom = y3 - y2 - y1 / 2 + yvp VTA_BaseLine = y3 - y1 / 2 - textSizeAscent ts + drawRectangle (Point (xvp hta) (yvp vta)) rectangle{ _rect_minsize = (x1+x2,y1+y2) } + drawOne (x,y,s) = drawTextsR hta vta angle (point x y) s + point x y = pMap (LValue x, LValue y) instance Default (PlotAnnotation x y) where def = PlotAnnotation @@ -65,6 +87,7 @@ , _plot_annotation_vanchor = VTA_Centre , _plot_annotation_angle = 0 , _plot_annotation_style = def + , _plot_annotation_background = def , _plot_annotation_values = [] } diff --git a/Graphics/Rendering/Chart/Renderable.hs b/Graphics/Rendering/Chart/Renderable.hs --- a/Graphics/Rendering/Chart/Renderable.hs +++ b/Graphics/Rendering/Chart/Renderable.hs @@ -19,6 +19,7 @@ RectCornerStyle(..), rectangleToRenderable, + drawRectangle, fillBackground, addMargins, @@ -218,47 +219,54 @@ rectangleToRenderable :: Rectangle -> Renderable a rectangleToRenderable rectangle = Renderable mf rf where - mf = return (_rect_minsize rectangle) - rf sz = do - maybeM () (fill sz) (_rect_fillStyle rectangle) - maybeM () (stroke sz) (_rect_lineStyle rectangle) - return nullPickFn - - fill sz fs = - withFillStyle fs $ - fillPath $ strokeRectangleP sz (_rect_cornerStyle rectangle) - - stroke sz ls = - withLineStyle ls $ - strokePath $ strokeRectangleP sz (_rect_cornerStyle rectangle) - - strokeRectangleP (x2,y2) RCornerSquare = - let (x1,y1) = (0,0) in moveTo' x1 y1 - <> lineTo' x1 y2 - <> lineTo' x2 y2 - <> lineTo' x2 y1 - <> lineTo' x1 y1 - <> lineTo' x1 y2 - - strokeRectangleP (x2,y2) (RCornerBevel s) = - let (x1,y1) = (0,0) in moveTo' x1 (y1+s) - <> lineTo' x1 (y2-s) - <> lineTo' (x1+s) y2 - <> lineTo' (x2-s) y2 - <> lineTo' x2 (y2-s) - <> lineTo' x2 (y1+s) - <> lineTo' (x2-s) y1 - <> lineTo' (x1+s) y1 - <> lineTo' x1 (y1+s) - <> lineTo' x1 (y2-s) + mf = return (_rect_minsize rectangle) + rf = \rectSize -> drawRectangle (Point 0 0) + rectangle{ _rect_minsize = rectSize } - strokeRectangleP (x2,y2) (RCornerRounded s) = - let (x1,y1) = (0,0) in arcNeg (Point (x1+s) (y2-s)) s (pi2*2) pi2 - <> arcNeg (Point (x2-s) (y2-s)) s pi2 0 - <> arcNeg (Point (x2-s) (y1+s)) s 0 (pi2*3) - <> arcNeg (Point (x1+s) (y1+s)) s (pi2*3) (pi2*2) - <> lineTo' x1 (y2-s) - - pi2 = pi / 2 +-- | Draw the specified rectangle such that its top-left vertex is placed at +-- the given position +drawRectangle :: Point -> Rectangle -> BackendProgram (PickFn a) +drawRectangle point rectangle = do + maybeM () (fill point size) (_rect_fillStyle rectangle) + maybeM () (stroke point size) (_rect_lineStyle rectangle) + return nullPickFn + where + size = _rect_minsize rectangle + + fill p sz fs = + withFillStyle fs $ + fillPath $ strokeRectangleP p sz (_rect_cornerStyle rectangle) + + stroke p sz ls = + withLineStyle ls $ + strokePath $ strokeRectangleP p sz (_rect_cornerStyle rectangle) + + strokeRectangleP (Point x1 y1) (x2,y2) RCornerSquare = + let (x3,y3) = (x1+x2,y1+y2) in moveTo' x1 y1 + <> lineTo' x1 y3 + <> lineTo' x3 y3 + <> lineTo' x3 y1 + <> lineTo' x1 y1 + + strokeRectangleP (Point x1 y1) (x2,y2) (RCornerBevel s) = + let (x3,y3) = (x1+x2,y1+y2) in moveTo' x1 (y1+s) + <> lineTo' x1 (y3-s) + <> lineTo' (x1+s) y3 + <> lineTo' (x3-s) y3 + <> lineTo' x3 (y3-s) + <> lineTo' x3 (y1+s) + <> lineTo' (x3-s) y1 + <> lineTo' (x1+s) y1 + <> lineTo' x1 (y1+s) + + strokeRectangleP (Point x1 y1) (x2,y2) (RCornerRounded s) = + let (x3,y3) = (x1+x2,y1+y2) in + arcNeg (Point (x1+s) (y3-s)) s (pi2*2) pi2 + <> arcNeg (Point (x3-s) (y3-s)) s pi2 0 + <> arcNeg (Point (x3-s) (y1+s)) s 0 (pi2*3) + <> arcNeg (Point (x1+s) (y1+s)) s (pi2*3) (pi2*2) + <> lineTo' x1 (y3-s) + + pi2 = pi / 2 $( makeLenses ''Rectangle )