-----------------------------------------------------------------------------
-- |
-- 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 -> BackendProgram a -> BackendProgram a
withRotation :: Double -> BackendProgram a -> BackendProgram a
withRotation Double
angle = Matrix -> BackendProgram a -> BackendProgram a
forall a. Matrix -> BackendProgram a -> BackendProgram a
withTransform (Double -> Matrix -> Matrix
rotate Double
angle Matrix
1)

-- | Apply a local translation.
withTranslation :: Point -> BackendProgram a -> BackendProgram a
withTranslation :: Point -> BackendProgram a -> BackendProgram a
withTranslation Point
p = Matrix -> BackendProgram a -> BackendProgram a
forall a. Matrix -> BackendProgram a -> BackendProgram a
withTransform (Vector -> Matrix -> Matrix
translate (Point -> Vector
pointToVec Point
p) Matrix
1)

-- | Apply a local scale.
withScale :: Vector -> BackendProgram a -> BackendProgram a
withScale :: Vector -> BackendProgram a -> BackendProgram a
withScale Vector
v = Matrix -> BackendProgram a -> BackendProgram a
forall a. Matrix -> BackendProgram a -> BackendProgram a
withTransform (Vector -> Matrix -> Matrix
scale Vector
v Matrix
1)

-- | Apply a local scale on the x-axis.
withScaleX :: Double -> BackendProgram a -> BackendProgram a
withScaleX :: Double -> BackendProgram a -> BackendProgram a
withScaleX Double
x = Vector -> BackendProgram a -> BackendProgram a
forall a. Vector -> BackendProgram a -> BackendProgram a
withScale (Double -> Double -> Vector
Vector Double
x Double
1)

-- | Apply a local scale on the y-axis.
withScaleY :: Double -> BackendProgram a -> BackendProgram a
withScaleY :: Double -> BackendProgram a -> BackendProgram a
withScaleY Double
y = Vector -> BackendProgram a -> BackendProgram a
forall a. Vector -> BackendProgram a -> BackendProgram a
withScale (Double -> Double -> Vector
Vector Double
1 Double
y)

-- | Changes the 'LineStyle' and 'FillStyle' to comply with
--   the given 'PointStyle'.
withPointStyle :: PointStyle -> BackendProgram a -> BackendProgram a
withPointStyle :: PointStyle -> BackendProgram a -> BackendProgram a
withPointStyle (PointStyle AlphaColour Double
cl AlphaColour Double
bcl Double
bw Double
_ PointShape
_) BackendProgram a
m = 
  LineStyle -> BackendProgram a -> BackendProgram a
forall a. LineStyle -> BackendProgram a -> BackendProgram a
withLineStyle (LineStyle
forall a. Default a => a
def { _line_color :: AlphaColour Double
_line_color = AlphaColour Double
bcl, _line_width :: Double
_line_width = Double
bw, _line_join :: LineJoin
_line_join = LineJoin
LineJoinMiter }) (BackendProgram a -> BackendProgram a)
-> BackendProgram a -> BackendProgram a
forall a b. (a -> b) -> a -> b
$ 
    FillStyle -> BackendProgram a -> BackendProgram a
forall a. FillStyle -> BackendProgram a -> BackendProgram a
withFillStyle (AlphaColour Double -> FillStyle
solidFillStyle AlphaColour Double
cl) BackendProgram a
m

withDefaultStyle :: BackendProgram a -> BackendProgram a
withDefaultStyle :: BackendProgram a -> BackendProgram a
withDefaultStyle = LineStyle -> BackendProgram a -> BackendProgram a
forall a. LineStyle -> BackendProgram a -> BackendProgram a
withLineStyle LineStyle
forall a. Default a => a
def (BackendProgram a -> BackendProgram a)
-> (BackendProgram a -> BackendProgram a)
-> BackendProgram a
-> BackendProgram a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FillStyle -> BackendProgram a -> BackendProgram a
forall a. FillStyle -> BackendProgram a -> BackendProgram a
withFillStyle FillStyle
forall a. Default a => a
def (BackendProgram a -> BackendProgram a)
-> (BackendProgram a -> BackendProgram a)
-> BackendProgram a
-> BackendProgram a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FontStyle -> BackendProgram a -> BackendProgram a
forall a. FontStyle -> BackendProgram a -> BackendProgram a
withFontStyle FontStyle
forall a. Default a => a
def

-- -----------------------------------------------------------------------
-- Alignment Helpers
-- -----------------------------------------------------------------------

