module Graphics.Rendering.Chart.Types(
Rect(..),
Point(..),
Vector(..),
RectSize,
Range,
mkrect,
pvadd,
pvsub,
psub,
vscale,
within,
RectEdge(..),
PointMapFn,
preserveCState,
setClipRegion,
strokeLines,
moveTo,
lineTo,
rectPath,
isValidNumber,
maybeM,
black, grey8, white, red, green, blue,
defaultColorSeq,
Color(..),
setSourceColor,
CairoLineStyle(..),
solidLine,
dashedLine,
setLineStyle,
CairoFillStyle(..),
defaultPointStyle,
solidFillStyle,
setFillStyle,
CairoFontStyle(..),
defaultFontStyle,
setFontStyle,
CairoPointStyle(..),
filledPolygon,
hollowPolygon,
filledCircles,
hollowCircles,
plusses,
exes,
stars,
HTextAnchor(..),
VTextAnchor(..),
drawText,
textSize,
CRender(..),
CEnv(..),
runCRender,
c,
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
data Point = Point {
p_x :: Double,
p_y :: Double
} deriving Show
data Vector = Vector {
v_x :: Double,
v_y :: Double
} deriving Show
data Color = Color {
c_r :: Double,
c_g :: Double,
c_b :: Double
}
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))
type PointMapFn x y = (x,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
}
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_ :: Color,
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_ :: Color
}
type Range = (Double,Double)
type RectSize = (Double,Double)
black = Color 0 0 0
grey8 = Color 0.8 0.8 0.8
white = Color 1 1 1
red = Color 1 0 0
green = Color 0 1 0
blue = Color 0 0 1
defaultColorSeq = cycle [blue,red,green, Color 1 1 0,Color 0 1 1,Color 1 0 1 ]
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)
lineTo p = do
p' <- alignp p
c $ C.lineTo (p_x p') (p_y p')
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
strokeLines :: [Point] -> CRender ()
strokeLines (p1:ps) = do
c $ C.newPath
moveTo p1
mapM_ lineTo ps
c $ C.stroke
strokeLines _ = return ()
rectPath :: Rect -> CRender ()
rectPath (Rect (Point x1 y1) (Point x2 y2)) = c $ do
C.newPath
C.moveTo x1 y1
C.lineTo x2 y1
C.lineTo x2 y2
C.lineTo x1 y2
C.lineTo x1 y1
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 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)
case line_dashes_ ls of
[] -> return ()
ds -> c $ C.setDash ds 0
setFillStyle (CairoFillStyle s) = s
setSourceColor (Color r g b) = C.setSourceRGB r g b
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
drawText :: HTextAnchor -> VTextAnchor -> Point -> String -> CRender ()
drawText hta vta (Point x y) s = c $ do
te <- C.textExtents s
fe <- C.fontExtents
let lx = xadj hta (C.textExtentsWidth te)
let ly = yadj vta te fe
C.moveTo (x+lx) (y+ly)
C.showText s
where
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)
preserveCState :: CRender a -> CRender a
preserveCState a = do
c $ C.save
v <- a
c $ C.restore
return v
filledCircles ::
Double
-> Color
-> 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
-> Color
-> 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
-> Color
-> 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
-> Color
-> 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
-> Color
-> 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
-> Color
-> 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
-> Color
-> 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
-> Color
-> CairoLineStyle
solidLine w cl = CairoLineStyle w cl [] C.LineCapButt C.LineJoinMiter
dashedLine ::
Double
-> [Double]
-> Color
-> CairoLineStyle
dashedLine w ds cl = CairoLineStyle w cl ds C.LineCapButt C.LineJoinMiter
solidFillStyle ::
Color
-> CairoFillStyle
solidFillStyle cl = CairoFillStyle fn
where fn = c $ setSourceColor cl
defaultPointStyle = filledCircles 1 white
defaultFontStyle = CairoFontStyle {
font_name_ = "sans",
font_size_ = 10,
font_slant_ = C.FontSlantNormal,
font_weight_ = C.FontWeightNormal,
font_color_ = black
}
isValidNumber v = not (isNaN v) && not (isInfinite v)
maybeM v = maybe (return v)
$( deriveAccessors ''CairoLineStyle )
$( deriveAccessors ''CairoFontStyle )