module Graphics.Rendering.Chart.Renderable where
import qualified Graphics.Rendering.Cairo as C
import Control.Monad
import Graphics.Rendering.Chart.Types
import Graphics.Rendering.Chart.Plot
data Renderable = Renderable {
minsize :: C.Render RectSize,
render :: Rect -> C.Render ()
}
class ToRenderable a where
toRenderable :: a -> Renderable
emptyRenderable = Renderable {
minsize = return (0,0),
render = \_ -> return ()
}
addMargins :: (Double,Double,Double,Double) -> Renderable -> Renderable
addMargins (t,b,l,r) rd = Renderable { minsize = mf, render = rf }
where
mf = do
(w,h) <- minsize rd
return (w+l+r,h+t+b)
rf r1@(Rect p1 p2) = do
render rd (Rect (p1 `pvadd` (Vector l t)) (p2 `pvsub` (Vector r b)))
fillBackground :: CairoFillStyle -> Renderable -> Renderable
fillBackground fs r = Renderable { minsize = minsize r, render = rf }
where
rf rect@(Rect p1 p2) = do
C.save
setClipRegion p1 p2
setFillStyle fs
C.paint
C.restore
render r rect
vertical, horizontal :: [(Double,Renderable)] -> Renderable
vertical rs = Renderable { minsize = mf, render = rf }
where
mf = do
(_,wmin,hmin) <- calcSizes
return (wmin, hmin)
rf (Rect p1 p2) = do
(sizes,wmin,hmin) <- calcSizes
let wactual = p_x p2 p_x p1
let hextra = p_y p2 p_y p1 hmin
let etotal = sum (map fst rs)
let rs' = [ (wactual,h + hextra * e / etotal,r)
| ((e,r),(w,h)) <- zip rs sizes ]
foldM_ render1 p1 rs'
calcSizes = do
sizes <- mapM minsize [ r | (_,r) <- rs]
let wmin = maximum [ w | (w,h) <- sizes ]
let hmin = sum [ h | (w,h) <- sizes ]
return (sizes,wmin,hmin)
render1 :: Point -> (Double,Double,Renderable) -> C.Render Point
render1 p (w,h,r) = do
render r (Rect p (p `pvadd` Vector w h))
return (p `pvadd` Vector 0 h)
horizontal rs = Renderable { minsize = mf, render = rf }
where
mf = do
(_,wmin,hmin) <- calcSizes
return (wmin, hmin)
rf (Rect p1 p2) = do
(sizes,wmin,hmin) <- calcSizes
let hactual = p_y p2 p_y p1
let wextra = p_x p2 p_x p1 wmin
let etotal = sum (map fst rs)
let rs' = [ (w + wextra * e / etotal,hactual,r)
| ((e,r),(w,h)) <- zip rs sizes ]
foldM_ render1 p1 rs'
calcSizes = do
sizes <- mapM minsize [ r | (_,r) <- rs]
let hmin = maximum [ h | (w,h) <- sizes ]
let wmin = sum [ w | (w,h) <- sizes ]
return (sizes,wmin,hmin)
render1 :: Point -> (Double,Double,Renderable) -> C.Render Point
render1 p (w,h,r) = do
render r (Rect p (p `pvadd` Vector w h))
return (p `pvadd` Vector w 0)
renderableToPNGFile :: Renderable -> Int -> Int -> FilePath -> IO ()
renderableToPNGFile chart width height path =
C.withImageSurface C.FormatARGB32 width height $ \result -> do
C.renderWith result $ rfn
C.surfaceWriteToPNG result path
where
rfn = do
alignPixels
render chart rect
rect = Rect (Point 0 0) (Point (fromIntegral width) (fromIntegral height))
renderableToPDFFile :: Renderable -> Int -> Int -> FilePath -> IO ()
renderableToPDFFile chart width height path =
C.withPDFSurface path (fromIntegral width) (fromIntegral height) $ \result -> do
C.renderWith result $ rfn
C.surfaceFinish result
where
rfn = do
render chart rect
C.showPage
rect = Rect (Point 0 0) (Point (fromIntegral width) (fromIntegral height))
renderableToPSFile :: Renderable -> Int -> Int -> FilePath -> IO ()
renderableToPSFile chart width height path =
C.withPSSurface path (fromIntegral width) (fromIntegral height) $ \result -> do
C.renderWith result $ rfn
C.surfaceFinish result
where
rfn = do
render chart rect
C.showPage
rect = Rect (Point 0 0) (Point (fromIntegral width) (fromIntegral height))
alignPixels :: C.Render ()
alignPixels = do
C.translate 0.5 0.5
data LegendStyle = LegendStyle {
legend_label_style :: CairoFontStyle,
legend_margin :: Double,
legend_plot_size :: Double
}
data Legend = Legend Bool LegendStyle [(String,Plot)]
instance ToRenderable Legend where
toRenderable l = Renderable {
minsize=minsizeLegend l,
render=renderLegend l
}
minsizeLegend :: Legend -> C.Render RectSize
minsizeLegend (Legend _ ls plots) = do
let labels = map fst plots
lsizes <- mapM textSize labels
lgap <- legendSpacer
let lm = legend_margin ls
let pw = legend_plot_size ls
let h = maximum [h | (w,h) <- lsizes]
let n = fromIntegral (length lsizes)
let w = sum [w + lgap | (w,h) <- lsizes] + pw * (n+1) + lm * (n1)
return (w,h)
renderLegend :: Legend -> Rect -> C.Render ()
renderLegend (Legend _ ls plots) (Rect rp1 rp2) = do
foldM_ rf rp1 plots
where
lm = legend_margin ls
lps = legend_plot_size ls
rf :: Point -> (String,Plot) -> C.Render Point
rf p1 (label,plot) = do
(w,h) <- textSize label
lgap <- legendSpacer
let p2 = (p1 `pvadd` Vector lps 0)
plot_render_legend plot (mkrect p1 rp1 p2 rp2)
let p3 = Point (p_x p2 + lgap) (p_y rp1)
drawText HTA_Left VTA_Top p3 label
return (p3 `pvadd` Vector (w+lm) 0)
legendSpacer = do
(lgap,_) <- textSize "X"
return lgap
defaultLegendStyle = LegendStyle {
legend_label_style=defaultFontStyle,
legend_margin=20,
legend_plot_size=20
}
label :: CairoFontStyle -> HTextAnchor -> VTextAnchor -> String -> Renderable
label fs hta vta s = Renderable { minsize = mf, render = rf }
where
mf = do
C.save
setFontStyle fs
sz <- textSize s
C.restore
return sz
rf (Rect p1 p2) = do
C.save
setFontStyle fs
let p = Point (xp hta (p_x p1) (p_x p2)) (yp vta (p_y p1) (p_y p2))
drawText hta vta p s
C.restore
xp HTA_Left x1 x2 = x1
xp HTA_Centre x1 x2 = (x1+x2)/2
xp HTA_Right x1 x2 = x2
yp VTA_Top y1 y2 = y2
yp VTA_Centre y1 y2 = (y1+y2)/2
yp VTA_Bottom y1 y2 = y1