-- | Align the path by applying the given function on all points.
alignPath :: (Point -> Point) -> Path -> Path
alignPath :: (Point -> Point) -> Path -> Path
alignPath Point -> Point
f = (Point -> Path)
-> (Point -> Path)
-> (Point -> Double -> Double -> Double -> Path)
-> (Point -> Double -> Double -> Double -> Path)
-> Path
-> Path
-> Path
forall m.
Monoid m =>
(Point -> m)
-> (Point -> m)
-> (Point -> Double -> Double -> Double -> m)
-> (Point -> Double -> Double -> Double -> m)
-> m
-> Path
-> m
foldPath (Point -> Path
G.moveTo (Point -> Path) -> (Point -> Point) -> Point -> Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point -> Point
f)
                       (Point -> Path
lineTo (Point -> Path) -> (Point -> Point) -> Point -> Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point -> Point
f)
                       (Point -> Double -> Double -> Double -> Path
arc (Point -> Double -> Double -> Double -> Path)
-> (Point -> Point) -> Point -> Double -> Double -> Double -> Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point -> Point
f)
                       (Point -> Double -> Double -> Double -> Path
arcNeg (Point -> Double -> Double -> Double -> Path)
-> (Point -> Point) -> Point -> Double -> Double -> Double -> Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point -> Point
f)
                       Path
close

-- | Align the path using the environment's alignment function for points.
--   This is generally useful when stroking. 
--   See 'alignPath' and 'getPointAlignFn'.
alignStrokePath :: Path -> BackendProgram Path
alignStrokePath :: Path -> BackendProgram Path
alignStrokePath Path
p = do
  Point -> Point
f <- BackendProgram (Point -> Point)
getPointAlignFn
  Path -> BackendProgram Path
forall (m :: * -> *) a. Monad m => a -> m a
return (Path -> BackendProgram Path) -> Path -> BackendProgram Path
forall a b. (a -> b) -> a -> b
$ (Point -> Point) -> Path -> Path
alignPath Point -> Point
f Path
p

-- | Align the path using the environment's alignment function for coordinates.
--   This is generally useful when filling. 
--   See 'alignPath' and 'getCoordAlignFn'.
alignFillPath :: Path -> BackendProgram Path
alignFillPath :: Path -> BackendProgram Path
alignFillPath Path
p = do
  Point -> Point
f <- BackendProgram (Point -> Point)
getCoordAlignFn
  Path -> BackendProgram Path
forall (m :: * -> *) a. Monad m => a -> m a
return (Path -> BackendProgram Path) -> Path -> BackendProgram Path
forall a b. (a -> b) -> a -> b
$ (Point -> Point) -> Path -> Path
alignPath Point -> Point
f Path
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] -> BackendProgram [Point]
alignStrokePoints :: [Point] -> BackendProgram [Point]
alignStrokePoints [Point]
p = do
  Point -> Point
f <- BackendProgram (Point -> Point)
getPointAlignFn
  [Point] -> BackendProgram [Point]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Point] -> BackendProgram [Point])
-> [Point] -> BackendProgram [Point]
forall a b. (a -> b) -> a -> b
$ (Point -> Point) -> [Point] -> [Point]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Point -> Point
f [Point]
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] -> BackendProgram [Point]
alignFillPoints :: [Point] -> BackendProgram [Point]
alignFillPoints [Point]
p = do
  Point -> Point
f <- BackendProgram (Point -> Point)
getCoordAlignFn
  [Point] -> BackendProgram [Point]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Point] -> BackendProgram [Point])
-> [Point] -> BackendProgram [Point]
forall a b. (a -> b) -> a -> b
$ (Point -> Point) -> [Point] -> [Point]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Point -> Point
f [Point]
p

-- | Align the point using the environment's alignment function for points.
--   See 'getPointAlignFn'.
alignStrokePoint :: Point -> BackendProgram Point
alignStrokePoint :: Point -> BackendProgram Point
alignStrokePoint Point
p = do 
    Point -> Point
alignfn <- BackendProgram (Point -> Point)
getPointAlignFn
    Point -> BackendProgram Point
forall (m :: * -> *) a. Monad m => a -> m a
return (Point -> Point
alignfn Point
p)

-- | Align the point using the environment's alignment function for coordinates.
--   See 'getCoordAlignFn'.
alignFillPoint :: Point -> BackendProgram Point
alignFillPoint :: Point -> BackendProgram Point
alignFillPoint Point
p = do 
    Point -> Point
alignfn <- BackendProgram (Point -> Point)
getCoordAlignFn
    Point -> BackendProgram Point
forall (m :: * -> *) a. Monad m => a -> m a
return (Point -> Point
alignfn Point
p)

-- | Create a path by connecting all points with a line.
--   The path is not closed.
stepPath :: [Point] -> Path
stepPath :: [Point] -> Path
stepPath (Point
p:[Point]
ps) = Point -> Path
G.moveTo Point
p
               Path -> Path -> Path
forall a. Semigroup a => a -> a -> a
<> [Path] -> Path
forall a. Monoid a => [a] -> a
mconcat ((Point -> Path) -> [Point] -> [Path]
forall a b. (a -> b) -> [a] -> [b]
map Point -> Path
lineTo [Point]
ps)
stepPath [] = Path
forall a. Monoid a => a
mempty

-- | Draw lines between the specified points.
strokePointPath :: [Point] -> BackendProgram ()
strokePointPath :: [Point] -> BackendProgram ()
strokePointPath [Point]
pts = Path -> BackendProgram ()
strokePath (Path -> BackendProgram ()) -> Path -> BackendProgram ()
forall a b. (a -> b) -> a -> b
$ [Point] -> Path
stepPath [Point]
pts

