module Graphics.Rendering.Chart.Types(
Rect(..),
Point(..),
Vector(..),
RectSize,
Range,
mkrect,
pvadd,
pvsub,
psub,
vscale,
within,
RectEdge(..),
Limit(..),
PointMapFn,
preserveCState,
setClipRegion,
moveTo,
lineTo,
rectPath,
strokePath,
fillPath,
isValidNumber,
maybeM,
defaultColorSeq,
setSourceColor,
CairoLineStyle(..),
solidLine,
dashedLine,
setLineStyle,
CairoFillStyle(..),
defaultPointStyle,
solidFillStyle,
setFillStyle,
CairoFontStyle(..),
defaultFontStyle,
setFontStyle,
CairoPointStyle(..),
filledPolygon,
hollowPolygon,
filledCircles,
hollowCircles,
plusses,
exes,
stars,
HTextAnchor(..),
VTextAnchor(..),
drawText,
drawTextR,
drawTextsR,
textSize,
textDrawRect,
CRender(..),
CEnv(..),
runCRender,
c,
alignp,
alignc,
line_width,
line_color,
line_dashes,
line_cap,
line_join,
font_name,
font_size,
font_slant,
font_weight,
font_color,
) where
import qualified Graphics.Rendering.Cairo as C
import Control.Monad.Reader
import Data.Accessor
import Data.Accessor.Template
import Data.Colour
import Data.Colour.SRGB
import Data.Colour.Names
import Data.List (unfoldr)
data Point = Point {
p_x :: Double,
p_y :: Double
} deriving Show
data Vector = Vector {
v_x :: Double,
v_y :: Double
} deriving Show
vscale :: Double -> Vector -> Vector
vscale c (Vector x y) = (Vector (x*c) (y*c))
pvadd :: Point -> Vector -> Point
pvadd (Point x1 y1) (Vector x2 y2) = (Point (x1+x2) (y1+y2))
pvsub :: Point -> Vector -> Point
pvsub (Point x1 y1) (Vector x2 y2) = (Point (x1x2) (y1y2))
psub :: Point -> Point -> Vector
psub (Point x1 y1) (Point x2 y2) = (Vector (x1x2) (y1y2))
data Limit a = LMin | LValue a | LMax
deriving Show
type PointMapFn x y = (Limit x, Limit y) -> Point
data Rect = Rect Point Point
deriving Show
data RectEdge = E_Top | E_Bottom | E_Left | E_Right
mkrect :: Point -> Point -> Point -> Point -> Rect
mkrect (Point x1 _) (Point _ y2) (Point x3 _) (Point _ y4) =
Rect (Point x1 y2) (Point x3 y4)
within :: Point -> Rect -> Bool
within (Point x y) (Rect (Point x1 y1) (Point x2 y2)) =
x >= x1 && x <= x2 && y >= y1 && y <= y2
data CEnv = CEnv {
cenv_point_alignfn :: Point -> Point,
cenv_coord_alignfn :: Point -> Point
}
newtype CRender a = DR (ReaderT CEnv C.Render a)
deriving (Functor, Monad, MonadReader CEnv)
runCRender :: CRender a -> CEnv -> C.Render a
runCRender (DR m) e = runReaderT m e
c :: C.Render a -> CRender a
c = DR . lift
newtype CairoPointStyle = CairoPointStyle (Point -> CRender ())
data CairoLineStyle = CairoLineStyle {
line_width_ :: Double,
line_color_ :: AlphaColour Double,
line_dashes_ :: [Double],
line_cap_ :: C.LineCap,
line_join_ :: C.LineJoin
}
newtype CairoFillStyle = CairoFillStyle (CRender ())
data CairoFontStyle = CairoFontStyle {
font_name_ :: String,
font_size_ :: Double,
font_slant_ :: C.FontSlant,
font_weight_ :: C.FontWeight,
font_color_ :: AlphaColour Double
}
type Range = (Double,Double)
type RectSize = (Double,Double)
defaultColorSeq :: [AlphaColour Double]
defaultColorSeq = cycle $ map opaque [blue, red, green, yellow, cyan, magenta]
moveTo, lineTo :: Point -> CRender ()
moveTo p = do
p' <- alignp p
c $ C.moveTo (p_x p') (p_y p')
alignp :: Point -> CRender Point
alignp p = do
alignfn <- fmap cenv_point_alignfn ask
return (alignfn p)
alignc :: Point -> CRender Point
alignc p = do
alignfn <- fmap cenv_coord_alignfn ask
return (alignfn p)
lineTo p = do
p' <- alignp p
c $ C.lineTo (p_x p') (p_y p')
setClipRegion :: Point -> Point -> CRender ()
setClipRegion p2 p3 = do
c $ C.moveTo (p_x p2) (p_y p2)
c $ C.lineTo (p_x p2) (p_y p3)
c $ C.lineTo (p_x p3) (p_y p3)
c $ C.lineTo (p_x p3) (p_y p2)
c $ C.lineTo (p_x p2) (p_y p2)
c $ C.clip
rectPath :: Rect -> [Point]
rectPath (Rect p1@(Point x1 y1) p3@(Point x2 y2)) = [p1,p2,p3,p4,p1]
where
p2 = (Point x1 y2)
p4 = (Point x2 y1)
stepPath :: [Point] -> CRender()
stepPath (p:ps) = c $ do
C.newPath
C.moveTo (p_x p) (p_y p)
mapM_ (\p -> C.lineTo (p_x p) (p_y p)) ps
stepPath _ = return ()
strokePath :: [Point] -> CRender()
strokePath pts = do
alignfn <- fmap cenv_point_alignfn ask
stepPath (map alignfn pts)
c $ C.stroke
fillPath :: [Point] -> CRender()
fillPath pts = do
alignfn <- fmap cenv_coord_alignfn ask
stepPath (map alignfn pts)
c $ C.fill
setFontStyle :: CairoFontStyle -> CRender ()
setFontStyle f = do
c $ C.selectFontFace (font_name_ f) (font_slant_ f) (font_weight_ f)
c $ C.setFontSize (font_size_ f)
c $ setSourceColor (font_color_ f)
setLineStyle :: CairoLineStyle -> CRender ()
setLineStyle ls = do
c $ C.setLineWidth (line_width_ ls)
c $ setSourceColor (line_color_ ls)
c $ C.setLineCap (line_cap_ ls)
c $ C.setLineJoin (line_join_ ls)
c $ C.setDash (line_dashes_ ls) 0
setFillStyle :: CairoFillStyle -> CRender ()
setFillStyle (CairoFillStyle s) = s
colourChannel :: (Floating a, Ord a) => AlphaColour a -> Colour a
colourChannel c = darken (recip (alphaChannel c)) (c `over` black)
setSourceColor :: AlphaColour Double -> C.Render ()
setSourceColor c = let (RGB r g b) = toSRGB $ colourChannel c
in C.setSourceRGBA r g b (alphaChannel c)
textSize :: String -> CRender RectSize
textSize s = c $ do
te <- C.textExtents s
fe <- C.fontExtents
return (C.textExtentsWidth te, C.fontExtentsHeight fe)
data HTextAnchor = HTA_Left | HTA_Centre | HTA_Right
data VTextAnchor = VTA_Top | VTA_Centre | VTA_Bottom | VTA_BaseLine
textDrawRect :: HTextAnchor -> VTextAnchor -> Point -> String -> CRender Rect
textDrawRect hta vta (Point x y) s = preserveCState $ textSize s >>= rect
where
rect (w,h) = c $ do te <- C.textExtents s
fe <- C.fontExtents
let lx = xadj hta (C.textExtentsWidth te)
let ly = yadj vta te fe
let (x',y') = (x + lx, y + ly)
let p1 = Point x' y'
let p2 = Point (x' + w) (y' + h)
return $ Rect p1 p2
xadj HTA_Left w = 0
xadj HTA_Centre w = (w/2)
xadj HTA_Right w = (w)
yadj VTA_Top te fe = C.fontExtentsAscent fe
yadj VTA_Centre te fe = (C.textExtentsYbearing te) / 2
yadj VTA_BaseLine te fe = 0
yadj VTA_Bottom te fe = (C.fontExtentsDescent fe)
drawText :: HTextAnchor -> VTextAnchor -> Point -> String -> CRender ()
drawText hta vta p s = drawTextR hta vta 0 p s
drawTextR :: HTextAnchor -> VTextAnchor -> Double -> Point -> String -> CRender ()
drawTextR hta vta angle (Point x y) s = preserveCState $ draw
where
draw = c $ do te <- C.textExtents s
fe <- C.fontExtents
let lx = xadj hta (C.textExtentsWidth te)
let ly = yadj vta te fe
C.translate x y
C.rotate theta
C.moveTo lx ly
C.showText s
theta = angle*pi/180.0
xadj HTA_Left w = 0
xadj HTA_Centre w = (w/2)
xadj HTA_Right w = (w)
yadj VTA_Top te fe = C.fontExtentsAscent fe
yadj VTA_Centre te fe = (C.textExtentsYbearing te) / 2
yadj VTA_BaseLine te fe = 0
yadj VTA_Bottom te fe = (C.fontExtentsDescent fe)
drawTextsR :: HTextAnchor -> VTextAnchor -> Double -> Point -> String -> CRender ()
drawTextsR hta vta angle (Point x y) s = preserveCState $ drawAll
where
ss = lines s
num = length ss
drawAll = c $ do tes <- mapM C.textExtents ss
fe <- C.fontExtents
let widths = map C.textExtentsWidth tes
maxw = maximum widths
maxh = maximum (map C.textExtentsYbearing tes)
gap = maxh / 2
totalHeight = fromIntegral num*maxh +
(fromIntegral num1)*gap
ys = take num (unfoldr (\y-> Just (y, ygapmaxh))
(yinit vta fe totalHeight))
xs = map (xadj hta) widths
C.translate x y
C.rotate theta
sequence_ (zipWith3 draw xs ys ss)
draw lx ly s = do C.moveTo lx ly
C.showText s
theta = angle*pi/180.0
xadj HTA_Left w = 0
xadj HTA_Centre w = (w/2)
xadj HTA_Right w = (w)
yinit VTA_Top fe height = C.fontExtentsAscent fe
yinit VTA_BaseLine fe height = 0
yinit VTA_Centre fe height = height / 2 + C.fontExtentsAscent fe
yinit VTA_Bottom fe height = height + C.fontExtentsAscent fe
preserveCState :: CRender a -> CRender a
preserveCState a = do
c $ C.save
v <- a
c $ C.restore
return v
filledCircles ::
Double
-> AlphaColour Double
-> CairoPointStyle
filledCircles radius cl = CairoPointStyle rf
where
rf p = do
(Point x y) <- alignp p
c $ setSourceColor cl
c $ C.newPath
c $ C.arc x y radius 0 (2*pi)
c $ C.fill
hollowCircles ::
Double
-> Double
-> AlphaColour Double
-> CairoPointStyle
hollowCircles radius w cl = CairoPointStyle rf
where
rf p = do
(Point x y) <- alignp p
c $ C.setLineWidth w
c $ setSourceColor cl
c $ C.newPath
c $ C.arc x y radius 0 (2*pi)
c $ C.stroke
hollowPolygon ::
Double
-> Double
-> Int
-> Bool
-> AlphaColour Double
-> CairoPointStyle
hollowPolygon radius w sides isrot cl = CairoPointStyle rf
where rf p =
do (Point x y ) <- alignp p
c $ C.setLineWidth w
c $ setSourceColor cl
c $ C.newPath
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 .. sides1]
(p:ps) = map (\a -> Point (x + radius * sin a)
(y + radius * cos a))
angles
moveTo p
mapM_ lineTo (ps++[p])
c $ C.stroke
filledPolygon ::
Double
-> Int
-> Bool
-> AlphaColour Double
-> CairoPointStyle
filledPolygon radius sides isrot cl = CairoPointStyle rf
where rf p =
do (Point x y ) <- alignp p
c $ setSourceColor cl
c $ C.newPath
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 .. sides1]
(p:ps) = map (\a -> Point (x + radius * sin a)
(y + radius * cos a)) angles
moveTo p
mapM_ lineTo (ps++[p])
c $ C.fill
plusses ::
Double
-> Double
-> AlphaColour Double
-> CairoPointStyle
plusses radius w cl = CairoPointStyle rf
where rf p = do (Point x y ) <- alignp p
c $ C.setLineWidth w
c $ setSourceColor cl
c $ C.newPath
c $ C.moveTo (x+radius) y
c $ C.lineTo (xradius) y
c $ C.moveTo x (yradius)
c $ C.lineTo x (y+radius)
c $ C.stroke
exes ::
Double
-> Double
-> AlphaColour Double
-> CairoPointStyle
exes radius w cl = CairoPointStyle rf
where rad = radius / sqrt 2
rf p = do (Point x y ) <- alignp p
c $ C.setLineWidth w
c $ setSourceColor cl
c $ C.newPath
c $ C.moveTo (x+rad) (y+rad)
c $ C.lineTo (xrad) (yrad)
c $ C.moveTo (x+rad) (yrad)
c $ C.lineTo (xrad) (y+rad)
c $ C.stroke
stars ::
Double
-> Double
-> AlphaColour Double
-> CairoPointStyle
stars radius w cl = CairoPointStyle rf
where rad = radius / sqrt 2
rf p = do (Point x y ) <- alignp p
c $ C.setLineWidth w
c $ setSourceColor cl
c $ C.newPath
c $ C.moveTo (x+radius) y
c $ C.lineTo (xradius) y
c $ C.moveTo x (yradius)
c $ C.lineTo x (y+radius)
c $ C.moveTo (x+rad) (y+rad)
c $ C.lineTo (xrad) (yrad)
c $ C.moveTo (x+rad) (yrad)
c $ C.lineTo (xrad) (y+rad)
c $ C.stroke
solidLine ::
Double
-> AlphaColour Double
-> CairoLineStyle
solidLine w cl = CairoLineStyle w cl [] C.LineCapButt C.LineJoinMiter
dashedLine ::
Double
-> [Double]
-> AlphaColour Double
-> CairoLineStyle
dashedLine w ds cl = CairoLineStyle w cl ds C.LineCapButt C.LineJoinMiter
solidFillStyle ::
AlphaColour Double
-> CairoFillStyle
solidFillStyle cl = CairoFillStyle fn
where fn = c $ setSourceColor cl
defaultPointStyle :: CairoPointStyle
defaultPointStyle = filledCircles 1 $ opaque white
defaultFontStyle :: CairoFontStyle
defaultFontStyle = CairoFontStyle {
font_name_ = "sans",
font_size_ = 10,
font_slant_ = C.FontSlantNormal,
font_weight_ = C.FontWeightNormal,
font_color_ = opaque black
}
isValidNumber :: (RealFloat a) => a -> Bool
isValidNumber v = not (isNaN v) && not (isInfinite v)
maybeM :: (Monad m) => b -> (a -> m b) -> Maybe a -> m b
maybeM v = maybe (return v)
$( deriveAccessors ''CairoLineStyle )
$( deriveAccessors ''CairoFontStyle )