-- | Fill the region with the given corners.
fillPointPath :: [Point] -> BackendProgram ()
fillPointPath :: [Point] -> BackendProgram ()
fillPointPath [Point]
pts = Path -> BackendProgram ()
fillPath (Path -> BackendProgram ()) -> Path -> BackendProgram ()
forall a b. (a -> b) -> a -> b
$ [Point] -> Path
stepPath [Point]
pts

-- -----------------------------------------------------------------------
-- Text Drawing
-- -----------------------------------------------------------------------

-- | Draw a line of text that is aligned at a different anchor point.
--   See 'drawText'.
drawTextA :: HTextAnchor -> VTextAnchor -> Point -> String -> BackendProgram ()
drawTextA :: HTextAnchor -> VTextAnchor -> Point -> String -> BackendProgram ()
drawTextA HTextAnchor
hta VTextAnchor
vta = HTextAnchor
-> VTextAnchor -> Double -> Point -> String -> BackendProgram ()
drawTextR HTextAnchor
hta VTextAnchor
vta Double
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 -> BackendProgram ()
drawTextR :: HTextAnchor
-> VTextAnchor -> Double -> Point -> String -> BackendProgram ()
drawTextR HTextAnchor
hta VTextAnchor
vta Double
angle Point
p String
s =
  Point -> BackendProgram () -> BackendProgram ()
forall a. Point -> BackendProgram a -> BackendProgram a
withTranslation Point
p (BackendProgram () -> BackendProgram ())
-> BackendProgram () -> BackendProgram ()
forall a b. (a -> b) -> a -> b
$
    Double -> BackendProgram () -> BackendProgram ()
forall a. Double -> BackendProgram a -> BackendProgram a
withRotation Double
theta (BackendProgram () -> BackendProgram ())
-> BackendProgram () -> BackendProgram ()
forall a b. (a -> b) -> a -> b
$ do
      TextSize
ts <- String -> BackendProgram TextSize
textSize String
s
      Point -> String -> BackendProgram ()
drawText (HTextAnchor -> VTextAnchor -> TextSize -> Point
adjustText HTextAnchor
hta VTextAnchor
vta TextSize
ts) String
s
  where
    theta :: Double
theta = Double
angleDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
forall a. Floating a => a
piDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
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 -> BackendProgram ()
drawTextsR :: HTextAnchor
-> VTextAnchor -> Double -> Point -> String -> BackendProgram ()
drawTextsR HTextAnchor
hta VTextAnchor
vta Double
angle Point
p String
s = case Int
num of
      Int
0 -> () -> BackendProgram ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Int
1 -> HTextAnchor
-> VTextAnchor -> Double -> Point -> String -> BackendProgram ()
drawTextR HTextAnchor
hta VTextAnchor
vta Double
angle Point
p String
s
      Int
_ -> 
        Point -> BackendProgram () -> BackendProgram ()
forall a. Point -> BackendProgram a -> BackendProgram a
withTranslation Point
p (BackendProgram () -> BackendProgram ())
-> BackendProgram () -> BackendProgram ()
forall a b. (a -> b) -> a -> b
$
          Double -> BackendProgram () -> BackendProgram ()
forall a. Double -> BackendProgram a -> BackendProgram a
withRotation Double
theta (BackendProgram () -> BackendProgram ())
-> BackendProgram () -> BackendProgram ()
forall a b. (a -> b) -> a -> b
$ do
            [TextSize]
tss <- (String -> BackendProgram TextSize)
-> [String] -> ProgramT ChartBackendInstr Identity [TextSize]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> BackendProgram TextSize
textSize [String]
ss
            let ts :: TextSize
ts = [TextSize] -> TextSize
forall a. [a] -> a
head [TextSize]
tss
            let -- widths = map textSizeWidth tss
                -- maxw   = maximum widths
                maxh :: Double
maxh   = [Double] -> Double
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ((TextSize -> Double) -> [TextSize] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map TextSize -> Double
textSizeYBearing [TextSize]
tss)
                gap :: Double
gap    = Double
maxh Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2 -- half-line spacing
                totalHeight :: Double
totalHeight = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
numDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
maxh Double -> Double -> Double
forall a. Num a => a -> a -> a
+
                              (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
numDouble -> Double -> Double
forall a. Num a => a -> a -> a
-Double
1)Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
gap
                ys :: [Double]
ys = Int -> [Double] -> [Double]
forall a. Int -> [a] -> [a]
take Int
num ((Double -> Maybe (Double, Double)) -> Double -> [Double]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr (\Double
y-> (Double, Double) -> Maybe (Double, Double)
forall a. a -> Maybe a
Just (Double
y, Double
yDouble -> Double -> Double
forall a. Num a => a -> a -> a
-Double
gapDouble -> Double -> Double
forall a. Num a => a -> a -> a
-Double
maxh))
                                       (VTextAnchor -> TextSize -> Double -> Double
yinit VTextAnchor
vta TextSize
ts Double
totalHeight))
                xs :: [Double]
xs = (TextSize -> Double) -> [TextSize] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map (HTextAnchor -> TextSize -> Double
adjustTextX HTextAnchor
hta) [TextSize]
tss
            [BackendProgram ()] -> BackendProgram ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ((Double -> Double -> String -> BackendProgram ())
-> [Double] -> [Double] -> [String] -> [BackendProgram ()]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Double -> Double -> String -> BackendProgram ()
drawT [Double]
xs [Double]
ys [String]
ss)
    where
      ss :: [String]
ss   = String -> [String]
lines String
s
      num :: Int
num  = [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
ss

      drawT :: Double -> Double -> String -> BackendProgram ()
drawT Double
x Double
y = Point -> String -> BackendProgram ()
drawText (Double -> Double -> Point
Point Double
x Double
y)
      theta :: Double
theta = Double
angleDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
forall a. Floating a => a
piDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
180.0

      yinit :: VTextAnchor -> TextSize -> Double -> Double
yinit VTextAnchor
VTA_Top      TextSize
ts Double
_      = TextSize -> Double
textSizeAscent TextSize
ts
      yinit VTextAnchor
VTA_BaseLine TextSize
_  Double
_      = Double
0
      yinit VTextAnchor
VTA_Centre   TextSize
ts Double
height = Double
height Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ TextSize -> Double
textSizeAscent TextSize
ts
      yinit VTextAnchor
VTA_Bottom   TextSize
ts Double
height = Double
height Double -> Double -> Double
forall a. Num a => a -> a -> a
+ TextSize -> Double
textSizeAscent TextSize
ts

-- | Calculate the correct offset to align the text anchor.
adjustText :: HTextAnchor -> VTextAnchor -> TextSize -> Point
adjustText :: HTextAnchor -> VTextAnchor -> TextSize -> Point
adjustText HTextAnchor
hta VTextAnchor
vta TextSize
ts = Double -> Double -> Point
Point (HTextAnchor -> TextSize -> Double
adjustTextX HTextAnchor
hta TextSize
ts) (VTextAnchor -> TextSize -> Double
adjustTextY VTextAnchor
vta TextSize
ts)

-- | Calculate the correct offset to align the horizontal anchor.
adjustTextX :: HTextAnchor -> TextSize -> Double
adjustTextX :: HTextAnchor -> TextSize -> Double
adjustTextX HTextAnchor
HTA_Left   TextSize
_  = Double
0
adjustTextX HTextAnchor
HTA_Centre TextSize
ts = - (TextSize -> Double
textSizeWidth TextSize
ts Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2)
adjustTextX HTextAnchor
HTA_Right  TextSize
ts = - TextSize -> Double
textSizeWidth TextSize
ts

-- | Calculate the correct offset to align the vertical anchor.
adjustTextY :: VTextAnchor -> TextSize -> Double
adjustTextY :: VTextAnchor -> TextSize -> Double
adjustTextY VTextAnchor
VTA_Top      TextSize
ts = TextSize -> Double
textSizeAscent TextSize
ts
adjustTextY VTextAnchor
VTA_Centre   TextSize
ts = - TextSize -> Double
textSizeYBearing TextSize
ts Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2
adjustTextY VTextAnchor
VTA_BaseLine TextSize
_  = Double
0
adjustTextY VTextAnchor
VTA_Bottom   TextSize
ts = - TextSize -> Double
textSizeDescent TextSize
ts

-- | Return the bounding rectangle for a text string positioned
--   where it would be drawn by 'drawText'.
--   See 'textSize'.
textDrawRect :: HTextAnchor -> VTextAnchor -> Point -> String -> BackendProgram Rect
textDrawRect :: HTextAnchor
-> VTextAnchor -> Point -> String -> BackendProgram Rect
textDrawRect HTextAnchor
hta VTextAnchor
vta (Point Double
x Double
y) String
s = do
  TextSize
ts <- String -> BackendProgram TextSize
textSize String
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 (Double
w,Double
h,Double
dh) = (TextSize -> Double
textSizeWidth TextSize
ts, TextSize -> Double
textSizeHeight TextSize
ts, TextSize -> Double
textSizeDescent TextSize
ts)
      lx :: Double
lx = HTextAnchor -> TextSize -> Double
adjustTextX HTextAnchor
hta TextSize
ts
      ly :: Double
ly = VTextAnchor -> TextSize -> Double
adjustTextY VTextAnchor
vta TextSize
ts
      (Double
x',Double
y') = (Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
lx, Double
y Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
ly Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
dh)
      p1 :: Point
p1 = Double -> Double -> Point
Point Double
x' (Double
y' Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
h)
      p2 :: Point
p2 = Double -> Double -> Point
Point (Double
x' Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
w) Double
y'
  Rect -> BackendProgram Rect
forall (m :: * -> *) a. Monad m => a -> m a
return (Rect -> BackendProgram Rect) -> Rect -> BackendProgram Rect
forall a b. (a -> b) -> a -> b
$ Point -> Point -> Rect
Rect Point
p1 Point
p2

-- | Get the width and height of the string when rendered.
--   See 'textSize'.
textDimension :: String -> BackendProgram RectSize
textDimension :: String -> BackendProgram (Double, Double)
textDimension String
s = do
  TextSize
ts <- String -> BackendProgram TextSize
textSize String
s
  (Double, Double) -> BackendProgram (Double, Double)
forall (m :: * -> *) a. Monad m => a -> m a
return (TextSize -> Double
textSizeWidth TextSize
ts, TextSize -> Double
textSizeHeight TextSize
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
                | PointShapeEllipse Double Double -- ^ Ratio of minor to major axis and rotation

-- | Abstract data type for the style of a plotted point.
data PointStyle = PointStyle
  { PointStyle -> AlphaColour Double
_point_color :: AlphaColour Double
  -- ^ The color to fill the point with.
  , PointStyle -> AlphaColour Double
_point_border_color :: AlphaColour Double
  -- ^ The color to stroke the outline with.
  , PointStyle -> Double
_point_border_width :: Double
  -- ^ The width of the outline.
  , PointStyle -> Double
_point_radius :: Double
  -- ^ The radius of the tightest surrounding circle of the point.
  , PointStyle -> PointShape
_point_shape :: PointShape
  -- ^ The shape.
  }

-- | Default style to use for points.
instance Default PointStyle where
  def :: PointStyle
def = PointStyle :: AlphaColour Double
-> AlphaColour Double
-> Double
-> Double
-> PointShape
-> PointStyle
PointStyle 
    { _point_color :: AlphaColour Double
_point_color        = Colour Double -> AlphaColour Double
forall a. Num a => Colour a -> AlphaColour a
opaque Colour Double
forall a. Num a => Colour a
black
    , _point_border_color :: AlphaColour Double
_point_border_color = AlphaColour Double
forall a. Num a => AlphaColour a
transparent
    , _point_border_width :: Double
_point_border_width = Double
0
    , _point_radius :: Double
_point_radius       = Double
1
    , _point_shape :: PointShape
_point_shape        = PointShape
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.
          -> BackendProgram ()
drawPoint :: PointStyle -> Point -> BackendProgram ()
drawPoint ps :: PointStyle
ps@(PointStyle AlphaColour Double
cl AlphaColour Double
_ Double
_ Double
r PointShape
shape) Point
p = PointStyle -> BackendProgram () -> BackendProgram ()
forall a. PointStyle -> BackendProgram a -> BackendProgram a
withPointStyle PointStyle
ps (BackendProgram () -> BackendProgram ())
-> BackendProgram () -> BackendProgram ()
forall a b. (a -> b) -> a -> b
$ do
  p' :: Point
p'@(Point Double
x Double
y) <- Point -> BackendProgram Point
alignStrokePoint Point
p
  case PointShape
shape of
    PointShape
PointShapeCircle -> do
      let path :: Path
path = Point -> Double -> Double -> Double -> Path
arc Point
p' Double
r Double
0 (Double
2Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
forall a. Floating a => a
pi)
      Path -> BackendProgram ()
fillPath Path
path
      Path -> BackendProgram ()
strokePath Path
path
    PointShapePolygon Int
sides Bool
isrot -> do
      let intToAngle :: a -> p
intToAngle a
n =
            if Bool
isrot
            then       a -> p
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
n p -> p -> p
forall a. Num a => a -> a -> a
* p
2p -> p -> p
forall a. Num a => a -> a -> a
*p
forall a. Floating a => a
pip -> p -> p
forall a. Fractional a => a -> a -> a
/Int -> p
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sides
            else (p
0.5 p -> p -> p
forall a. Num a => a -> a -> a
+ a -> p
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
n)p -> p -> p
forall a. Num a => a -> a -> a
*p
2p -> p -> p
forall a. Num a => a -> a -> a
*p
forall a. Floating a => a
pip -> p -> p
forall a. Fractional a => a -> a -> a
/Int -> p
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sides
          angles :: [Double]
angles = (Int -> Double) -> [Int] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Double
forall p a. (Integral a, Floating p) => a -> p
intToAngle [Int
0 .. Int
sidesInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
          (Point
p1:Point
p1':[Point]
p1s) = (Double -> Point) -> [Double] -> [Point]
forall a b. (a -> b) -> [a] -> [b]
map (\Double
a -> Double -> Double -> Point
Point (Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
r Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double
forall a. Floating a => a -> a
sin Double
a)
                                      (Double
y Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
r Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double
forall a. Floating a => a -> a
cos Double
a)) [Double]
angles
      let path :: Path
path = Point -> Path
G.moveTo Point
p1 Path -> Path -> Path
forall a. Semigroup a => a -> a -> a
<> [Path] -> Path
forall a. Monoid a => [a] -> a
mconcat ((Point -> Path) -> [Point] -> [Path]
forall a b. (a -> b) -> [a] -> [b]
map Point -> Path
lineTo ([Point] -> [Path]) -> [Point] -> [Path]
forall a b. (a -> b) -> a -> b
$ Point
p1'Point -> [Point] -> [Point]
forall a. a -> [a] -> [a]
:[Point]
p1s) Path -> Path -> Path
forall a. Semigroup a => a -> a -> a
<> Point -> Path
lineTo Point
p1 Path -> Path -> Path
forall a. Semigroup a => a -> a -> a
<> Point -> Path
lineTo Point
p1'
      Path -> BackendProgram ()
fillPath Path
path
      Path -> BackendProgram ()
strokePath Path
path
    PointShapeArrowHead Double
theta ->
      Point -> BackendProgram () -> BackendProgram ()
forall a. Point -> BackendProgram a -> BackendProgram a
withTranslation Point
p (BackendProgram () -> BackendProgram ())
-> BackendProgram () -> BackendProgram ()
forall a b. (a -> b) -> a -> b
$ Double -> BackendProgram () -> BackendProgram ()
forall a. Double -> BackendProgram a -> BackendProgram a
withRotation (Double
theta Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
forall a. Floating a => a
piDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2) (BackendProgram () -> BackendProgram ())
-> BackendProgram () -> BackendProgram ()
forall a b. (a -> b) -> a -> b
$
          PointStyle -> Point -> BackendProgram ()
drawPoint (Double -> Int -> Bool -> AlphaColour Double -> PointStyle
filledPolygon Double
r Int
3 Bool
True AlphaColour Double
cl) (Double -> Double -> Point
Point Double
0 Double
0)
    PointShape
PointShapePlus -> 
      Path -> BackendProgram ()
strokePath (Path -> BackendProgram ()) -> Path -> BackendProgram ()
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Path
moveTo' (Double
xDouble -> Double -> Double
forall a. Num a => a -> a -> a
+Double
r) Double
y
                Path -> Path -> Path
forall a. Semigroup a => a -> a -> a
<> Double -> Double -> Path
lineTo' (Double
xDouble -> Double -> Double
forall a. Num a => a -> a -> a
-Double
r) Double
y
                Path -> Path -> Path
forall a. Semigroup a => a -> a -> a
<> Double -> Double -> Path
moveTo' Double
x (Double
yDouble -> Double -> Double
forall a. Num a => a -> a -> a
-Double
r)
                Path -> Path -> Path
forall a. Semigroup a => a -> a -> a
<> Double -> Double -> Path
lineTo' Double
x (Double
yDouble -> Double -> Double
forall a. Num a => a -> a -> a
+Double
r)
    PointShape
PointShapeCross -> do
      let rad :: Double
rad = Double
r Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double -> Double
forall a. Floating a => a -> a
sqrt Double
2
      Path -> BackendProgram ()
strokePath (Path -> BackendProgram ()) -> Path -> BackendProgram ()
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Path
moveTo' (Double
xDouble -> Double -> Double
forall a. Num a => a -> a -> a
+Double
rad) (Double
yDouble -> Double -> Double
forall a. Num a => a -> a -> a
+Double
rad)
                Path -> Path -> Path
forall a. Semigroup a => a -> a -> a
<> Double -> Double -> Path
lineTo' (Double
xDouble -> Double -> Double
forall a. Num a => a -> a -> a
-Double
rad) (Double
yDouble -> Double -> Double
forall a. Num a => a -> a -> a
-Double
rad)
                Path -> Path -> Path
forall a. Semigroup a => a -> a -> a
<> Double -> Double -> Path
moveTo' (Double
xDouble -> Double -> Double
forall a. Num a => a -> a -> a
+Double
rad) (Double
yDouble -> Double -> Double
forall a. Num a => a -> a -> a
-Double
rad)
                Path -> Path -> Path
forall a. Semigroup a => a -> a -> a
<> Double -> Double -> Path
lineTo' (Double
xDouble -> Double -> Double
forall a. Num a => a -> a -> a
-Double
rad) (Double
yDouble -> Double -> Double
forall a. Num a => a -> a -> a
+Double
rad)
    PointShape
PointShapeStar -> do
      let rad :: Double
rad = Double
r Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double -> Double
forall a. Floating a => a -> a
sqrt Double
2
      Path -> BackendProgram ()
strokePath (Path -> BackendProgram ()) -> Path -> BackendProgram ()
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Path
moveTo' (Double
xDouble -> Double -> Double
forall a. Num a => a -> a -> a
+Double
r) Double
y
                Path -> Path -> Path
forall a. Semigroup a => a -> a -> a
<> Double -> Double -> Path
lineTo' (Double
xDouble -> Double -> Double
forall a. Num a => a -> a -> a
-Double
r) Double
y
                Path -> Path -> Path
forall a. Semigroup a => a -> a -> a
<> Double -> Double -> Path
moveTo' Double
x (Double
yDouble -> Double -> Double
forall a. Num a => a -> a -> a
-Double
r)
                Path -> Path -> Path
forall a. Semigroup a => a -> a -> a
<> Double -> Double -> Path
lineTo' Double
x (Double
yDouble -> Double -> Double
forall a. Num a => a -> a -> a
+Double
r)
                Path -> Path -> Path
forall a. Semigroup a => a -> a -> a
<> Double -> Double -> Path
moveTo' (Double
xDouble -> Double -> Double
forall a. Num a => a -> a -> a
+Double
rad) (Double
yDouble -> Double -> Double
forall a. Num a => a -> a -> a
+Double
rad)
                Path -> Path -> Path
forall a. Semigroup a => a -> a -> a
<> Double -> Double -> Path
lineTo' (Double
xDouble -> Double -> Double
forall a. Num a => a -> a -> a
-Double
rad) (Double
yDouble -> Double -> Double
forall a. Num a => a -> a -> a
-Double
rad)
                Path -> Path -> Path
forall a. Semigroup a => a -> a -> a
<> Double -> Double -> Path
moveTo' (Double
xDouble -> Double -> Double
forall a. Num a => a -> a -> a
+Double
rad) (Double
yDouble -> Double -> Double
forall a. Num a => a -> a -> a
-Double
rad)
                Path -> Path -> Path
forall a. Semigroup a => a -> a -> a
<> Double -> Double -> Path
lineTo' (Double
xDouble -> Double -> Double
forall a. Num a => a -> a -> a
-Double
rad) (Double
yDouble -> Double -> Double
forall a. Num a => a -> a -> a
+Double
rad)
    PointShapeEllipse Double
b Double
theta ->
      Point -> BackendProgram () -> BackendProgram ()
forall a. Point -> BackendProgram a -> BackendProgram a
withTranslation Point
p (BackendProgram () -> BackendProgram ())
-> BackendProgram () -> BackendProgram ()
forall a b. (a -> b) -> a -> b
$ Double -> BackendProgram () -> BackendProgram ()
forall a. Double -> BackendProgram a -> BackendProgram a
withRotation Double
theta (BackendProgram () -> BackendProgram ())
-> BackendProgram () -> BackendProgram ()
forall a b. (a -> b) -> a -> b
$ Double -> BackendProgram () -> BackendProgram ()
forall a. Double -> BackendProgram a -> BackendProgram a
withScaleX Double
b (BackendProgram () -> BackendProgram ())
-> BackendProgram () -> BackendProgram ()
forall a b. (a -> b) -> a -> b
$ do
        let path :: Path
path = Point -> Double -> Double -> Double -> Path
arc (Double -> Double -> Point
Point Double
0 Double
0) Double
r Double
0 (Double
2Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
forall a. Floating a => a
pi)
        Path -> BackendProgram ()
fillPath Path
path
        Path -> BackendProgram ()
strokePath Path
path

-- -----------------------------------------------------------------------
-- Style Helpers
-- -----------------------------------------------------------------------

-- | The default sequence of colours to use when plotings different data sets
--   in a graph.
defaultColorSeq :: [AlphaColour Double]
defaultColorSeq :: [AlphaColour Double]
defaultColorSeq = [AlphaColour Double] -> [AlphaColour Double]
forall a. [a] -> [a]
cycle ([AlphaColour Double] -> [AlphaColour Double])
-> [AlphaColour Double] -> [AlphaColour Double]
forall a b. (a -> b) -> a -> b
$ (Colour Double -> AlphaColour Double)
-> [Colour Double] -> [AlphaColour Double]
forall a b. (a -> b) -> [a] -> [b]
map Colour Double -> AlphaColour Double
forall a. Num a => Colour a -> AlphaColour a
opaque [Colour Double
forall a. (Ord a, Floating a) => Colour a
blue, Colour Double
forall a. (Ord a, Floating a) => Colour a
red, Colour Double
forall a. (Ord a, Floating a) => Colour a
green, Colour Double
forall a. (Ord a, Floating a) => Colour a
yellow, Colour Double
forall a. (Ord a, Floating a) => Colour a
cyan, Colour Double
forall a. (Ord a, Floating a) => Colour a
magenta]

-- | Create a solid line style (not dashed).
solidLine :: Double             -- ^ Width of line.
          -> AlphaColour Double -- ^ Colour of line.
          -> LineStyle
solidLine :: Double -> AlphaColour Double -> LineStyle
solidLine Double
w AlphaColour Double
cl = Double
-> AlphaColour Double
-> [Double]
-> LineCap
-> LineJoin
-> LineStyle
LineStyle Double
w AlphaColour Double
cl [] LineCap
LineCapButt LineJoin
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 :: Double -> [Double] -> AlphaColour Double -> LineStyle
dashedLine Double
w [Double]
ds AlphaColour Double
cl = Double
-> AlphaColour Double
-> [Double]
-> LineCap
-> LineJoin
-> LineStyle
LineStyle Double
w AlphaColour Double
cl [Double]
ds LineCap
LineCapButt LineJoin
LineJoinMiter

-- | Style for filled circle points.
filledCircles :: Double             -- ^ Radius of circle.
              -> AlphaColour Double -- ^ Fill colour.
              -> PointStyle
filledCircles :: Double -> AlphaColour Double -> PointStyle
filledCircles Double
radius AlphaColour Double
cl = 
  AlphaColour Double
-> AlphaColour Double
-> Double
-> Double
-> PointShape
-> PointStyle
PointStyle AlphaColour Double
cl AlphaColour Double
forall a. Num a => AlphaColour a
transparent Double
0 Double
radius PointShape
PointShapeCircle

-- | Style for stroked circle points.
hollowCircles :: Double -- ^ Radius of circle.
              -> Double -- ^ Thickness of line.
              -> AlphaColour Double -- Colour of line.
              -> PointStyle
hollowCircles :: Double -> Double -> AlphaColour Double -> PointStyle
hollowCircles Double
radius Double
w AlphaColour Double
cl = 
  AlphaColour Double
-> AlphaColour Double
-> Double
-> Double
-> PointShape
-> PointStyle
PointStyle AlphaColour Double
forall a. Num a => AlphaColour a
transparent AlphaColour Double
cl Double
w Double
radius PointShape
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 :: Double -> Double -> Int -> Bool -> AlphaColour Double -> PointStyle
hollowPolygon Double
radius Double
w Int
sides Bool
isrot AlphaColour Double
cl = 
  AlphaColour Double
-> AlphaColour Double
-> Double
-> Double
-> PointShape
-> PointStyle
PointStyle AlphaColour Double
forall a. Num a => AlphaColour a
transparent AlphaColour Double
cl Double
w Double
radius (Int -> Bool -> PointShape
PointShapePolygon Int
sides Bool
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 :: Double -> Int -> Bool -> AlphaColour Double -> PointStyle
filledPolygon Double
radius Int
sides Bool
isrot AlphaColour Double
cl = 
  AlphaColour Double
-> AlphaColour Double
-> Double
-> Double
-> PointShape
-> PointStyle
PointStyle AlphaColour Double
cl AlphaColour Double
forall a. Num a => AlphaColour a
transparent Double
0 Double
radius (Int -> Bool -> PointShape
PointShapePolygon Int
sides Bool
isrot)

-- | Plus sign point style.
plusses :: Double -- ^ Radius of tightest surrounding circle.
        -> Double -- ^ Thickness of line.
        -> AlphaColour Double -- ^ Color of line.
        -> PointStyle
plusses :: Double -> Double -> AlphaColour Double -> PointStyle
plusses Double
radius Double
w AlphaColour Double
cl = 
  AlphaColour Double
-> AlphaColour Double
-> Double
-> Double
-> PointShape
-> PointStyle
PointStyle AlphaColour Double
forall a. Num a => AlphaColour a
transparent AlphaColour Double
cl Double
w Double
radius PointShape
PointShapePlus

-- | Cross point style.
exes :: Double -- ^ Radius of circle.
     -> Double -- ^ Thickness of line.
     -> AlphaColour Double -- ^ Color of line.
     -> PointStyle
exes :: Double -> Double -> AlphaColour Double -> PointStyle
exes Double
radius Double
w AlphaColour Double
cl =
  AlphaColour Double
-> AlphaColour Double
-> Double
-> Double
-> PointShape
-> PointStyle
PointStyle AlphaColour Double
forall a. Num a => AlphaColour a
transparent AlphaColour Double
cl Double
w Double
radius PointShape
PointShapeCross

-- | Combination of plus and cross point style.
stars :: Double -- ^ Radius of circle.
      -> Double -- ^ Thickness of line.
      -> AlphaColour Double -- ^ Color of line.
      -> PointStyle
stars :: Double -> Double -> AlphaColour Double -> PointStyle
stars Double
radius Double
w AlphaColour Double
cl =
  AlphaColour Double
-> AlphaColour Double
-> Double
-> Double
-> PointShape
-> PointStyle
PointStyle AlphaColour Double
forall a. Num a => AlphaColour a
transparent AlphaColour Double
cl Double
w Double
radius PointShape
PointShapeStar

arrows :: Double -- ^ Radius of circle.
       -> Double -- ^ Rotation (Tau)
       -> Double -- ^ Thickness of line.
       -> AlphaColour Double -- ^ Color of line.
       -> PointStyle
arrows :: Double -> Double -> Double -> AlphaColour Double -> PointStyle
arrows Double
radius Double
angle Double
w AlphaColour Double
cl =
  AlphaColour Double
-> AlphaColour Double
-> Double
-> Double
-> PointShape
-> PointStyle
PointStyle AlphaColour Double
forall a. Num a => AlphaColour a
transparent AlphaColour Double
cl Double
w Double
radius (Double -> PointShape
PointShapeArrowHead Double
angle)

-- | Fill style that fill everything this the given colour.
solidFillStyle :: AlphaColour Double -> FillStyle
solidFillStyle :: AlphaColour Double -> FillStyle
solidFillStyle = AlphaColour Double -> FillStyle
FillStyleSolid

$( makeLenses ''PointStyle )