diff --git a/Chart.cabal b/Chart.cabal --- a/Chart.cabal +++ b/Chart.cabal @@ -1,5 +1,5 @@ Name: Chart -Version: 0.8 +Version: 0.9 License: BSD3 License-file: LICENSE Copyright: Tim Docker, 2006 @@ -19,10 +19,10 @@ library if flag(splitbase) - Build-depends: base >= 3, old-locale, time, mtl + Build-depends: base >= 3, old-locale, time, mtl, array, data-accessor, data-accessor-template else Build-depends: base < 3 - Build-depends: gtk >= 0.9.11, cairo >= 0.9.11, mtl + Build-depends: gtk >= 0.9.11, cairo >= 0.9.11, time, mtl, array, data-accessor, data-accessor-template Exposed-modules: Graphics.Rendering.Chart, @@ -31,7 +31,9 @@ Graphics.Rendering.Chart.Renderable, Graphics.Rendering.Chart.Axis, Graphics.Rendering.Chart.Layout, + Graphics.Rendering.Chart.Legend, Graphics.Rendering.Chart.Plot, Graphics.Rendering.Chart.Pie, - Graphics.Rendering.Chart.Simple + Graphics.Rendering.Chart.Simple, + Graphics.Rendering.Chart.Grid diff --git a/Graphics/Rendering/Chart.hs b/Graphics/Rendering/Chart.hs --- a/Graphics/Rendering/Chart.hs +++ b/Graphics/Rendering/Chart.hs @@ -1,4 +1,4 @@ ------------------------------------------------------------------------------ +---------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Chart -- Copyright : (c) Tim Docker 2006 @@ -11,77 +11,35 @@ -- 'Renderable' is then actually displayed or output by calling either -- 'renderableToPNGFile', or 'Graphics.Rendering.Chart.Gtk.renderableToWindow'. -- --- Currently, the only useful 'Renderable' for displaying charts --- is created by applying 'toRenderable' to a value of type --- 'Graphics.Rendering.Chart.Layout.Layout1' +-- Currently, there are two kinds of 'Renderable' for displaying charts: -- +-- * a standard two axes chart can be is created by applying +-- 'toRenderable' to a value of type 'Graphics.Rendering.Chart.Layout.Layout1' +-- +-- * a pie chart can be is created by applying +-- 'toRenderable' to a value of type 'Graphics.Rendering.Chart.Pie.PieLayout' +-- +-- Multiple Renderables can be composed using the "Graphics.Rendering.Chart.Grid" module. +-- +-- Many of the record structure involved in the API have a large +-- number of fields For each record type X, there is generally a +-- default value called defaultX with sensibly initialised fields - eg +-- 'Layout1' has 'defaultLayout1' etc. +-- -- For a simpler though less flexible API, see "Graphics.Rendering.Chart.Simple". -- ----------------------------------------------------------------------------- module Graphics.Rendering.Chart( - Renderable(..), - ToRenderable(..), - Layout1(..), - Axis(..), - LinearAxisParams(..), - Plot(..), - ToPlot(..), - PlotPoints(..), - PlotErrBars(..), - PlotLines(..), - PlotFillBetween(..), - HAxis(..), - VAxis(..), - LegendStyle(..), - Rect(..), - Point(..), - Color(..), - ErrPoint(..), - PieChart(..), - PieLayout(..), - PieItem(..), - defaultAxisLineStyle, - defaultPlotLineStyle, - defaultAxis, - defaultPlotPoints, - defaultPlotErrBars, - defaultPlotLines, - defaultPlotFillBetween, - defaultLayout1, - defaultLinearAxis, - defaultPieLayout, - defaultPieChart, - defaultPieItem, - defaultLegendStyle, - filledCircles, - hollowCircles, - exes, plusses, stars, - filledPolygon, - hollowPolygon, - solidLine, - dashedLine, - solidFillStyle, - independentAxes, - linkedAxes, - linkedAxes', - explicitAxis, - autoScaledAxis, - autoScaledAxis', - autoScaledLogAxis, - autoScaledLogAxis', - timeAxis, - autoTimeAxis, - days, months, years, - renderableToPNGFile, - renderableToPDFFile, - renderableToPSFile, - renderableToSVGFile, - doubleFromLocalTime, - localTimeFromDouble, - CairoLineStyle(..), - CairoFillStyle(..), - CairoFontStyle(..) + + module Graphics.Rendering.Chart.Types, + module Graphics.Rendering.Chart.Renderable, + module Graphics.Rendering.Chart.Layout, + module Graphics.Rendering.Chart.Axis, + module Graphics.Rendering.Chart.Plot, + module Graphics.Rendering.Chart.Legend, + module Graphics.Rendering.Chart.Pie, + ) where import Graphics.Rendering.Chart.Types @@ -89,4 +47,5 @@ import Graphics.Rendering.Chart.Layout import Graphics.Rendering.Chart.Axis import Graphics.Rendering.Chart.Plot +import Graphics.Rendering.Chart.Legend import Graphics.Rendering.Chart.Pie diff --git a/Graphics/Rendering/Chart/Axis.hs b/Graphics/Rendering/Chart/Axis.hs --- a/Graphics/Rendering/Chart/Axis.hs +++ b/Graphics/Rendering/Chart/Axis.hs @@ -3,28 +3,95 @@ -- Module : Graphics.Rendering.Chart.Axis -- Copyright : (c) Tim Docker 2006 -- License : BSD-style (see chart/COPYRIGHT) +-- +-- Code to calculate and render axes. +-- +-- Note that template haskell is used to derive accessor functions +-- (see 'Data.Accessor') for each field of the following data types: +-- +-- * 'AxisData' +-- +-- * 'Axis' +-- +-- * 'AxisStyle' +-- +-- * 'LinearAxisParams' +-- +-- * 'LogAxisParams' +-- +-- 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 :: Data.Accessor.Accessor D F +-- @ +-- -module Graphics.Rendering.Chart.Axis where +{-# OPTIONS_GHC -XTemplateHaskell #-} +module Graphics.Rendering.Chart.Axis( + AxisData(..), + AxisT(..), + LinearAxisParams(..), + LogAxisParams(..), + AxisStyle(..), + PlotValue(..), + LogValue(..), + AxisFn, + + defaultAxisLineStyle, + defaultLinearAxis, + defaultLogAxis, + defaultAxisStyle, + autoScaledAxis, + autoScaledLogAxis, + timeAxis, + autoTimeAxis, + days, months, years, + + axisToRenderable, + renderAxisGrid, + axisOverhang, + + axisGridNone, + axisGridAtTicks, + axisGridAtLabels, + + axis_viewport, + axis_ticks, + axis_labels, + axis_grid, + + axis_line_style, + axis_label_style, + axis_grid_style, + axis_label_gap, + + la_labelf, + la_nLabels, + la_nTicks, + + loga_labelf, + +) where + import qualified Graphics.Rendering.Cairo as C import Data.Time import System.Locale (defaultTimeLocale) import Control.Monad import Data.List +import Data.Accessor.Template import Graphics.Rendering.Chart.Types import Graphics.Rendering.Chart.Renderable --- | The concrete data type for an axis -data Axis = Axis { - - -- | The axis_viewport function maps values into device - -- cordinates. - axis_viewport :: Range -> Double -> Double, +-- | The basic data associated with an axis showing values of type x +data AxisData x = AxisData { - -- | The title string to be displayed on the axis. An - -- empty string means no title. - axis_title :: String, + -- | The axis_viewport_ function maps values into device + -- cordinates. + axis_viewport_ :: Range -> x -> Double, -- | The tick marks on the axis as pairs. -- The first element is the position on the axis @@ -32,71 +99,84 @@ -- length of the tick in output coordinates. -- The tick starts on the axis, and positive number are drawn -- towards the plot area. - axis_ticks :: [(Double,Double)], - + axis_ticks_ :: [(x,Double)], + -- | The labels on an axis as pairs. The first element -- is the position on the axis (in viewport units) and -- the second is the label text string. - axis_labels :: [ (Double, String) ], + axis_labels_ :: [ (x, String) ], -- | The positions on the axis (in viewport units) where -- we want to show grid lines. - axis_grid :: [ Double ], - - -- | How far the labels are to be drawn from the axis. - axis_label_gap :: Double, + axis_grid_ :: [ x ] +} - axis_title_style :: CairoFontStyle, - axis_line_style :: CairoLineStyle, - axis_label_style :: CairoFontStyle, - axis_grid_style :: CairoLineStyle +-- | Control values for how an axis gets displayed +data AxisStyle = AxisStyle { + axis_line_style_ :: CairoLineStyle, + axis_label_style_ :: CairoFontStyle, + axis_grid_style_ :: CairoLineStyle, + -- | How far the labels are to be drawn from the axis. + axis_label_gap_ :: Double } --- | Function type to generate an optional axis given a set --- of points to be plotted against that axis. -type AxisFn = [Double] -> Maybe Axis --- | Function type to generate a pair of axes (either top --- and bottom, or left and right), given the set of points to --- be plotted against each of them. -type AxesFn = [Double] -> [Double] -> (Maybe Axis,Maybe Axis) +-- | A function to generate the axis data given the data values +-- to be plotted against it. +type AxisFn x = [x] -> AxisData x -data AxisT = AxisT RectEdge Axis +-- | Collect the information we need to render an axis. The +-- bool is true if the axis direction is reversed +data AxisT x = AxisT RectEdge AxisStyle Bool (AxisData x) -instance ToRenderable AxisT where - toRenderable at = Renderable { +instance ToRenderable (AxisT x) where + toRenderable = setPickFn nullPickFn.axisToRenderable + +axisToRenderable :: AxisT x -> Renderable x +axisToRenderable at = Renderable { minsize=minsizeAxis at, render=renderAxis at } -minsizeAxis :: AxisT -> CRender RectSize -minsizeAxis (AxisT at a) = do - let labels = map snd (axis_labels a) +axisGridNone :: AxisData x -> AxisData x +axisGridNone ad = ad{axis_grid_=[]} + +axisGridAtTicks :: AxisData x -> AxisData x +axisGridAtTicks ad = ad{axis_grid_=map fst (axis_ticks_ ad)} + +axisGridAtLabels :: AxisData x -> AxisData x +axisGridAtLabels ad = ad{axis_grid_=map fst (axis_labels_ ad)} + +minsizeAxis :: AxisT x -> CRender RectSize +minsizeAxis (AxisT at as rev ad) = do + let labels = map snd (axis_labels_ ad) labelSizes <- preserveCState $ do - setFontStyle (axis_label_style a) + setFontStyle (axis_label_style_ as) mapM textSize labels let (lw,lh) = foldl maxsz (0,0) labelSizes - let ag = axis_label_gap a - let tsize = maximum [ max 0 (-l) | (v,l) <- axis_ticks a ] + let ag = axis_label_gap_ as + let tsize = maximum [ max 0 (-l) | (v,l) <- axis_ticks_ ad ] let sz = case at of - E_Top -> (lw,max (lh + ag) tsize) - E_Bottom -> (lw,max (lh + ag) tsize) - E_Left -> (max (lw + ag) tsize, lh) - E_Right -> (max (lw + ag) tsize, lh) + E_Top -> (lw,max (addIfNZ lh ag) tsize) + E_Bottom -> (lw,max (addIfNZ lh ag) tsize) + E_Left -> (max (addIfNZ lw ag) tsize, lh) + E_Right -> (max (addIfNZ lw ag) tsize, lh) return sz where maxsz (w1,h1) (w2,h2) = (max w1 w2, max h1 h2) + addIfNZ a b | a == 0 = 0 + | otherwise = a+b -- | Calculate the amount by which the labels extend beyond -- the ends of the axis -axisOverhang :: AxisT -> CRender (Double,Double) -axisOverhang (AxisT at a) = do - let labels = map snd (sort (axis_labels a)) +axisOverhang :: Ord x => AxisT x -> CRender (Double,Double) +axisOverhang (AxisT at as rev ad) = do + let labels = map snd (sort (axis_labels_ ad)) labelSizes <- preserveCState $ do - setFontStyle (axis_label_style a) + setFontStyle (axis_label_style_ as) mapM textSize labels case labelSizes of [] -> return (0,0) @@ -111,20 +191,21 @@ E_Left -> ohangv E_Right -> ohangh -renderAxis :: AxisT -> Rect -> CRender () -renderAxis at@(AxisT et a) rect = do - let ls = axis_line_style a +renderAxis :: AxisT x -> RectSize -> CRender (PickFn x) +renderAxis at@(AxisT et as rev ad) sz = do + let ls = axis_line_style_ as preserveCState $ do - setLineStyle ls{line_cap=C.LineCapSquare} + setLineStyle ls{line_cap_=C.LineCapSquare} strokeLines [Point sx sy,Point ex ey] preserveCState $ do - setLineStyle ls{line_cap=C.LineCapButt} - mapM_ drawTick (axis_ticks a) + setLineStyle ls{line_cap_=C.LineCapButt} + mapM_ drawTick (axis_ticks_ ad) preserveCState $ do - setFontStyle (axis_label_style a) - mapM_ drawLabel (axis_labels a) + setFontStyle (axis_label_style_ as) + mapM_ drawLabel (axis_labels_ ad) + return nullPickFn where - (sx,sy,ex,ey,tp,axisPoint) = axisMapping at rect + (sx,sy,ex,ey,tp,axisPoint) = axisMapping at sz drawTick (value,length) = let t1 = axisPoint value @@ -132,7 +213,7 @@ in strokeLines [t1,t2] (hta,vta,lp) = - let g = axis_label_gap a + let g = axis_label_gap_ as in case et of E_Top -> (HTA_Centre,VTA_Bottom,(Vector 0 (-g))) E_Bottom -> (HTA_Centre,VTA_Top,(Vector 0 g)) @@ -142,28 +223,26 @@ drawLabel (value,s) = do drawText hta vta (axisPoint value `pvadd` lp) s -axisMapping :: AxisT -> Rect -> (Double,Double,Double,Double,Vector,Double->Point) -axisMapping (AxisT et a) rect = case et of +axisMapping :: AxisT z -> RectSize -> (Double,Double,Double,Double,Vector,z->Point) +axisMapping (AxisT et as rev ad) (x2,y2) = case et of E_Top -> (x1,y2,x2,y2, (Vector 0 1), mapx (x1,x2) y2) E_Bottom -> (x1,y1,x2,y1, (Vector 0 (-1)), mapx (x1,x2) y1) E_Left -> (x2,y2,x2,y1, (Vector (1) 0), mapy (y1,y2) x2) E_Right -> (x1,y2,x1,y1, (Vector (-1) 0), mapy (y1,y2) x1) where - (Rect (Point x1 y1) (Point x2 y2)) = rect - - mapx :: Range -> Double -> Double -> Point - mapx xr y x = Point (axis_viewport a xr x) y + (x1,y1) = (0,0) - mapy :: Range -> Double -> Double -> Point - mapy (yr0,yr1) x y = Point x (axis_viewport a (yr1,yr0) y) + mapx xr y x = Point (axis_viewport_ ad (reverse xr) x) y + mapy (yr0,yr1) x y = Point x (axis_viewport_ ad (reverse (yr1,yr0)) y) + reverse r@(r0,r1) = if rev then (r1,r0) else r -renderAxisGrid :: Rect -> AxisT -> CRender () -renderAxisGrid rect@(Rect p1 p2) at@(AxisT re a) = do +renderAxisGrid :: RectSize -> AxisT z -> CRender () +renderAxisGrid sz@(w,h) at@(AxisT re as rev ad) = do preserveCState $ do - setLineStyle (axis_grid_style a) - mapM_ (drawGridLine re) (axis_grid a) + setLineStyle (axis_grid_style_ as) + mapM_ (drawGridLine re) (axis_grid_ ad) where - (sx,sy,ex,ey,tp,axisPoint) = axisMapping at rect + (sx,sy,ex,ey,tp,axisPoint) = axisMapping at sz drawGridLine E_Top = vline drawGridLine E_Bottom = vline @@ -171,13 +250,13 @@ drawGridLine E_Right = hline vline v = let v' = p_x (axisPoint v) - in strokeLines [Point v' (p_y p1),Point v' (p_y p2)] + in strokeLines [Point v' 0,Point v' h] hline v = let v' = p_y (axisPoint v) - in strokeLines [Point (p_x p1) v',Point (p_x p2) v'] + in strokeLines [Point 0 v',Point w v'] ----------------------------------------------------------------------- + steps:: Double -> Range -> [Rational] steps nSteps (min,max) = [ (fromIntegral (min' + i)) * s | i <- [0..n] ] where @@ -194,50 +273,38 @@ steps' = sort [ (abs((max-min)/(fromRational s) - nsteps), s) | s <- steps ] s = snd (head steps') --- | Explicitly specify an axis -explicitAxis :: Maybe Axis -> AxisFn -explicitAxis ma _ = ma - -autoAxis labelf transform (rlabelvs, rtickvs, rgridvs) a = Just axis +makeAxis :: PlotValue x => (x -> String) -> ([x],[x],[x]) -> AxisData x +makeAxis labelf (labelvs, tickvs, gridvs) = AxisData { + axis_viewport_=newViewport, + axis_ticks_=newTicks, + axis_grid_=gridvs, + axis_labels_=newLabels + } where - axis = a { - axis_viewport=newViewport, - axis_ticks=newTicks, - axis_grid=gridvs, - axis_labels=newLabels - } - newViewport = transform (min',max') + newViewport = vmap (min',max') newTicks = [ (v,2) | v <- tickvs ] ++ [ (v,5) | v <- labelvs ] newLabels = [(v,labelf v) | v <- labelvs] - labelvs = map fromRational rlabelvs - tickvs = map fromRational rtickvs min' = minimum labelvs max' = maximum labelvs - gridvs = case (axis_grid a) of - [] -> [] - _ -> map fromRational rgridvs +data GridMode = GridNone | GridAtMajor | GridAtMinor data LinearAxisParams = LinearAxisParams { -- | The function used to show the axes labels - la_labelf :: Double -> String, + la_labelf_ :: Double -> String, -- | The target number of labels to be shown - la_nLabels :: Int, + la_nLabels_ :: Int, -- | The target number of ticks to be shown - la_nTicks :: Int, - - -- | If True, the grid is shown at the label values, otherwise the - -- otherwise the grid is shown at the tick values - la_gridAtMinor :: Bool + la_nTicks_ :: Int } + defaultLinearAxis = LinearAxisParams { - la_labelf = showD, - la_nLabels = 5, - la_nTicks = 50, - la_gridAtMinor = False + la_labelf_ = showD, + la_nLabels_ = 5, + la_nTicks_ = 50 } -- | Generate a linear axis automatically. @@ -245,27 +312,19 @@ -- and grid set appropriately for the data displayed against that axies. -- The resulting axis will only show a grid if the template has some grid -- values. -autoScaledAxis' :: LinearAxisParams -> Axis -> AxisFn -autoScaledAxis' lap a ps0 = autoAxis (la_labelf lap) vmap (labelvs,tickvs,gridvs) a +autoScaledAxis :: LinearAxisParams -> AxisFn Double +autoScaledAxis lap ps0 = makeAxis (la_labelf_ lap) (labelvs,tickvs,gridvs) where ps = filter isValidNumber ps0 (min,max) = (minimum ps,maximum ps) range [] = (0,1) range _ | min == max = (min-0.5,min+0.5) | otherwise = (min,max) - labelvs = steps (fromIntegral (la_nLabels lap)) r - tickvs = steps (fromIntegral (la_nTicks lap)) (fromRational (minimum labelvs),fromRational (maximum labelvs)) - gridvs = case la_gridAtMinor lap of - False -> labelvs - True -> tickvs + labelvs = map fromRational $ steps (fromIntegral (la_nLabels_ lap)) r + tickvs = map fromRational $ steps (fromIntegral (la_nTicks_ lap)) (minimum labelvs,maximum labelvs) + gridvs = labelvs r = range ps --- | Generate a linear axis automatically. --- Same as autoScaledAxis', but with labels generated with "showD" --- (showD is show for doubles, but with any trailing ".0" removed) -autoScaledAxis :: Axis -> AxisFn -autoScaledAxis = autoScaledAxis' defaultLinearAxis - showD x = case reverse $ show x of '0':'.':r -> reverse r _ -> show x @@ -279,8 +338,6 @@ where (a,b) = properFraction x -lmap (x1,x2) r x = vmap (log x1, log x2) r (log x) - {- Rules: Do no subdivide between powers of 10 until all powers of 10 get a major ticks. @@ -331,55 +388,39 @@ -- and grid set appropriately for the data displayed against that axies. -- The resulting axis will only show a grid if the template has some grid -- values. -autoScaledLogAxis' :: (Double->String) -> Axis -> AxisFn -autoScaledLogAxis' labelf a ps0 = autoAxis labelf lmap (logTicks (range ps)) a +autoScaledLogAxis :: LogAxisParams -> AxisFn LogValue +autoScaledLogAxis lap ps0 = makeAxis labelf (wrap rlabelvs, wrap rtickvs, wrap rgridvs) where - ps = filter isValidNumber ps0 + ps = filter (\(LogValue x) -> isValidNumber x && 0 < x) ps0 (min, max) = (minimum ps,maximum ps) range [] = (3,30) - range _ | min == max = (min/3,max*3) - | otherwise = (min,max) + range _ | min == max = (unLogValue min/3,unLogValue max*3) + | otherwise = (unLogValue min,unLogValue max) + (rlabelvs, rtickvs, rgridvs) = logTicks (range ps) + wrap = map (LogValue . fromRational) + unLogValue (LogValue x) = x + labelf = loga_labelf_ lap --- | Generate a log axis automatically. --- Same as autoScaledLogAxis', but with labels generated with "showD" --- (showD is show for doubles, but with any trailing ".0" removed) -autoScaledLogAxis :: Axis -> AxisFn -autoScaledLogAxis = autoScaledLogAxis' showD --- | Show independent axes on each side of the layout -independentAxes :: AxisFn -> AxisFn -> AxesFn -independentAxes af1 af2 pts1 pts2 = (af1 pts1, af2 pts2) - --- | Show the same axis on both sides of the layout -linkedAxes :: AxisFn -> AxesFn -linkedAxes af pts1 pts2 = (a,a) - where - a = af (pts1++pts2) +data LogAxisParams = LogAxisParams { + -- | The function used to show the axes labels + loga_labelf_ :: LogValue -> String +} --- | Show the same axis on both sides of the layout, but with labels --- only on the primary side -linkedAxes' :: AxisFn -> AxesFn -linkedAxes' af pts1 pts2 = (a,removeLabels a) - where - a = af (pts1++pts2) - removeLabels = liftM (\a -> a{axis_title="",axis_labels = []}) +defaultLogAxis = LogAxisParams { + loga_labelf_ = \(LogValue x) -> showD x +} ---------------------------------------------------------------------- defaultAxisLineStyle = solidLine 1 black defaultGridLineStyle = dashedLine 1 [5,5] grey8 -defaultAxis = Axis { - axis_viewport = vmap (0,1), - axis_title = "", - axis_ticks = [(0,10),(1,10)], - axis_labels = [], - axis_grid = [0.0,0.5,1.0], - axis_label_gap = 10, - axis_title_style = defaultFontStyle, - axis_line_style = defaultAxisLineStyle, - axis_label_style = defaultFontStyle, - axis_grid_style = defaultGridLineStyle +defaultAxisStyle = AxisStyle { + axis_line_style_ = defaultAxisLineStyle, + axis_label_style_ = defaultFontStyle, + axis_grid_style_ = defaultGridLineStyle, + axis_label_gap_ = 10 } ---------------------------------------------------------------------- @@ -423,30 +464,28 @@ -- and the ultimate range will aligned to it's elements. The second 'TimeSeq' sets -- the labels and grid. The 'TimeLabelFn' is used to format LocalTimes for labels. -- The values to be plotted against this axis can be created with 'doubleFromLocalTime' -timeAxis :: TimeSeq -> TimeSeq -> TimeLabelFn -> Axis -> AxisFn -timeAxis tseq lseq labelf a pts = Just axis +timeAxis :: TimeSeq -> TimeSeq -> TimeLabelFn -> AxisFn LocalTime +timeAxis tseq lseq labelf pts = AxisData { + axis_viewport_=vmap(min', max'), + axis_ticks_=[ (t,2) | t <- times] ++ [ (t,5) | t <- ltimes, visible t], + axis_labels_=[ (t,l) | (t,l) <- labels, visible t], + axis_grid_=[ t | t <- ltimes, visible t] + } where - axis = a { - axis_viewport=vmap (dfct min', dfct max'), - axis_ticks=[ (dfct t,2) | t <- times] ++ [ (t,5) | t <- ltimes', visible t], - axis_labels=[ (t,l) | (t,l) <- labels, visible t], - axis_grid=[ t | t <- ltimes', visible t] - } (min,max) = case pts of [] -> (refLocalTime,refLocalTime) - ps -> let min = minimum ps - max = maximum ps in - (ctfd min,ctfd max) + ps -> (minimum ps, maximum ps) refLocalTime = LocalTime (ModifiedJulianDay 0) midnight times = coverTS tseq min max ltimes = coverTS lseq min max - ltimes' = map dfct ltimes min' = minimum times max' = maximum times - visible t = dfct min' <= t && t <= dfct max' - labels = [ ((dfct m2 + dfct m1) / 2, labelf m1) | (m1,m2) <- zip ltimes (tail ltimes) ] - dfct = doubleFromLocalTime - ctfd = localTimeFromDouble + visible t = min' <= t && t <= max' + labels = [ (avg m1 m2, labelf m1) | (m1,m2) <- zip ltimes (tail ltimes) ] + avg m1 m2 = localTimeFromDouble $ m1' + (m2' - m1')/2 + where + m1' = doubleFromLocalTime m1 + m2' = doubleFromLocalTime m2 -- | A 'TimeSeq' for calendar days days :: TimeSeq @@ -477,20 +516,56 @@ -- | Automatically choose a suitable time axis, based upon the time range of data. -- The values to be plotted against this axis can be created with 'doubleFromLocalTime' -autoTimeAxis :: Axis -> AxisFn -autoTimeAxis a pts = +autoTimeAxis :: AxisFn LocalTime +autoTimeAxis [] = timeAxis days days (formatTime defaultTimeLocale "%d-%b") [] +autoTimeAxis pts = if tdiff < 15 - then timeAxis days days (ft "%d-%b") a pts + then timeAxis days days (ft "%d-%b") pts else if tdiff < 90 - then timeAxis days months (ft "%b-%y") a pts + then timeAxis days months (ft "%b-%y") pts else if tdiff < 450 - then timeAxis months months (ft "%b-%y") a pts + then timeAxis months months (ft "%b-%y") pts else if tdiff < 1800 - then timeAxis months years (ft "%Y") a pts - else timeAxis years years (ft "%Y") a pts + then timeAxis months years (ft "%Y") pts + else timeAxis years years (ft "%Y") pts where - tdiff = t1 - t0 + tdiff = diffDays (localDay t1) (localDay t0) t1 = maximum pts t0 = minimum pts ft = formatTime defaultTimeLocale + +----------------------------------------------------------------------------- + +class Ord a => PlotValue a where + toValue :: a -> Double + autoAxis ::AxisFn a + +instance PlotValue Double where + toValue = id + autoAxis = autoScaledAxis defaultLinearAxis + +newtype LogValue = LogValue Double + deriving (Eq, Ord) + +instance Show LogValue where + show (LogValue x) = show x + +instance PlotValue LogValue where + toValue (LogValue x) = log x + autoAxis = autoScaledLogAxis defaultLogAxis + +instance PlotValue LocalTime where + toValue = doubleFromLocalTime + autoAxis = autoTimeAxis + +-- | A linear mapping of points in one range to another +vmap :: PlotValue x => (x,x) -> Range -> x -> Double +vmap (v1,v2) (v3,v4) v = v3 + (toValue v - toValue v1) * (v4-v3) / (toValue v2 - toValue v1) + +---------------------------------------------------------------------- +-- Template haskell to derive an instance of Data.Accessor.Accessor for each field +$( deriveAccessors ''AxisData ) +$( deriveAccessors ''AxisStyle ) +$( deriveAccessors ''LinearAxisParams ) +$( deriveAccessors ''LogAxisParams ) diff --git a/Graphics/Rendering/Chart/Grid.hs b/Graphics/Rendering/Chart/Grid.hs new file mode 100644 --- /dev/null +++ b/Graphics/Rendering/Chart/Grid.hs @@ -0,0 +1,242 @@ +module Graphics.Rendering.Chart.Grid ( + Grid, + tval, tspan, + empty, nullt, + (.|.), (./.), + above, aboveN, + beside, besideN, + overlay, + width, height, + gridToRenderable, + weights +) where + +import Data.List +import Data.Array +-- import qualified Data.Map as Map +import Control.Monad +import Numeric +import Graphics.Rendering.Chart.Renderable +import Graphics.Rendering.Chart.Types +--import Graphics.Rendering.Chart.Gtk +import qualified Graphics.Rendering.Cairo as C + +type Span = (Int,Int) +type Size = (Int,Int) +type SpaceWeight = (Double,Double) + +type Cell a = (a,Span,SpaceWeight) + +data Grid a = Value (a,Span,SpaceWeight) + | Above (Grid a) (Grid a) Size + | Beside (Grid a) (Grid a) Size + | Overlay (Grid a) (Grid a) Size + | Empty + | Null + deriving (Show) + +width :: Grid a -> Int +width Null = 0 +width Empty = 1 +width (Value _) = 1 +width (Beside _ _ (w,h)) = w +width (Above _ _ (w,h)) = w +width (Overlay _ _ (w,h)) = w + +height :: Grid a -> Int +height Null = 0 +height Empty = 1 +height (Value _) = 1 +height (Beside _ _ (w,h)) = h +height (Above _ _ (w,h)) = h +height (Overlay _ _ (w,h)) = h + +tval :: a -> Grid a +tval a = Value (a,(1,1),(0,0)) + +tspan :: a -> Span -> Grid a +tspan a span = Value (a,span,(1,1)) + +empty, nullt :: Grid a +empty = Empty +nullt = Null + +above, beside :: Grid a -> Grid a -> Grid a +above Null t = t +above t Null = t +above t1 t2 = Above t1 t2 size + where size = (max (width t1) (width t2), height t1 + height t2) + +beside Null t = t +beside t Null = t +beside t1 t2 = Beside t1 t2 size + where size = (width t1 + width t2, max (height t1) (height t2)) + +aboveN, besideN :: [Grid a] -> Grid a +aboveN = foldl above nullt +besideN = foldl beside nullt + +overlay Null t = t +overlay t Null = t +overlay t1 t2 = Overlay t1 t2 size + where size = (max (width t1) (width t2), max (height t1) (height t2)) + +(.|.) = beside +(./.) = above + +weights :: SpaceWeight -> Grid a -> Grid a +weights sw Null = Null +weights sw Empty = Empty +weights sw (Value (v,sp,_)) = Value (v,sp,sw) +weights sw (Above t1 t2 sz) = Above (weights sw t1) (weights sw t2) sz +weights sw (Beside t1 t2 sz) = Beside (weights sw t1) (weights sw t2) sz +weights sw (Overlay t1 t2 sz) = Overlay (weights sw t1) (weights sw t2) sz + +-- fix me, need to make .|. and .||. higher precedence +-- than ./. and .//. + +instance Functor Grid where + fmap f (Value (a,span,ew)) = Value (f a,span,ew) + fmap f (Above t1 t2 s) = Above (fmap f t1) (fmap f t2) s + fmap f (Beside t1 t2 s) = Beside (fmap f t1) (fmap f t2) s + fmap f (Overlay t1 t2 s) = Overlay (fmap f t1) (fmap f t2) s + fmap f Empty = Empty + fmap f Null = Null + +mapGridM :: Monad m => (a -> m b) -> Grid a -> m (Grid b) +mapGridM f (Value (a,span,ew)) = do + b <- f a + return (Value (b,span,ew)) +mapGridM f (Above t1 t2 s) = do + t1' <- mapGridM f t1 + t2' <- mapGridM f t2 + return (Above t1' t2' s) +mapGridM f (Beside t1 t2 s) = do + t1' <- mapGridM f t1 + t2' <- mapGridM f t2 + return (Beside t1' t2' s) +mapGridM f (Overlay t1 t2 s) = do + t1' <- mapGridM f t1 + t2' <- mapGridM f t2 + return (Overlay t1' t2' s) +mapGridM _ Empty = return Empty +mapGridM _ Null = return Null + +---------------------------------------------------------------------- +type FlatGrid a = Array (Int,Int) [(a,Span,SpaceWeight)] + +flatten :: Grid a -> FlatGrid a +flatten t = accumArray (flip (:)) [] ((0,0), (width t - 1, height t - 1)) + (flatten2 (0,0) t []) + +type FlatEl a = ((Int,Int),Cell a) + +flatten2 :: (Int,Int) -> Grid a -> [FlatEl a] -> [FlatEl a] +flatten2 i Empty els = els +flatten2 i Null els = els +flatten2 i (Value cell) els = (i,cell):els + +flatten2 i@(x,y) (Above t1 t2 size) els = (f1.f2) els + where + f1 = flatten2 i t1 + f2 = flatten2 (x,y + height t1) t2 + +flatten2 i@(x,y) (Beside t1 t2 size) els = (f1.f2) els + where + f1 = flatten2 i t1 + f2 = flatten2 (x + width t1, y) t2 + +flatten2 i@(x,y) (Overlay t1 t2 size) els = (f1.f2) els + where + f1 = flatten2 i t1 + f2 = flatten2 i t2 + +foldT :: ((Int,Int) -> Cell a -> r -> r) -> r -> FlatGrid a -> r +foldT f iv ft = foldr f' iv (assocs ft) + where + f' (i,vs) r = foldr (\cell -> f i cell) r vs + +---------------------------------------------------------------------- +type DArray = Array Int Double + +gridToRenderable :: Grid (Renderable a) -> Renderable a +gridToRenderable t = Renderable minsizef renderf + where + getSizes :: CRender (DArray, DArray, DArray, DArray) + getSizes = do + szs <- mapGridM minsize t :: CRender (Grid RectSize) + let szs' = flatten szs + let widths = accumArray max 0 (0, width t - 1) (foldT (ef wf) [] szs') + let heights = accumArray max 0 (0, height t - 1) (foldT (ef hf) [] szs') + let xweights = accumArray max 0 (0, width t - 1) (foldT (ef xwf) [] szs') + let yweights = accumArray max 0 (0, height t - 1) (foldT (ef ywf) [] szs') + return (widths,heights,xweights,yweights) + + wf (x,y) (w,h) (ww,wh) = (x,w) + hf (x,y) (w,h) (ww,wh) = (y,h) + xwf (x,y) (w,h) (xw,yw) = (x,xw) + ywf (x,y) (w,h) (xw,yw) = (y,yw) + + ef f loc (size,span,ew) | span == (1,1) = (f loc size ew:) + | otherwise = id + + minsizef = do + (widths, heights, xweights, yweights) <- getSizes + return (sum (elems widths), sum (elems heights)) + + renderf (w,h) = do + (widths, heights, xweights, yweights) <- getSizes + let widths' = addExtraSpace w widths xweights + let heights' = addExtraSpace h heights yweights + let csizes = (ctotal widths',ctotal heights') + rf1 csizes (0,0) t + + rf1 csizes loc@(i,j) t = case t of + Null -> return nullPickFn + Empty -> return nullPickFn + (Value (r,span,_)) -> do + let (Rect (Point x0 y0) (Point x1 y1)) = mkRect csizes loc span + preserveCState $ do + c $ C.translate x0 y0 + render r (x1-x0,y1-y0) + (Above t1 t2 _) -> do + pf1 <- rf1 csizes (i,j) t1 + pf2 <- rf1 csizes (i,j+height t1) t2 + let pf p@(Point x y) = if y < (snd csizes ! (j + height t1)) then pf1 p + else pf2 p + return pf + (Beside t1 t2 _) -> do + pf1 <- rf1 csizes (i,j) t1 + pf2 <- rf1 csizes (i+width t1,j) t2 + let pf p@(Point x y) = if x < (fst csizes ! (i + width t1)) then pf1 p + else pf2 p + return pf + (Overlay t1 t2 _) -> do + pf2 <- rf1 csizes (i,j) t2 + pf1 <- rf1 csizes (i,j) t1 + let pf p = pf1 p `mplus` pf2 p + return pf + + mkRect :: (DArray, DArray) -> (Int,Int) -> (Int,Int) -> Rect + mkRect (cwidths,cheights) (x,y) (w,h) = Rect (Point x1 y1) (Point x2 y2) + where + x1 = cwidths ! x + y1 = cheights ! y + x2 = cwidths ! min (x+w) (snd $ bounds cwidths) + y2 = cheights ! min (y+h) (snd $ bounds cheights) + mx = fst (bounds cwidths) + my = fst (bounds cheights) + + addExtraSpace :: Double -> DArray -> DArray -> DArray + addExtraSpace size sizes weights = + if totalws == 0 then sizes + else listArray (bounds sizes) sizes' + where + ws = elems weights + totalws = sum ws + extra = size - sum (elems sizes) + extras = map (*(extra/totalws)) ws + sizes' = zipWith (+) extras (elems sizes) + + ctotal :: DArray -> DArray + ctotal a = listArray (let (i,j) = bounds a in (i,j+1)) (scanl (+) 0 (elems a)) diff --git a/Graphics/Rendering/Chart/Gtk.hs b/Graphics/Rendering/Chart/Gtk.hs --- a/Graphics/Rendering/Chart/Gtk.hs +++ b/Graphics/Rendering/Chart/Gtk.hs @@ -14,7 +14,7 @@ import Graphics.Rendering.Chart.Renderable import Graphics.Rendering.Chart.Types -renderableToWindow :: Renderable -> Int -> Int -> IO () +renderableToWindow :: Renderable a -> Int -> Int -> IO () renderableToWindow chart windowWidth windowHeight = do G.unsafeInitGUIForThreadedRTS -- G.initGUI @@ -31,12 +31,10 @@ G.widgetShowAll window G.mainGUI -updateCanvas :: Renderable -> G.DrawingArea -> IO Bool +updateCanvas :: Renderable a -> G.DrawingArea -> IO Bool updateCanvas chart canvas = do win <- G.widgetGetDrawWindow canvas (width, height) <- G.widgetGetSize canvas - let rect = Rect (Point 0 0) (Point (fromIntegral width) (fromIntegral height)) - G.renderWithDrawable win $ runCRender (rfn rect) bitmapEnv + let sz = (fromIntegral width,fromIntegral height) + G.renderWithDrawable win $ runCRender (render chart sz) bitmapEnv return True - where - rfn rect = render chart rect diff --git a/Graphics/Rendering/Chart/Layout.hs b/Graphics/Rendering/Chart/Layout.hs --- a/Graphics/Rendering/Chart/Layout.hs +++ b/Graphics/Rendering/Chart/Layout.hs @@ -3,163 +3,334 @@ -- Module : Graphics.Rendering.Chart.Layout -- Copyright : (c) Tim Docker 2006 -- License : BSD-style (see chart/COPYRIGHT) +-- +-- This module glues together axes and plots to actually create a renderable +-- for a chart. +-- +-- Note that template haskell is used to derive accessor functions +-- (see 'Data.Accessor') for each field of the following data types: +-- +-- * 'Layout1' +-- +-- * 'LayoutAxis' +-- +-- 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 :: Data.Accessor.Accessor D F +-- @ +-- -module Graphics.Rendering.Chart.Layout where +{-# OPTIONS_GHC -XTemplateHaskell #-} +module Graphics.Rendering.Chart.Layout( + Layout1(..), + LayoutAxis(..), + MAxisFn, + + defaultLayout1, + + mAxis, + noAxis, + + updateAllAxesStyles, + updateXAxesData, + updateYAxesData, + setForeground, + + laxis_title_style, + laxis_title, + laxis_style, + laxis_data, + laxis_reverse, + + layout1_background, + layout1_title, + layout1_title_style, + layout1_left_axis, + layout1_right_axis, + layout1_top_axis, + layout1_bottom_axis, + layout1_margin, + layout1_plots, + layout1_legend, + layout1_grid_last + ) where + import qualified Graphics.Rendering.Cairo as C import Graphics.Rendering.Chart.Axis import Graphics.Rendering.Chart.Types import Graphics.Rendering.Chart.Plot +import Graphics.Rendering.Chart.Legend import Graphics.Rendering.Chart.Renderable +import Graphics.Rendering.Chart.Grid import Control.Monad import Control.Monad.Reader (local) +import Data.Accessor.Template +import Data.Accessor --- | The side of an horizontal axis -data HAxis = HA_Top | HA_Bottom deriving (Eq) +-- | A @MAxisFn@ is a function that generates an (optional) axis +-- given the points plotted against that axis. +type MAxisFn t = [t] -> Maybe (AxisData t) --- | The side of a vertical axis -data VAxis = VA_Left | VA_Right deriving (Eq) +data LayoutAxis x = LayoutAxis { + laxis_title_style_ :: CairoFontStyle, + laxis_title_ :: String, + laxis_style_ :: AxisStyle, + laxis_data_ :: MAxisFn x, + -- | True if left to right (bottom to top) is to show descending values + laxis_reverse_ :: Bool + +} + -- | A Layout1 value is a single plot area, with optional: axes on --- each of the 4 sides; title at the top; legend at the bottom. -data Layout1 = Layout1 { - layout1_background :: CairoFillStyle, - layout1_title :: String, - layout1_title_style :: CairoFontStyle, - layout1_horizontal_axes :: AxesFn, - layout1_vertical_axes :: AxesFn, - layout1_margin :: Double, - layout1_plots :: [(String,HAxis,VAxis,Plot)], - layout1_legend :: Maybe(LegendStyle), - layout1_grid_last :: Bool +-- each of the 4 sides; title at the top; legend at the bottom. It's +-- parameterised by the types of values to be plotted on the horizonal +-- and vertical axes. +data Layout1 x y = Layout1 { + + layout1_background_ :: CairoFillStyle, + + layout1_title_ :: String, + layout1_title_style_ :: CairoFontStyle, + + layout1_bottom_axis_ :: LayoutAxis x, + layout1_top_axis_ :: LayoutAxis x, + layout1_left_axis_ :: LayoutAxis y, + layout1_right_axis_ :: LayoutAxis y, + + layout1_margin_ :: Double, + layout1_plots_ :: [(String,Either (Plot x y) (Plot x y))], + layout1_legend_ :: Maybe(LegendStyle), + + -- | True if the grid is to be rendered on top of the Plots + layout1_grid_last_ :: Bool } -instance ToRenderable Layout1 where - toRenderable = layout1ToRenderable +data Layout1Pick x y = L1P_Legend String + | L1P_PlotArea x y y + | L1P_BottomAxis x + | L1P_TopAxis x + | L1P_LeftAxis y + | L1P_RightAxis y +instance (Ord x, Ord y) => ToRenderable (Layout1 x y) where + toRenderable = setPickFn nullPickFn.layout1ToRenderable + +layout1ToRenderable :: (Ord x, Ord y) => Layout1 x y -> Renderable (Layout1Pick x y) layout1ToRenderable l = - fillBackground (layout1_background l) ( - vertical [ - (0, addMargins (lm/2,0,0,0) title), - (1, addMargins (lm,lm,lm,lm) plotArea), - (0, horizontal [ (0,mkLegend VA_Left),(1,emptyRenderable),(0, mkLegend VA_Right) ] ) - ] - ) + fillBackground (layout1_background_ l) ( + gridToRenderable $ aboveN [ + tval $ addMargins (lm/2,0,0,0) title, + weights (1,1) $ tval $ addMargins (lm,lm,lm,lm) plotArea, + tval $ legends + ] ) where - lm = layout1_margin l + title = label (layout1_title_style_ l) HTA_Centre VTA_Centre (layout1_title_ l) - title = label (layout1_title_style l) HTA_Centre VTA_Centre (layout1_title l) + plotArea = gridToRenderable (layer2 `overlay` layer1) - mkLegend va = case (layout1_legend l) of - Nothing -> emptyRenderable - (Just ls) -> case [(s,p) | (s,_,va',p) <- layout1_plots l, va' == va, not (null s)] of - [] -> emptyRenderable - ps -> addMargins (0,lm,lm,0) (toRenderable (Legend True ls ps)) + layer1 = aboveN [ + besideN [er, er, er ], + besideN [er, er, er ], + besideN [er, er, weights (1,1) plots ] + ] - plotArea = grid [0,0,1,0,0] [0,0,1,0,0] - [ [er, er, (1,atitle ta), er, er ], - [er, (1,tl), (1,taxis), (1,tr), er ], - [(1,atitle la), (1,laxis), (0,plots), (1,raxis), (1,atitle ra)], - [er, (1,bl), (1,baxis), (1,br), er ], - [er, er, (1,atitle ba), er, er ] ] + layer2 = aboveN [ + besideN [er, er, ttitle, er, er ], + besideN [er, tl, taxis, tr, er ], + besideN [ltitle, laxis, er, raxis, rtitle ], + besideN [er, bl, baxis, br, er ], + besideN [er, er, btitle, er, er ] + ] - atitle Nothing = emptyRenderable - atitle (Just (AxisT e a)) = rlabel (axis_title_style a) ha va rot (axis_title a) - where (ha,va,rot) = case e of E_Top -> (HTA_Centre,VTA_Bottom,0) - E_Bottom -> (HTA_Centre,VTA_Top,0) - E_Left -> (HTA_Right,VTA_Centre,90) - E_Right -> (HTA_Left,VTA_Centre,90) + ttitle = atitle HTA_Centre VTA_Bottom 0 layout1_top_axis_ + btitle = atitle HTA_Centre VTA_Top 0 layout1_bottom_axis_ + ltitle = atitle HTA_Right VTA_Centre 90 layout1_left_axis_ + rtitle = atitle HTA_Left VTA_Centre 90 layout1_right_axis_ - plots = Renderable { - minsize=return (0,0), - render=renderPlots l - } + er = tval $ emptyRenderable + atitle ha va rot af = if ttext == "" then er else tval $ rlabel tstyle ha va rot ttext + where + tstyle = laxis_title_style_ (af l) + ttext = laxis_title_ (af l) + + plots = tval $ plotsToRenderable l + (ba,la,ta,ra) = getAxes l - baxis = maybe emptyRenderable toRenderable ba - taxis = maybe emptyRenderable toRenderable ta - laxis = maybe emptyRenderable toRenderable la - raxis = maybe emptyRenderable toRenderable ra + baxis = tval $ maybe emptyRenderable (mapPickFn L1P_BottomAxis . axisToRenderable) ba + taxis = tval $ maybe emptyRenderable (mapPickFn L1P_TopAxis . axisToRenderable) ta + laxis = tval $ maybe emptyRenderable (mapPickFn L1P_LeftAxis . axisToRenderable) la + raxis = tval $ maybe emptyRenderable (mapPickFn L1P_RightAxis . axisToRenderable) ra - tl = axesSpacer fst ta fst la - bl = axesSpacer fst ba snd la - tr = axesSpacer snd ta fst ra - br = axesSpacer snd ba snd ra + tl = tval $ axesSpacer fst ta fst la + bl = tval $ axesSpacer fst ba snd la + tr = tval $ axesSpacer snd ta fst ra + br = tval $ axesSpacer snd ba snd ra - er = (0,emptyRenderable) + legends = gridToRenderable (besideN [ tval $ mkLegend lefts, + weights (1,1) $ tval $ emptyRenderable, + tval $ mkLegend rights ]) + lefts = [ (s,p) | (s,Left p) <- (layout1_plots_ l) ] + rights = [ (s,p) | (s,Right p) <- (layout1_plots_ l) ] -renderPlots l r@(Rect p1 p2) = preserveCState $ do + mkLegend plots = case (layout1_legend_ l) of + Nothing -> emptyRenderable + (Just ls) -> case plots of + [] -> emptyRenderable + ps -> addMargins (0,lm,lm,lm) + (mapPickFn L1P_Legend $ legendToRenderable (Legend True ls ps)) + + lm = layout1_margin_ l + +plotsToRenderable :: Layout1 x y -> Renderable (Layout1Pick x y) +plotsToRenderable l = Renderable { + minsize=return (0,0), + render= renderPlots l + } + +renderPlots :: Layout1 x y -> RectSize -> CRender (PickFn (Layout1Pick x y)) +renderPlots l sz@(w,h) = preserveCState $ do -- render the plots - setClipRegion p1 p2 + setClipRegion (Point 0 0) (Point w h) - when (not (layout1_grid_last l)) renderGrids + when (not (layout1_grid_last_ l)) renderGrids local (const vectorEnv) $ do - mapM_ (rPlot r) (layout1_plots l) - when (layout1_grid_last l) renderGrids + mapM_ rPlot (layout1_plots_ l) + when (layout1_grid_last_ l) renderGrids + return nullPickFn where (bAxis,lAxis,tAxis,rAxis) = getAxes l - rPlot :: Rect -> (String,HAxis,VAxis,Plot) -> CRender () - rPlot rect (_,ha,va,p) = - let mxaxis = case ha of HA_Bottom -> bAxis - HA_Top -> tAxis - myaxis = case va of VA_Left -> lAxis - VA_Right -> rAxis - in rPlot1 rect mxaxis myaxis p - - rPlot1 :: Rect -> Maybe AxisT -> Maybe AxisT -> Plot -> CRender () - rPlot1 (Rect dc1 dc2) (Just (AxisT _ xaxis)) (Just (AxisT _ yaxis)) p = - let xrange = (p_x dc1, p_x dc2) - yrange = (p_y dc2, p_y dc1) - pmfn (Point x y) = Point (axis_viewport xaxis xrange x) (axis_viewport yaxis yrange y) - in plot_render p pmfn - rPlot1 _ _ _ _ = return () + rPlot (_,Left p) = rPlot1 bAxis lAxis p + rPlot (_,Right p) = rPlot1 bAxis rAxis p + rPlot1 (Just (AxisT _ xs xrev xaxis)) (Just (AxisT _ ys yrev yaxis)) p = + let xrange = if xrev then (w, 0) else (0,w) + yrange = if yrev then (0, h) else (h, 0) + pmfn (x,y) = Point (axis_viewport_ xaxis xrange x) (axis_viewport_ yaxis yrange y) + in plot_render_ p pmfn + rPlot1 _ _ _ = return () + renderGrids = do - maybeM () (renderAxisGrid r) tAxis - maybeM () (renderAxisGrid r) bAxis - maybeM () (renderAxisGrid r) lAxis - maybeM () (renderAxisGrid r) rAxis + maybeM () (renderAxisGrid sz) tAxis + maybeM () (renderAxisGrid sz) bAxis + maybeM () (renderAxisGrid sz) lAxis + maybeM () (renderAxisGrid sz) rAxis axesSpacer f1 a1 f2 a2 = embedRenderable $ do oh1 <- maybeM (0,0) axisOverhang a1 oh2 <- maybeM (0,0) axisOverhang a2 return (spacer (f1 oh1, f2 oh2)) -maybeM v = maybe (return v) - -getAxes :: Layout1 -> (Maybe AxisT, Maybe AxisT, Maybe AxisT, Maybe AxisT) -getAxes l = (mk E_Bottom bAxis, mk E_Left lAxis, - mk E_Top tAxis, mk E_Right rAxis) +getAxes :: Layout1 x y -> (Maybe (AxisT x), Maybe (AxisT y), Maybe (AxisT x), Maybe (AxisT y)) +getAxes l = (bAxis,lAxis,tAxis,rAxis) where - (xvals0,xvals1,yvals0,yvals1) = allPlottedValues (layout1_plots l) - (bAxis,tAxis) = layout1_horizontal_axes l xvals0 xvals1 - (lAxis,rAxis) = layout1_vertical_axes l yvals0 yvals1 - mk _ Nothing = Nothing - mk at (Just a) = Just (AxisT at a) + (xvals0,xvals1,yvals0,yvals1) = allPlottedValues (layout1_plots_ l) + xvals = xvals0 ++ xvals1 + -- Link the axes if either has no data, and use the axis that + -- actually has data to decide whether to reverse it + (yvals0',yrev0) = if null yvals0 then (yvals0++yvals1, layout1_right_axis_) + else (yvals0, layout1_left_axis_) + (yvals1',yrev1) = if null yvals1 then (yvals0++yvals1, layout1_left_axis_) + else (yvals1, layout1_right_axis_) -allPlottedValues :: [(String,HAxis,VAxis,Plot)] -> ( [Double], [Double], [Double], [Double] ) + bAxis = mkAxis E_Bottom layout1_bottom_axis_ layout1_bottom_axis_ xvals + tAxis = mkAxis E_Top layout1_top_axis_ layout1_bottom_axis_ xvals + lAxis = mkAxis E_Left layout1_left_axis_ yrev0 yvals0' + rAxis = mkAxis E_Right layout1_right_axis_ yrev1 yvals1' + + mkAxis t axisf revf vals = do + adata <- laxis_data_ (axisf l) vals + return (AxisT t (laxis_style_ (axisf l)) (laxis_reverse_ (revf l)) adata) + +allPlottedValues :: [(String,Either (Plot x y) (Plot x' y'))] -> ( [x], [x'], [y], [y'] ) allPlottedValues plots = (xvals0,xvals1,yvals0,yvals1) where - pts = concat [ [ (ha,va,pt)| pt <- plot_all_points p] | (_,ha,va,p) <- plots ] - xvals0 = [ (p_x pt) | (HA_Bottom,_,pt) <- pts ] - xvals1 = [ (p_x pt) | (HA_Top,_,pt) <- pts ] - yvals0 = [ (p_y pt) | (_,VA_Left,pt) <- pts ] - yvals1 = [ (p_y pt) | (_,VA_Right,pt) <- pts ] - + xvals0 = [ x | (_, Left p) <- plots, (x,_) <- plot_all_points_ p] + yvals0 = [ y | (_, Left p) <- plots, (_,y) <- plot_all_points_ p] + xvals1 = [ x | (_, Right p) <- plots, (x,_) <- plot_all_points_ p] + yvals1 = [ y | (_, Right p) <- plots, (_,y) <- plot_all_points_ p] +defaultLayout1 :: (PlotValue x,PlotValue y) => Layout1 x y defaultLayout1 = Layout1 { - layout1_background = solidFillStyle white, - layout1_title = "", - layout1_title_style = defaultFontStyle{font_size=15, font_weight=C.FontWeightBold}, - layout1_horizontal_axes = linkedAxes (autoScaledAxis defaultAxis), - layout1_vertical_axes = linkedAxes (autoScaledAxis defaultAxis), - layout1_margin = 10, - layout1_plots = [], - layout1_legend = Just defaultLegendStyle, - layout1_grid_last = False + layout1_background_ = solidFillStyle white, + + layout1_title_ = "", + layout1_title_style_ = defaultFontStyle{font_size_=15, font_weight_=C.FontWeightBold}, + + layout1_top_axis_ = defaultLayoutAxis, + layout1_bottom_axis_ = defaultLayoutAxis, + layout1_left_axis_ = defaultLayoutAxis, + layout1_right_axis_ = defaultLayoutAxis, + + layout1_margin_ = 10, + layout1_plots_ = [], + layout1_legend_ = Just defaultLegendStyle, + layout1_grid_last_ = False } + +defaultLayoutAxis :: PlotValue t => LayoutAxis t +defaultLayoutAxis = LayoutAxis { + laxis_title_style_ = defaultFontStyle{font_size_=10}, + laxis_title_ = "", + laxis_style_ = defaultAxisStyle, + laxis_data_ = mAxis autoAxis, + laxis_reverse_ = False +} + +-- | Create an axis when there are points to be plotted against it. +mAxis :: PlotValue t => AxisFn t -> MAxisFn t +mAxis axisfn [] = Nothing +mAxis axisfn ps = Just (axisfn ps) + +-- | Never create an axis +noAxis :: PlotValue t => LayoutAxis t +noAxis = LayoutAxis { + laxis_title_style_ = defaultFontStyle{font_size_=10}, + laxis_title_ = "", + laxis_style_ = defaultAxisStyle, + laxis_data_ = const Nothing, + laxis_reverse_ = False +} + +---------------------------------------------------------------------- +-- Template haskell to derive an instance of Data.Accessor.Accessor for each field +$( deriveAccessors ''Layout1 ) +$( deriveAccessors ''LayoutAxis ) + +-- | Helper to update all axis styles on a Layout1 simultaneously +updateAllAxesStyles :: (AxisStyle -> AxisStyle) -> Layout1 x y -> Layout1 x y +updateAllAxesStyles uf = (layout1_top_axis .> laxis_style ^: uf) . + (layout1_bottom_axis .> laxis_style ^: uf) . + (layout1_left_axis .> laxis_style ^: uf) . + (layout1_right_axis .> laxis_style ^: uf) + +-- | Helper to update data member of both horizontal axes in a Layout1 +updateXAxesData :: (MAxisFn x -> MAxisFn x) -> Layout1 x y -> Layout1 x y +updateXAxesData uf = (layout1_top_axis .> laxis_data ^: uf) . + (layout1_bottom_axis .> laxis_data ^: uf) + +-- | Helper to update data member of both vertical axes in a Layout1 +updateYAxesData :: (MAxisFn y -> MAxisFn y) -> Layout1 x y -> Layout1 x y +updateYAxesData uf = (layout1_left_axis .> laxis_data ^: uf) . + (layout1_right_axis .> laxis_data ^: uf) + + +-- | Helper to set the forground color uniformly on a Layout1 +setForeground :: Color -> Layout1 x y -> Layout1 x y +setForeground fg = updateAllAxesStyles ( + (axis_line_style .> line_color ^= fg). + (axis_label_style .> font_color ^= fg) + ) + . (layout1_title_style .> font_color ^= fg) + . (layout1_legend ^: fmap (legend_label_style .> font_color ^= fg)) + diff --git a/Graphics/Rendering/Chart/Legend.hs b/Graphics/Rendering/Chart/Legend.hs new file mode 100644 --- /dev/null +++ b/Graphics/Rendering/Chart/Legend.hs @@ -0,0 +1,75 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Chart.Legend +-- Copyright : (c) Tim Docker 2006 +-- License : BSD-style (see chart/COPYRIGHT) + +{-# OPTIONS_GHC -XTemplateHaskell #-} + +module Graphics.Rendering.Chart.Legend( + Legend(..), + LegendStyle(..), + defaultLegendStyle, + legendToRenderable, + legend_label_style, + legend_margin, + legend_plot_size, +) where + +import qualified Graphics.Rendering.Cairo as C +import Control.Monad +import Data.List (nub, partition,intersperse) +import Data.Accessor.Template + +import Graphics.Rendering.Chart.Types +import Graphics.Rendering.Chart.Plot +import Graphics.Rendering.Chart.Renderable +import Graphics.Rendering.Chart.Grid + +---------------------------------------------------------------------- +-- Legend + +data LegendStyle = LegendStyle { + legend_label_style_ :: CairoFontStyle, + legend_margin_ :: Double, + legend_plot_size_ :: Double +} + +data Legend x y = Legend Bool LegendStyle [(String,Plot x y)] + +instance ToRenderable (Legend x y) where + toRenderable = setPickFn nullPickFn.legendToRenderable + +legendToRenderable :: Legend x y -> Renderable String +legendToRenderable (Legend _ ls plots) = gridToRenderable grid + where + grid = besideN $ intersperse ggap1 (map (tval.rf) (join_nub plots)) + rf (title,ps) = setPickFn (const (Just title)) (gridToRenderable grid1) + where + grid1 = besideN $ intersperse ggap2 (map rp ps) ++ [ggap2,gtitle] + gtitle = tval $ lbl title + rp p = tval $ Renderable { + minsize = return (legend_plot_size_ ls, 0), + render = \(w,h) -> do + plot_render_legend_ p (Rect (Point 0 0) (Point w h)) + return nullPickFn + } + ggap1 = tval $ spacer (legend_margin_ ls,0) + ggap2 = tval $ spacer1 (lbl "X") + lbl s = label (legend_label_style_ ls) HTA_Centre VTA_Centre s + +join_nub :: [(String, a)] -> [(String, [a])] +join_nub ((x,a1):ys) = case partition ((==x) . fst) ys of + (xs, rest) -> (x, a1:map snd xs) : join_nub rest +join_nub [] = [] + +defaultLegendStyle = LegendStyle { + legend_label_style_=defaultFontStyle, + legend_margin_=20, + legend_plot_size_=20 +} + +---------------------------------------------------------------------- +-- Template haskell to derive an instance of Data.Accessor.Accessor for each field +$( deriveAccessors ''LegendStyle ) + diff --git a/Graphics/Rendering/Chart/Pie.hs b/Graphics/Rendering/Chart/Pie.hs --- a/Graphics/Rendering/Chart/Pie.hs +++ b/Graphics/Rendering/Chart/Pie.hs @@ -1,65 +1,118 @@ -module Graphics.Rendering.Chart.Pie where +{-# OPTIONS_GHC -XTemplateHaskell #-} +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Chart.Layout +-- Copyright : (c) Tim Docker 2008 +-- License : BSD-style (see chart/COPYRIGHT) +-- +-- A basic pie chart. +-- +-- Note that template haskell is used to derive accessor functions +-- (see 'Data.Accessor') for each field of the following data types: +-- +-- * 'PieLayout' +-- +-- * 'PieChart' +-- +-- * 'PieItem' +-- +-- 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 :: Data.Accessor.Accessor D F +-- @ +-- + + +module Graphics.Rendering.Chart.Pie( + PieLayout(..), + PieChart(..), + PieItem(..), + defaultPieLayout, + defaultPieChart, + defaultPieItem, + + pie_title, + pie_title_style, + pie_plot, + pie_background, + pie_margin, + pie_data, + pie_colors, + pie_label_style, + pie_label_line_style, + pie_start_angle, + pitem_label, + pitem_offset, + pitem_value, + +) where -- original code thanks to Neal Alexander import qualified Graphics.Rendering.Cairo as C import Data.List import Data.Bits +import Data.Accessor.Template import Control.Monad import Graphics.Rendering.Chart.Types +import Graphics.Rendering.Chart.Legend import Graphics.Rendering.Chart.Renderable +import Graphics.Rendering.Chart.Grid data PieLayout = PieLayout { - pie_title :: String, - pie_title_style :: CairoFontStyle, - pie_plot :: PieChart, - pie_background :: CairoFillStyle, - pie_margin :: Double + pie_title_ :: String, + pie_title_style_ :: CairoFontStyle, + pie_plot_ :: PieChart, + pie_background_ :: CairoFillStyle, + pie_margin_ :: Double } data PieChart = PieChart { - pie_data :: [PieItem], - pie_colors :: [Color], - pie_label_style :: CairoFontStyle, - pie_label_line_style :: CairoLineStyle, - pie_start_angle :: Double + pie_data_ :: [PieItem], + pie_colors_ :: [Color], + pie_label_style_ :: CairoFontStyle, + pie_label_line_style_ :: CairoLineStyle, + pie_start_angle_ :: Double } data PieItem = PieItem { - pitem_label :: String, - pitem_offset :: Double, - pitem_value :: Double + pitem_label_ :: String, + pitem_offset_ :: Double, + pitem_value_ :: Double } defaultPieChart = PieChart { - pie_data = [], - pie_colors = defaultColorSeq, - pie_label_style = defaultFontStyle, - pie_label_line_style = solidLine 1 black, - pie_start_angle = 0 + pie_data_ = [], + pie_colors_ = defaultColorSeq, + pie_label_style_ = defaultFontStyle, + pie_label_line_style_ = solidLine 1 black, + pie_start_angle_ = 0 } defaultPieItem = PieItem "" 0 0 defaultPieLayout = PieLayout { - pie_background = solidFillStyle white, - pie_title = "", - pie_title_style = defaultFontStyle{font_size=15, font_weight=C.FontWeightBold}, - pie_plot = defaultPieChart, - pie_margin = 10 + pie_background_ = solidFillStyle white, + pie_title_ = "", + pie_title_style_ = defaultFontStyle{font_size_=15, font_weight_=C.FontWeightBold}, + pie_plot_ = defaultPieChart, + pie_margin_ = 10 } instance ToRenderable PieLayout where - toRenderable p = fillBackground (pie_background p) ( - vertical [ - (0, addMargins (lm/2,0,0,0) title), - (1, addMargins (lm,lm,lm,lm) (toRenderable $ pie_plot p)) + toRenderable p = fillBackground (pie_background_ p) ( + gridToRenderable $ aboveN [ + tval $ addMargins (lm/2,0,0,0) title, + weights (1,1) $ tval $ addMargins (lm,lm,lm,lm) (toRenderable $ pie_plot_ p) ] ) where - title = label (pie_title_style p) HTA_Centre VTA_Top (pie_title p) - lm = pie_margin p + title = label (pie_title_style_ p) HTA_Centre VTA_Top (pie_title_ p) + lm = pie_margin_ p instance ToRenderable PieChart where toRenderable p = Renderable { @@ -68,10 +121,10 @@ } extraSpace p = do - textSizes <- mapM textSize (map pitem_label (pie_data p)) + textSizes <- mapM textSize (map pitem_label_ (pie_data_ p)) let maxw = foldr (max.fst) 0 textSizes let maxh = foldr (max.snd) 0 textSizes - let maxo = foldr (max.pitem_offset) 0 (pie_data p) + let maxo = foldr (max.pitem_offset_) 0 (pie_data_ p) let extra = label_rgap + label_rlength + maxo return (extra + maxw, extra + maxh ) @@ -79,35 +132,38 @@ (extraw,extrah) <- extraSpace p return (extraw * 2, extrah * 2) -renderPie p (Rect p1 p2) = do +renderPie p (w,h) = do (extraw,extrah) <- extraSpace p let (w,h) = (p_x p2 - p_x p1, p_y p2 - p_y p1) let center = Point (p_x p1 + w/2) (p_y p1 + h/2) let radius = (min (w - 2*extraw) (h - 2*extrah)) / 2 - foldM_ (paint center radius) (pie_start_angle p) (zip (pie_colors p) content) + foldM_ (paint center radius) (pie_start_angle_ p) (zip (pie_colors_ p) content) + return nullPickFn where - content = let total = sum (map pitem_value (pie_data p)) - in [ pi{pitem_value=pitem_value pi/total} | pi <- pie_data p ] + p1 = Point 0 0 + p2 = Point w h + content = let total = sum (map pitem_value_ (pie_data_ p)) + in [ pi{pitem_value_=pitem_value_ pi/total} | pi <- pie_data_ p ] paint :: Point -> Double -> Double -> (Color,PieItem) -> CRender Double paint center radius a1 (color,pitem) = do - let ax = 360.0 * (pitem_value pitem) + let ax = 360.0 * (pitem_value_ pitem) let a2 = a1 + (ax / 2) let a3 = a1 + ax - let offset = pitem_offset pitem + let offset = pitem_offset_ pitem pieSlice (ray a2 offset) a1 a3 color - pieLabel (pitem_label pitem) a2 offset + pieLabel (pitem_label_ pitem) a2 offset return a3 where pieLabel :: String -> Double -> Double -> CRender () pieLabel name angle offset = do - setFontStyle (pie_label_style p) - setLineStyle (pie_label_line_style p) + setFontStyle (pie_label_style_ p) + setLineStyle (pie_label_line_style_ p) moveTo (ray angle (radius + label_rgap+offset)) let p1 = (ray angle (radius + label_rgap + label_rlength+offset)) @@ -152,3 +208,10 @@ label_rgap = 5 label_rlength = 15 + +---------------------------------------------------------------------- +-- Template haskell to derive an instance of Data.Accessor.Accessor for each field +$( deriveAccessors ''PieLayout ) +$( deriveAccessors ''PieChart ) +$( deriveAccessors ''PieItem ) + diff --git a/Graphics/Rendering/Chart/Plot.hs b/Graphics/Rendering/Chart/Plot.hs --- a/Graphics/Rendering/Chart/Plot.hs +++ b/Graphics/Rendering/Chart/Plot.hs @@ -3,7 +3,34 @@ -- Module : Graphics.Rendering.Chart.Plot -- Copyright : (c) Tim Docker 2006 -- License : BSD-style (see chart/COPYRIGHT) +-- +-- Definitions of various types of Plots we can put on a 2D Chart. +-- +-- Note that template haskell is used to derive accessor functions +-- (see 'Data.Accessor') for each field of the following data types: +-- +-- * 'Plot' +-- +-- * 'PlotLines' +-- +-- * 'PlotPoints' +-- +-- * 'PlotFillBetween' +-- +-- * 'PlotErrBars' +-- +-- 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 :: Data.Accessor.Accessor D F +-- @ +-- + +{-# OPTIONS_GHC -XTemplateHaskell #-} + module Graphics.Rendering.Chart.Plot( Plot(..), ToPlot(..), @@ -12,233 +39,278 @@ PlotLines(..), PlotFillBetween(..), ErrPoint(..), + symErrPoint, defaultPlotLineStyle, defaultPlotPoints, defaultPlotErrBars, defaultPlotFillBetween, - defaultPlotLines - + defaultPlotLines, + + plot_lines_style, + plot_lines_values, + + plot_render, + plot_render_legend, + plot_all_points, + + plot_points_style, + plot_points_values, + + plot_fillbetween_style, + plot_fillbetween_values, + + plot_errbars_line_style, + plot_errbars_tick_length, + plot_errbars_overhang, + plot_errbars_values, + ) where import qualified Graphics.Rendering.Cairo as C import Graphics.Rendering.Chart.Types import Control.Monad +import Data.Accessor.Template -- | Interface to control plotting on a 2D area. -data Plot = Plot { +data Plot x y = Plot { -- | Given the mapping between model space coordinates and device coordinates, -- render this plot into a chart. - plot_render :: PointMapFn -> CRender (), + plot_render_ :: PointMapFn x y -> CRender (), -- | Render a small sample of this plot into the given rectangle. -- This is for used to generate a the legend a chart. - plot_render_legend :: Rect -> CRender (), + plot_render_legend_ :: Rect -> CRender (), -- | All of the model space coordinates to be plotted. These are -- used to autoscale the axes where necessary. - plot_all_points :: [Point] -}; + plot_all_points_ :: [(x,y)] +} -- | a type class abstracting the conversion of a value to a Plot. class ToPlot a where - toPlot :: a -> Plot + toPlot :: a x y -> Plot x y ---------------------------------------------------------------------- -- | Value defining a series of (possibly disjointed) lines, -- and a style in which to render them -data PlotLines = PlotLines { - plot_lines_style :: CairoLineStyle, - plot_lines_values :: [[Point]] +data PlotLines x y = PlotLines { + plot_lines_style_ :: CairoLineStyle, + plot_lines_values_ :: [[(x,y)]] } + instance ToPlot PlotLines where toPlot p = Plot { - plot_render = renderPlotLines p, - plot_render_legend = renderPlotLegendLines p, - plot_all_points = concat (plot_lines_values p) + plot_render_ = renderPlotLines p, + plot_render_legend_ = renderPlotLegendLines p, + plot_all_points_ = concat (plot_lines_values_ p) } -renderPlotLines :: PlotLines -> PointMapFn -> CRender () +renderPlotLines :: PlotLines x y -> PointMapFn x y -> CRender () renderPlotLines p pmap = preserveCState $ do - setLineStyle (plot_lines_style p) - mapM_ drawLines (plot_lines_values p) + setLineStyle (plot_lines_style_ p) + mapM_ drawLines (plot_lines_values_ p) where drawLines (p:ps) = do moveTo (pmap p) mapM_ (\p -> lineTo (pmap p)) ps c $ C.stroke -renderPlotLegendLines :: PlotLines -> Rect -> CRender () +renderPlotLegendLines :: PlotLines x y -> Rect -> CRender () renderPlotLegendLines p r@(Rect p1 p2) = preserveCState $ do - setLineStyle (plot_lines_style p) + setLineStyle (plot_lines_style_ p) let y = (p_y p1 + p_y p2) / 2 moveTo (Point (p_x p1) y) lineTo (Point (p_x p2) y) c $ C.stroke defaultPlotLineStyle = (solidLine 1 blue){ - line_cap = C.LineCapRound, - line_join = C.LineJoinRound + line_cap_ = C.LineCapRound, + line_join_ = C.LineJoinRound } defaultPlotLines = PlotLines { - plot_lines_style = defaultPlotLineStyle, - plot_lines_values = [] + plot_lines_style_ = defaultPlotLineStyle, + plot_lines_values_ = [] } ---------------------------------------------------------------------- -- | Value defining a series of datapoints, and a style in -- which to render them -data PlotPoints = PlotPoints { - plot_points_style :: CairoPointStyle, - plot_points_values :: [Point] +data PlotPoints x y = PlotPoints { + plot_points_style_ :: CairoPointStyle, + plot_points_values_ :: [(x,y)] } + instance ToPlot PlotPoints where toPlot p = Plot { - plot_render = renderPlotPoints p, - plot_render_legend = renderPlotLegendPoints p, - plot_all_points = plot_points_values p + plot_render_ = renderPlotPoints p, + plot_render_legend_ = renderPlotLegendPoints p, + plot_all_points_ = plot_points_values_ p } -renderPlotPoints :: PlotPoints -> PointMapFn -> CRender () +renderPlotPoints :: PlotPoints x y -> PointMapFn x y -> CRender () renderPlotPoints p pmap = preserveCState $ do - mapM_ (drawPoint.pmap) (plot_points_values p) + mapM_ (drawPoint.pmap) (plot_points_values_ p) where - (CairoPointStyle drawPoint) = (plot_points_style p) + (CairoPointStyle drawPoint) = (plot_points_style_ p) -renderPlotLegendPoints :: PlotPoints -> Rect -> CRender () +renderPlotLegendPoints :: PlotPoints x y -> Rect -> CRender () renderPlotLegendPoints p r@(Rect p1 p2) = preserveCState $ do drawPoint (Point (p_x p1) ((p_y p1 + p_y p2)/2)) drawPoint (Point ((p_x p1 + p_x p2)/2) ((p_y p1 + p_y p2)/2)) drawPoint (Point (p_x p2) ((p_y p1 + p_y p2)/2)) where - (CairoPointStyle drawPoint) = (plot_points_style p) + (CairoPointStyle drawPoint) = (plot_points_style_ p) defaultPlotPoints = PlotPoints { - plot_points_style =defaultPointStyle, - plot_points_values = [] + plot_points_style_ =defaultPointStyle, + plot_points_values_ = [] } ---------------------------------------------------------------------- -- | Value specifying a plot filling the area between two sets of Y -- coordinates, given common X coordinates. -data PlotFillBetween = PlotFillBetween { - plot_fillbetween_style :: CairoFillStyle, - plot_fillbetween_values :: [ (Double, (Double,Double))] +data PlotFillBetween x y = PlotFillBetween { + plot_fillbetween_style_ :: CairoFillStyle, + plot_fillbetween_values_ :: [ (x, (y,y))] } + instance ToPlot PlotFillBetween where toPlot p = Plot { - plot_render = renderPlotFillBetween p, - plot_render_legend = renderPlotLegendFill p, - plot_all_points = plotAllPointsFillBetween p + plot_render_ = renderPlotFillBetween p, + plot_render_legend_ = renderPlotLegendFill p, + plot_all_points_ = plotAllPointsFillBetween p } -renderPlotFillBetween :: PlotFillBetween -> PointMapFn -> CRender () -renderPlotFillBetween p pmap = renderPlotFillBetween' p (plot_fillbetween_values p) pmap +renderPlotFillBetween :: PlotFillBetween x y -> PointMapFn x y -> CRender () +renderPlotFillBetween p pmap = renderPlotFillBetween' p (plot_fillbetween_values_ p) pmap renderPlotFillBetween' p [] _ = return () renderPlotFillBetween' p vs pmap = preserveCState $ do - setFillStyle (plot_fillbetween_style p) + setFillStyle (plot_fillbetween_style_ p) moveTo p0 mapM_ lineTo p1s mapM_ lineTo (reverse p2s) lineTo p0 c $ C.fill where - (p0:p1s) = map pmap [ Point x y1 | (x,(y1,y2)) <- vs ] - p2s = map pmap [ Point x y2 | (x,(y1,y2)) <- vs ] + (p0:p1s) = map pmap [ (x,y1) | (x,(y1,y2)) <- vs ] + p2s = map pmap [ (x,y2) | (x,(y1,y2)) <- vs ] -renderPlotLegendFill :: PlotFillBetween -> Rect -> CRender () +renderPlotLegendFill :: PlotFillBetween x y -> Rect -> CRender () renderPlotLegendFill p r = preserveCState $ do - setFillStyle (plot_fillbetween_style p) + setFillStyle (plot_fillbetween_style_ p) rectPath r c $ C.fill -plotAllPointsFillBetween :: PlotFillBetween -> [Point] -plotAllPointsFillBetween p = concat [ [Point x y1, Point x y2] - | (x,(y1,y2)) <- plot_fillbetween_values p] +plotAllPointsFillBetween :: PlotFillBetween x y -> [(x,y)] +plotAllPointsFillBetween p = concat [ [(x, y1), (x, y2)] + | (x,(y1,y2)) <- plot_fillbetween_values_ p] defaultPlotFillBetween = PlotFillBetween { - plot_fillbetween_style=solidFillStyle (Color 0.5 0.5 1.0), - plot_fillbetween_values=[] + plot_fillbetween_style_=solidFillStyle (Color 0.5 0.5 1.0), + plot_fillbetween_values_=[] } ---------------------------------------------------------------------- -- | Value for holding a point with associated error bounds for -- each axis. -data ErrPoint = ErrPoint { - ep_x :: Double, - ep_y :: Double, - ep_dx :: Double, - ep_dy :: Double + +data ErrValue x = ErrValue { + ev_low :: x, + ev_best :: x, + ev_high :: x } deriving Show +data ErrPoint x y = ErrPoint { + ep_x :: ErrValue x, + ep_y :: ErrValue y +} deriving Show + +-- | When the error is symetric, we can simply pass in dx for the error +symErrPoint x y dx dy = ErrPoint (ErrValue (x-dx) x (x+dx)) + (ErrValue (y-dy) y (y+dy)) + -- | Value defining a series of error intervals, and a style in -- which to render them -data PlotErrBars = PlotErrBars { - plot_errbars_line_style :: CairoLineStyle, - plot_errbars_tick_length :: Double, - plot_errbars_overhang :: Double, - plot_errbars_values :: [ErrPoint] +data PlotErrBars x y = PlotErrBars { + plot_errbars_line_style_ :: CairoLineStyle, + plot_errbars_tick_length_ :: Double, + plot_errbars_overhang_ :: Double, + plot_errbars_values_ :: [ErrPoint x y] } + instance ToPlot PlotErrBars where toPlot p = Plot { - plot_render = renderPlotErrBars p, - plot_render_legend = renderPlotLegendErrBars p, - plot_all_points = map (\(ErrPoint x y _ _) -> Point x y ) $ plot_errbars_values p + plot_render_ = renderPlotErrBars p, + plot_render_legend_ = renderPlotLegendErrBars p, + plot_all_points_ = concat + [[((ev_low x),(ev_low y)), ((ev_high x),(ev_high y))] + | ErrPoint x y <- plot_errbars_values_ p] } -renderPlotErrBars :: PlotErrBars -> PointMapFn -> CRender () +renderPlotErrBars :: PlotErrBars x y -> PointMapFn x y -> CRender () renderPlotErrBars p pmap = preserveCState $ do - mapM_ (drawErrBar.epmap) (plot_errbars_values p) + mapM_ (drawErrBar.epmap) (plot_errbars_values_ p) where - epmap (ErrPoint x y dx dy) = ErrPoint x' y' (abs $ x''-x') (abs $ y''-y') - where (Point x' y') = pmap (Point x y) - (Point x'' y'') = pmap (Point (x+dx) (y+dy)) + epmap (ErrPoint (ErrValue xl x xh) (ErrValue yl y yh)) = + ErrPoint (ErrValue xl' x' xh') (ErrValue yl' y' yh') + where (Point x' y') = pmap (x,y) + (Point xl' yl') = pmap (xl,yl) + (Point xh' yh') = pmap (xh,yh) drawErrBar = drawErrBar0 p -drawErrBar0 ps (ErrPoint x y dx dy) = do - let tl = plot_errbars_tick_length ps - let oh = plot_errbars_overhang ps - setLineStyle (plot_errbars_line_style ps) +drawErrBar0 ps (ErrPoint (ErrValue xl x xh) (ErrValue yl y yh)) = do + let tl = plot_errbars_tick_length_ ps + let oh = plot_errbars_overhang_ ps + setLineStyle (plot_errbars_line_style_ ps) c $ C.newPath - c $ C.moveTo (x-dx-oh) y - c $ C.lineTo (x+dx+oh) y - c $ C.moveTo x (y-dy-oh) - c $ C.lineTo x (y+dy+oh) - c $ C.moveTo (x-dx) (y-tl) - c $ C.lineTo (x-dx) (y+tl) - c $ C.moveTo (x-tl) (y-dy) - c $ C.lineTo (x+tl) (y-dy) - c $ C.moveTo (x+dx) (y-tl) - c $ C.lineTo (x+dx) (y+tl) - c $ C.moveTo (x-tl) (y+dy) - c $ C.lineTo (x+tl) (y+dy) + c $ C.moveTo (xl-oh) y + c $ C.lineTo (xh+oh) y + c $ C.moveTo x (yl-oh) + c $ C.lineTo x (yh+oh) + c $ C.moveTo xl (y-tl) + c $ C.lineTo xl (y+tl) + c $ C.moveTo (x-tl) yl + c $ C.lineTo (x+tl) yl + c $ C.moveTo xh (y-tl) + c $ C.lineTo xh (y+tl) + c $ C.moveTo (x-tl) yh + c $ C.lineTo (x+tl) yh c $ C.stroke -renderPlotLegendErrBars :: PlotErrBars -> Rect -> CRender () +renderPlotLegendErrBars :: PlotErrBars x y -> Rect -> CRender () renderPlotLegendErrBars p r@(Rect p1 p2) = preserveCState $ do - drawErrBar (ErrPoint (p_x p1) ((p_y p1 + p_y p2)/2) dx dx ) - drawErrBar (ErrPoint ((p_x p1 + p_x p2)/2) ((p_y p1 + p_y p2)/2) dx dx) - drawErrBar (ErrPoint (p_x p2) ((p_y p1 + p_y p2)/2) dx dx) + drawErrBar (symErrPoint (p_x p1) ((p_y p1 + p_y p2)/2) dx dx ) + drawErrBar (symErrPoint ((p_x p1 + p_x p2)/2) ((p_y p1 + p_y p2)/2) dx dx) + drawErrBar (symErrPoint (p_x p2) ((p_y p1 + p_y p2)/2) dx dx) where drawErrBar = drawErrBar0 p dx = min ((p_x p2 - p_x p1)/6) ((p_y p2 - p_y p1)/2) defaultPlotErrBars = PlotErrBars { - plot_errbars_line_style = solidLine 1 blue, - plot_errbars_tick_length = 3, - plot_errbars_overhang = 0, - plot_errbars_values = [] + plot_errbars_line_style_ = solidLine 1 blue, + plot_errbars_tick_length_ = 3, + plot_errbars_overhang_ = 0, + plot_errbars_values_ = [] } + +---------------------------------------------------------------------- +-- Template haskell to derive an instance of Data.Accessor.Accessor for each field +$( deriveAccessors ''Plot ) +$( deriveAccessors ''PlotLines ) +$( deriveAccessors ''PlotPoints ) +$( deriveAccessors ''PlotFillBetween ) +$( deriveAccessors ''PlotErrBars ) 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 @@ -3,116 +3,163 @@ -- Module : Graphics.Rendering.Chart.Renderable -- Copyright : (c) Tim Docker 2006 -- License : BSD-style (see chart/COPYRIGHT) +-- +-- This module contains the definition of the 'Renderable' type, which +-- is a composable drawing element, along with assorted functions to +-- them. +-- -module Graphics.Rendering.Chart.Renderable where +module Graphics.Rendering.Chart.Renderable( + Renderable(..), + ToRenderable(..), + PickFn, + renderableToPNGFile, + renderableToPDFFile, + renderableToPSFile, + renderableToSVGFile, + + vectorEnv, + bitmapEnv, + + fillBackground, + addMargins, + emptyRenderable, + embedRenderable, + label, + rlabel, + spacer, + spacer1, + setPickFn, + mapPickFn, + nullPickFn, + + rect_minsize, + rect_fillStyle, + rect_lineStyle, + rect_cornerStyle, +) where + import qualified Graphics.Rendering.Cairo as C import Control.Monad -import Data.List ( nub, partition, transpose, sort ) +import Data.Accessor +import Data.List ( nub, transpose, sort ) import Graphics.Rendering.Chart.Types -import Graphics.Rendering.Chart.Plot +-- | A function that maps a point in device coordinates +-- to some value. +-- +-- Perhaps it might be generalised from Maybe a to +-- (MonadPlus m ) => m a in the future. +type PickFn a = Point -> (Maybe a) + +nullPickFn :: PickFn a +nullPickFn = const Nothing + -- | A Renderable is a record of functions required to layout a -- graphic element. -data Renderable = Renderable { +data Renderable a = Renderable { -- | a Cairo action to calculate a minimum size, minsize :: CRender RectSize, - -- | a Cairo action for drawing it within a specified rectangle. - render :: Rect -> CRender () + -- | a Cairo action for drawing it within a rectangle. + -- The rectangle is from the origin to the given point. + -- + -- The resulting "pick" function maps a point in the image to + -- a value. + render :: RectSize -> CRender (PickFn a) } -- | A type class abtracting the conversion of a value to a -- Renderable. class ToRenderable a where - toRenderable :: a -> Renderable + toRenderable :: a -> Renderable () emptyRenderable = spacer (0,0) +-- | Create a blank renderable with a specified minimum size +spacer :: RectSize -> Renderable a spacer sz = Renderable { minsize = return sz, - render = \_ -> return () + render = \_ -> return nullPickFn } -addMargins :: (Double,Double,Double,Double) -> Renderable -> Renderable + +-- | Create a blank renderable with a minimum size the same as +-- some other renderable. +spacer1 :: Renderable a -> Renderable b +spacer1 r = Renderable { + minsize = minsize r, + render = \_ -> return nullPickFn +} + +-- | Replace the pick function of a renderable with another +setPickFn :: PickFn b -> Renderable a -> Renderable b +setPickFn pickfn r = Renderable { + minsize=minsize r, + render = \sz -> do { render r sz; return pickfn; } + } + +-- | Map a function over result of a renderables pickfunction. +mapPickFn :: (a -> b) -> Renderable a -> Renderable b +mapPickFn f r = Renderable { + minsize=minsize r, + render = \sz -> do { + pf <- render r sz; + return (\p -> fmap f (pf p)); + } + } + +-- | Add some spacing at the edges of a renderable. +addMargins :: (Double,Double,Double,Double) -- ^ The spacing to be added + -> Renderable a -- ^ The source renderable + -> Renderable a 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))) + rf (w,h) = do + preserveCState $ do + c $ C.translate l t + pickf <- render rd (w-l-r,h-t-b) + mtx <- c $ C.getMatrix + return (mkpickf pickf (w,h) mtx) -fillBackground :: CairoFillStyle -> Renderable -> Renderable + mkpickf pickf (w,h) mtx pt | within pt' rect = pickf pt' + | otherwise = Nothing + where + pt' = transform mtx pt + rect = (Rect (Point 0 0) (Point w h)) + +transform :: C.Matrix -> Point -> Point +transform = undefined + +-- | Overlay a renderable over a solid background fill. +fillBackground :: CairoFillStyle -> Renderable a -> Renderable a fillBackground fs r = Renderable { minsize = minsize r, render = rf } where - rf rect@(Rect p1 p2) = do + rf rsize@(w,h) = do preserveCState $ do - setClipRegion p1 p2 + setClipRegion (Point 0 0) (Point w h) setFillStyle fs c $ C.paint - render r rect - -vertical, horizontal :: [(Double,Renderable)] -> Renderable -vertical rs = grid [1] (map fst rs) [[(0,snd r)] | r <- rs] -horizontal rs = grid (map fst rs) [1] [[(0,snd r) | r <- rs]] - --- | Layout multiple Renderables into a grid. --- Arg 1 is the weights for the allocation of extra horizontal space --- to columns, Arg 2 is the weights for the allocation of extra --- vertical space to rows, and Arg 3 is the grid of renderables to be --- layed out. Each element of the grid is a tuple - the first item of --- the tuple is the drawing priority. Lower priorities get drawn --- first. Drawing order is significant when Renderables draw outside --- their edges. -grid :: [Double] -> [Double] -> [[(Int,Renderable)]] -> Renderable -grid we he rss = Renderable { minsize = mf, render = rf } - where - mf = do - msizes <- getSizes - let widths = (map.map) fst msizes - let heights = (map.map) snd msizes - return ((sum.map maximum.transpose) widths,(sum.map maximum) heights) - - rf (Rect p1 p2) = do - msizes <- getSizes - let widths = (map maximum.(map.map) fst.transpose) msizes - let heights = (map maximum.(map.map) snd) msizes - let widths1 = allocate (p_x p2 - p_x p1 - sum widths) we widths - let heights1 = allocate (p_y p2 - p_y p1 - sum heights) he heights - let xs = scanl (+) (p_x p1) widths1 - let ys = scanl (+) (p_y p1) heights1 - - forM_ priorities $ \pr-> - forM_ (zip3 rss ys (tail ys)) $ \(rs,y0,y1) -> - forM_ (zip3 rs xs (tail xs)) $ \((n,r),x0,x1) -> - when (n==pr) $ render r (Rect (Point x0 y0) (Point x1 y1)) - - getSizes = (mapM.mapM) (\(n,r)-> minsize r) rss - priorities = sort (nub ((concatMap.map) fst rss)) - -allocate :: Double -> [Double] -> [Double] -> [Double] -allocate extra ws vs = zipWith (+) vs (extras++[0,0..]) - where - total = sum ws - extras = [ extra * v / total | v <- ws ] + render r rsize -- | Output the given renderable to a PNG file of the specifed size -- (in pixels), to the specified file. -renderableToPNGFile :: Renderable -> Int -> Int -> FilePath -> IO () +renderableToPNGFile :: Renderable a -> Int -> Int -> FilePath -> IO () renderableToPNGFile chart width height path = C.withImageSurface C.FormatARGB32 width height $ \result -> do C.renderWith result $ runCRender rfn bitmapEnv C.surfaceWriteToPNG result path where rfn = do - render chart rect - - rect = Rect (Point 0 0) (Point (fromIntegral width) (fromIntegral height)) + render chart (fromIntegral width, fromIntegral height) renderableToFile withSurface chart width height path = withSurface path (fromIntegral width) (fromIntegral height) $ \result -> do @@ -120,34 +167,34 @@ C.surfaceFinish result where rfn = do - render chart rect + render chart (fromIntegral width, fromIntegral height) c $ C.showPage - rect = Rect (Point 0 0) (Point (fromIntegral width) (fromIntegral height)) - -- | Output the given renderable to a PDF file of the specifed size -- (in points), to the specified file. -renderableToPDFFile :: Renderable -> Int -> Int -> FilePath -> IO () +renderableToPDFFile :: Renderable a -> Int -> Int -> FilePath -> IO () renderableToPDFFile = renderableToFile C.withPDFSurface -- | Output the given renderable to a postscript file of the specifed size -- (in points), to the specified file. -renderableToPSFile :: Renderable -> Int -> Int -> FilePath -> IO () +renderableToPSFile :: Renderable a -> Int -> Int -> FilePath -> IO () renderableToPSFile = renderableToFile C.withPSSurface -- | Output the given renderable to an SVG file of the specifed size -- (in points), to the specified file. -renderableToSVGFile :: Renderable -> Int -> Int -> FilePath -> IO () +renderableToSVGFile :: Renderable a -> Int -> Int -> FilePath -> IO () renderableToSVGFile = renderableToFile C.withSVGSurface bitmapEnv = CEnv adjfn where adjfn (Point x y)= Point (adj x) (adj y) - adj x = (fromIntegral (round (x-0.5)))+0.5 + adj x = (fromIntegral.round) x + 0.5 vectorEnv = CEnv id -embedRenderable :: CRender Renderable -> Renderable +-- | Helper function for using a renderable, when we generate it +-- in the CRender monad. +embedRenderable :: CRender (Renderable a) -> Renderable a embedRenderable ca = Renderable { minsize = do { a <- ca; minsize a }, render = \ r -> do { a <- ca; render a r } @@ -155,88 +202,31 @@ ---------------------------------------------------------------------- --- Legend - -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 -> CRender RectSize -minsizeLegend (Legend _ ls plots) = do - let labels = nub $ map fst plots - setFontStyle $ legend_label_style ls - 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 * (n-1) - return (w,h) - -renderLegend :: Legend -> Rect -> CRender () -renderLegend (Legend _ ls plots) (Rect rp1 rp2) = do - foldM_ rf rp1 $ join_nub plots - where - lm = legend_margin ls - lps = legend_plot_size ls - - rf :: Point -> (String,[Plot]) -> CRender Point - rf p1 (label,theseplots) = do - setFontStyle $ legend_label_style ls - (w,h) <- textSize label - lgap <- legendSpacer - let p2 = (p1 `pvadd` Vector lps 0) - mapM_ (\p -> plot_render_legend p (mkrect p1 rp1 p2 rp2)) theseplots - let p3 = Point (p_x p2 + lgap) (p_y rp1) - drawText HTA_Left VTA_Top p3 label - return (p3 `pvadd` Vector (w+lm) 0) - join_nub :: [(String, a)] -> [(String, [a])] - join_nub ((x,a1):ys) = case partition ((==x) . fst) ys of - (xs, rest) -> (x, a1:map snd xs) : join_nub rest - join_nub [] = [] - -legendSpacer = do - (lgap,_) <- textSize "X" - return lgap - -defaultLegendStyle = LegendStyle { - legend_label_style=defaultFontStyle, - legend_margin=20, - legend_plot_size=20 -} - - ----------------------------------------------------------------------- -- Labels -label :: CairoFontStyle -> HTextAnchor -> VTextAnchor -> String -> Renderable +-- | Construct a renderable from a text string, aligned with the axes +label :: CairoFontStyle -> HTextAnchor -> VTextAnchor -> String -> Renderable a label fs hta vta = rlabel fs hta vta 0 -rlabel :: CairoFontStyle -> HTextAnchor -> VTextAnchor -> Double -> String -> Renderable +-- | Construct a renderable from a text string, rotated wrt to axes. The angle +-- of rotation is in degrees. +rlabel :: CairoFontStyle -> HTextAnchor -> VTextAnchor -> Double -> String -> Renderable a rlabel fs hta vta rot s = Renderable { minsize = mf, render = rf } where mf = preserveCState $ do setFontStyle fs (w,h) <- textSize s return (w*acr+h*asr,w*asr+h*acr) - rf (Rect p1 p2) = preserveCState $ do + rf (w0,h0) = preserveCState $ do setFontStyle fs sz@(w,h) <- textSize s - c $ C.translate (xadj sz hta (p_x p1) (p_x p2)) (yadj sz vta (p_y p1) (p_y p2)) + fe <- c $ C.fontExtents + c $ C.translate 0 (-C.fontExtentsDescent fe) + c $ C.translate (xadj sz hta 0 w0) (yadj sz vta 0 h0) c $ C.rotate rot' c $ C.moveTo (-w/2) (h/2) c $ C.showText s + return nullPickFn xadj (w,h) HTA_Left x1 x2 = x1 +(w*acr+h*asr)/2 xadj (w,h) HTA_Centre x1 x2 = (x1 + x2)/2 xadj (w,h) HTA_Right x1 x2 = x2 -(w*acr+h*asr)/2 @@ -248,25 +238,88 @@ (cr,sr) = (cos rot', sin rot') (acr,asr) = (abs cr, abs sr) --- a quick test to display labels with all combinations --- of anchors -labelTest rot = renderableToPNGFile r 800 800 "labels.png" - where - r = fillBackground fwhite $ grid [1,1,1] [1,1,1] ls - ls = [ [(0,addMargins (20,20,20,20) $ fillBackground fblue $ crossHairs $ rlabel fs h v rot s) | h <- hs] | v <- vs ] - s = "Labels" - hs = [HTA_Left, HTA_Centre, HTA_Right] - vs = [VTA_Top, VTA_Centre, VTA_Bottom] - fwhite = solidFillStyle white - fblue = solidFillStyle (Color 0.8 0.8 1) - fs = defaultFontStyle{font_size=30,font_weight=C.FontWeightBold} - crossHairs r =Renderable { - minsize = minsize r, - render = \rect@(Rect (Point x1 y1) (Point x2 y2)) -> do - let xa = (x1 + x2) / 2 - let ya = (y1 + y2) / 2 - strokeLines [Point x1 ya,Point x2 ya] - strokeLines [Point xa y1,Point xa y2] - render r rect - } - +---------------------------------------------------------------------- +-- Rectangles + +data RectCornerStyle = RCornerSquare + | RCornerBevel Double + | RCornerRounded Double + +data Rectangle = Rectangle { + rect_minsize_ :: RectSize, + rect_fillStyle_ :: Maybe CairoFillStyle, + rect_lineStyle_ :: Maybe CairoLineStyle, + rect_cornerStyle_ :: RectCornerStyle +} + +-- | Accessor for field rect_minsize_ +rect_minsize = accessor (\v->rect_minsize_ v) (\a v -> v{rect_minsize_=a}) + +-- | Accessor for field rect_fillStyle_ +rect_fillStyle = accessor (\v->rect_fillStyle_ v) (\a v -> v{rect_fillStyle_=a}) + +-- | Accessor for field rect_lineStyle_ +rect_lineStyle = accessor (\v->rect_lineStyle_ v) (\a v -> v{rect_lineStyle_=a}) + +-- | Accessor for field rect_cornerStyle_ +rect_cornerStyle = accessor (\v->rect_cornerStyle_ v) (\a v -> v{rect_cornerStyle_=a}) + + +defaultRectangle = Rectangle { + rect_minsize_ = (0,0), + rect_fillStyle_ = Nothing, + rect_lineStyle_ = Nothing, + rect_cornerStyle_ = RCornerSquare +} + +instance ToRenderable Rectangle where + toRenderable rectangle = Renderable mf rf + where + mf = return (rect_minsize_ rectangle) + rf sz = preserveCState $ do + maybeM () (fill sz) (rect_fillStyle_ rectangle) + maybeM () (stroke sz) (rect_lineStyle_ rectangle) + return nullPickFn + + fill sz fs = do + setFillStyle fs + strokeRectangle sz (rect_cornerStyle_ rectangle) + c $ C.fill + + stroke sz ls = do + setLineStyle ls + strokeRectangle sz (rect_cornerStyle_ rectangle) + c $ C.stroke + + strokeRectangle (x2,y2) RCornerSquare = c $ do + let (x1,y1) = (0,0) + C.moveTo x1 y1 + C.lineTo x1 y2 + C.lineTo x2 y2 + C.lineTo x2 y1 + C.lineTo x1 y1 + C.lineTo x1 y2 + + strokeRectangle (x2,y2) (RCornerBevel s) = c $ do + let (x1,y1) = (0,0) + C.moveTo x1 (y1+s) + C.lineTo x1 (y2-s) + C.lineTo (x1+s) y2 + C.lineTo (x2-s) y2 + C.lineTo x2 (y2-s) + C.lineTo x2 (y1+s) + C.lineTo (x2-s) y1 + C.lineTo (x1+s) y1 + C.lineTo x1 (y1+s) + C.lineTo x1 (y2-s) + + strokeRectangle (x2,y2) (RCornerRounded s) = c $ do + let (x1,y1) = (0,0) + C.arcNegative (x1+s) (y2-s) s (pi2*2) pi2 + C.arcNegative (x2-s) (y2-s) s pi2 0 + C.arcNegative (x2-s) (y1+s) s 0 (pi2*3) + C.arcNegative (x1+s) (y1+s) s (pi2*3) (pi2*2) + C.lineTo x1 (y2-s) + + pi2 = pi / 2 + diff --git a/Graphics/Rendering/Chart/Simple.hs b/Graphics/Rendering/Chart/Simple.hs --- a/Graphics/Rendering/Chart/Simple.hs +++ b/Graphics/Rendering/Chart/Simple.hs @@ -22,7 +22,7 @@ -- -- Examples: -- --- @renderableToWindow (toRenderable $ plot [0,0.1..10] sin "sin(x)") 640 480@ +-- @renderableToWindow (toRenderable $ plotLayout $ plot [0,0.1..10] sin "sin(x)") 640 480@ -- -- @plotWindow [0,1,3,4,8]] [12,15,1,5,8] "o" "points"@ -- @@ -31,7 +31,8 @@ -- @plotPS "foo.ps" [0,0.1..10] (sin.exp) "- " (sin.exp) "o-"@ ----------------------------------------------------------------------------- module Graphics.Rendering.Chart.Simple( plot, PlotKind(..), xcoords, - plotWindow, plotPDF, plotPS + plotWindow, plotPDF, plotPS, + plotLayout ) where import Data.Maybe ( catMaybes ) @@ -50,9 +51,11 @@ where symbolSequence = cycle [ Ex, HollowCircle, Square, Diamond, Triangle, DownTriangle, Plus, Star, FilledCircle ] -iplot :: [InternalPlot] -> Layout1 +-- When defaultLayout1 has been generalized, change this signature to +-- [InternalPlot x y] -> Layout1 x y z +iplot :: [InternalPlot Double Double] -> Layout1 Double Double iplot foobar = defaultLayout1 { - layout1_plots = concat $ zipWith toplot (ip foobar) [0..] + layout1_plots_ = concat $ zipWith toplot (ip foobar) [0..] } where ip (xs@(IPX _ _):xyss) = map (\ys -> (xs,ys)) yss ++ ip rest where yss = takeWhile isIPY xyss @@ -61,52 +64,51 @@ ip [] = [] isIPY (IPY _ _) = True isIPY _ = False - toplot (IPX xs _, IPY ys yks) ind = map (\z -> (name yks, HA_Bottom, VA_Left, z)) plots - where vs = map (\(x,y) -> Point x y) $ filter isOkay $ zip xs ys + toplot (IPX xs _, IPY ys yks) ind = map (\z -> (name yks, Left z)) plots + where vs = zip xs ys plots = case catMaybes $ map plotas yks of [] -> [toPlot $ defaultPlotLines - { plot_lines_values = [vs], - plot_lines_style = solidLine 1 (styleColor ind) }] + { plot_lines_values_ = [vs], + plot_lines_style_ = solidLine 1 (styleColor ind) }] xs -> xs plotas Solid = Just $ toPlot $ defaultPlotLines - { plot_lines_values = [vs], - plot_lines_style = solidLine 1 (styleColor ind) } + { plot_lines_values_ = [vs], + plot_lines_style_ = solidLine 1 (styleColor ind) } plotas Dashed = Just $ toPlot $ defaultPlotLines - { plot_lines_values = [vs], - plot_lines_style = dashedLine 1 [10,10] (styleColor ind) } + { plot_lines_values_ = [vs], + plot_lines_style_ = dashedLine 1 [10,10] (styleColor ind) } plotas Dotted = Just $ toPlot $ defaultPlotLines - { plot_lines_values = [vs], - plot_lines_style = dashedLine 1 [1,11] (styleColor ind) } + { plot_lines_values_ = [vs], + plot_lines_style_ = dashedLine 1 [1,11] (styleColor ind) } plotas FilledCircle = Just $ toPlot $ defaultPlotPoints - { plot_points_values = vs, - plot_points_style=filledCircles 4 (styleColor ind) } + { plot_points_values_ = vs, + plot_points_style_=filledCircles 4 (styleColor ind) } plotas HollowCircle = Just $ toPlot $ defaultPlotPoints - { plot_points_values = vs, - plot_points_style=hollowCircles 5 1 (styleColor ind) } + { plot_points_values_ = vs, + plot_points_style_=hollowCircles 5 1 (styleColor ind) } plotas Triangle = Just $ toPlot $ defaultPlotPoints - { plot_points_values = vs, - plot_points_style=hollowPolygon 7 1 3 False (styleColor ind) } + { plot_points_values_ = vs, + plot_points_style_=hollowPolygon 7 1 3 False (styleColor ind) } plotas DownTriangle = Just $ toPlot $ defaultPlotPoints - { plot_points_values = vs, - plot_points_style=hollowPolygon 7 1 3 True (styleColor ind) } + { plot_points_values_ = vs, + plot_points_style_=hollowPolygon 7 1 3 True (styleColor ind) } plotas Square = Just $ toPlot $ defaultPlotPoints - { plot_points_values = vs, - plot_points_style=hollowPolygon 7 1 4 False (styleColor ind) } + { plot_points_values_ = vs, + plot_points_style_=hollowPolygon 7 1 4 False (styleColor ind) } plotas Diamond = Just $ toPlot $ defaultPlotPoints - { plot_points_values = vs, - plot_points_style=hollowPolygon 7 1 4 True (styleColor ind) } + { plot_points_values_ = vs, + plot_points_style_=hollowPolygon 7 1 4 True (styleColor ind) } plotas Plus = Just $ toPlot $ defaultPlotPoints - { plot_points_values = vs, - plot_points_style=plusses 7 1 (styleColor ind) } + { plot_points_values_ = vs, + plot_points_style_=plusses 7 1 (styleColor ind) } plotas Ex = Just $ toPlot $ defaultPlotPoints - { plot_points_values = vs, - plot_points_style=exes 7 1 (styleColor ind) } + { plot_points_values_ = vs, + plot_points_style_=exes 7 1 (styleColor ind) } plotas Star = Just $ toPlot $ defaultPlotPoints - { plot_points_values = vs, - plot_points_style=stars 7 1 (styleColor ind) } + { plot_points_values_ = vs, + plot_points_style_=stars 7 1 (styleColor ind) } plotas Symbols = plotas (styleSymbol ind) plotas _ = Nothing - isOkay (_,n) = not (isNaN n || isInfinite n) name :: [PlotKind] -> String name (Name s:_) = s @@ -141,15 +143,19 @@ | Triangle | DownTriangle | Square | Diamond | Plus | Ex | Star | Symbols | LittleDot | Dashed | Dotted | Solid deriving ( Eq, Show, Ord ) -data InternalPlot = IPY [Double] [PlotKind] | IPX [Double] [PlotKind] +data InternalPlot x y = IPY [y] [PlotKind] | IPX [x] [PlotKind] -uplot :: [UPlot] -> Layout1 -uplot us = iplot $ nameDoubles $ evalfuncs us - where nameDoubles :: [UPlot] -> [InternalPlot] +newtype Layout1DDD = Layout1DDD { plotLayout :: Layout1 Double Double } +instance ToRenderable Layout1DDD where + toRenderable = toRenderable . plotLayout + +uplot :: [UPlot] -> Layout1DDD +uplot us = Layout1DDD $ iplot $ nameDoubles $ evalfuncs us + where nameDoubles :: [UPlot] -> [InternalPlot Double Double] nameDoubles (X xs:uus) = case grabName uus of - (ks,uus') -> IPX xs ks : nameDoubles uus' + (ks,uus') -> IPX (filter isValidNumber xs) ks : nameDoubles uus' nameDoubles (UDoubles xs:uus) = case grabName uus of - (ks,uus') -> IPY xs ks : nameDoubles uus' + (ks,uus') -> IPY (filter isValidNumber xs) ks : nameDoubles uus' nameDoubles (_:uus) = nameDoubles uus nameDoubles [] = [] evalfuncs :: [UPlot] -> [UPlot] @@ -183,7 +189,7 @@ pl :: [UPlot] -> t instance (PlotArg a, PlotType r) => PlotType (a -> r) where pl args = \ a -> pl (toUPlot a ++ args) -instance PlotType Layout1 where +instance PlotType Layout1DDD where pl args = uplot (reverse args) -- | Display a plot on the screen. diff --git a/Graphics/Rendering/Chart/Types.hs b/Graphics/Rendering/Chart/Types.hs --- a/Graphics/Rendering/Chart/Types.hs +++ b/Graphics/Rendering/Chart/Types.hs @@ -1,14 +1,115 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# OPTIONS_GHC -XTemplateHaskell #-} + ----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Chart.Types -- Copyright : (c) Tim Docker 2006 -- 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 'Data.Accessor') for each field of the following data types: +-- +-- * 'CairoLineStyle' +-- +-- * 'CairoFontStyle' +-- +-- 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 :: Data.Accessor.Accessor D F +-- @ +-- -module Graphics.Rendering.Chart.Types where +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 -- | A point in two dimensions data Point = Point { @@ -44,7 +145,7 @@ psub (Point x1 y1) (Point x2 y2) = (Vector (x1-x2) (y1-y2)) -- | a function mapping between points -type PointMapFn = Point -> Point +type PointMapFn x y = (x,y) -> Point -- | A rectangle is defined by two points data Rect = Rect Point Point @@ -53,13 +154,16 @@ data RectEdge = E_Top | E_Bottom | E_Left | E_Right -- | Create a rectangle based upon the coordinates of 4 points +mkrect :: Point -> Point -> Point -> Point -> Rect mkrect (Point x1 _) (Point _ y2) (Point x3 _) (Point _ y4) = Rect (Point x1 y2) (Point x3 y4) --- | A linear mapping of points in one range to another -vmap :: Range -> Range -> Double -> Double -vmap (v1,v2) (v3,v4) v = v3 + (v-v1) * (v4-v3) / (v2-v1) +-- | Test if a point is within a rectangle +within :: Point -> Rect -> Bool +within (Point x y) (Rect (Point x1 y1) (Point x2 y2)) = + x >= x1 && x <= x2 && y >= y1 && y <= y2 + ---------------------------------------------------------------------- -- | The environment present in the CRender Monad. @@ -74,6 +178,8 @@ cenv_point_alignfn :: Point -> Point } +-- | The reader monad containing context information to control +-- the rendering process. newtype CRender a = DR (ReaderT CEnv C.Render a) deriving (Functor, Monad, MonadReader CEnv) @@ -93,13 +199,13 @@ -- | Data type for the style of a line data CairoLineStyle = CairoLineStyle { - line_width :: Double, - line_color :: Color, - line_dashes :: [Double], - line_cap :: C.LineCap, - line_join :: C.LineJoin + line_width_ :: Double, + line_color_ :: Color, + line_dashes_ :: [Double], + line_cap_ :: C.LineCap, + line_join_ :: C.LineJoin } - + -- | Abstract data type for a fill style -- -- The contained Cairo action sets the required fill @@ -108,11 +214,11 @@ -- | Data type for a font data CairoFontStyle = CairoFontStyle { - font_name :: String, - font_size :: Double, - font_slant :: C.FontSlant, - font_weight :: C.FontWeight, - font_color :: Color + font_name_ :: String, + font_size_ :: Double, + font_slant_ :: C.FontSlant, + font_weight_ :: C.FontWeight, + font_color_ :: Color } type Range = (Double,Double) @@ -171,16 +277,16 @@ 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) + 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 + 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 @@ -188,6 +294,8 @@ setSourceColor (Color r g b) = C.setSourceRGB r g b +-- | Return the bounding rectancgle for a text string rendered +-- in the current context. textSize :: String -> CRender RectSize textSize s = c $ do te <- C.textExtents s @@ -373,11 +481,19 @@ defaultPointStyle = filledCircles 1 white defaultFontStyle = CairoFontStyle { - font_name = "sans", - font_size = 10, - font_slant = C.FontSlantNormal, - font_weight = C.FontWeightNormal, - font_color = black + 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) + +---------------------------------------------------------------------- +-- Template haskell to derive an instance of Data.Accessor.Accessor for each field +$( deriveAccessors ''CairoLineStyle ) +$( deriveAccessors ''CairoFontStyle ) + diff --git a/tests/test.hs b/tests/test.hs --- a/tests/test.hs +++ b/tests/test.hs @@ -2,11 +2,15 @@ import Graphics.Rendering.Chart import Graphics.Rendering.Chart.Simple import Graphics.Rendering.Chart.Gtk +import Graphics.Rendering.Chart.Grid + import System.Environment(getArgs) import System.Time import System.Random import Data.Time.Calendar import Data.Time.LocalTime +import Data.Accessor +import Data.Accessor.Tuple import Prices data OutputType = Window | PNG | PS | PDF | SVG @@ -17,186 +21,154 @@ chooseLineWidth PS = 0.25 chooseLineWidth SVG = 0.25 -blue = (Color 0 0 1) -green = (Color 0 1 0) green1 = (Color 0.5 1 0.5) -red = (Color 1 0 0) red1 = (Color 0.5 0.5 1) ---------------------------------------------------------------------- -test1 :: OutputType -> IO Renderable -test1 otype = return (toRenderable layout) +test1 :: OutputType -> Renderable () +test1 otype = toRenderable layout where am :: Double -> Double am x = (sin (x*3.14159/45) + 1) / 2 * (sin (x*3.14159/5)) - sinusoid1 = defaultPlotLines { - plot_lines_values = [[ (Point x (am x)) | x <- [0,(0.5)..400]]], - plot_lines_style = solidLine lineWidth blue - } + sinusoid1 = plot_lines_values ^= [[ (x,(am x)) | x <- [0,(0.5)..400]]] + $ plot_lines_style ^= solidLine lineWidth blue + $ defaultPlotLines - sinusoid2 = defaultPlotPoints { - plot_points_style=filledCircles 2 red, - plot_points_values = [ (Point x (am x)) | x <- [0,7..400]] - } + sinusoid2 = plot_points_style ^= filledCircles 2 red + $ plot_points_values ^= [ (x,(am x)) | x <- [0,7..400]] + $ defaultPlotPoints - layout = defaultLayout1 { - layout1_title="Amplitude Modulation", - layout1_horizontal_axes=linkedAxes (autoScaledAxis defaultAxis), - layout1_vertical_axes=linkedAxes (autoScaledAxis defaultAxis), - layout1_plots = [("am",HA_Bottom,VA_Left,(toPlot sinusoid1)), - ("am points", HA_Bottom,VA_Left,(toPlot sinusoid2))] - } + layout = layout1_title ^= "Amplitude Modulation" + $ layout1_plots ^= [("am",Left (toPlot sinusoid1)), + ("am points", Left (toPlot sinusoid2))] + $ defaultLayout1 lineWidth = chooseLineWidth otype - -test1a :: OutputType -> IO Renderable -test1a otype = return (toRenderable layout) +test1a :: OutputType -> Renderable () +test1a otype = toRenderable layout where am :: Double -> Double am x = (sin (x*3.14159/45) + 1) / 2 * (sin (x*3.14159/5)) - sinusoid1 = defaultPlotLines { - plot_lines_values = [[ (Point x (am x)) | x <- [0,(0.5)..400]]], - plot_lines_style = solidLine lineWidth blue - } + sinusoid1 = plot_lines_values ^= [[ (x,(am x)) | x <- [0,(0.5)..400]]] + $ plot_lines_style ^= solidLine lineWidth blue + $ defaultPlotLines - sinusoid2 = defaultPlotPoints { - plot_points_style=filledCircles 2 red, - plot_points_values = [ (Point x (am x)) | x <- [0,7..400]] - } + sinusoid2 = plot_points_style ^= filledCircles 2 red + $ plot_points_values ^= [ (x,(am x)) | x <- [0,7..400]] + $ defaultPlotPoints - lap = defaultLinearAxis{la_nLabels=2,la_nTicks=20,la_gridAtMinor=True} + axis = mAxis $ axisGridAtTicks.autoScaledAxis ( + la_nLabels ^= 2 + $ la_nTicks ^= 20 + $ defaultLinearAxis + ) - layout = defaultLayout1 { - layout1_title="Amplitude Modulation", - layout1_horizontal_axes=linkedAxes (autoScaledAxis' lap defaultAxis), - layout1_vertical_axes=linkedAxes (autoScaledAxis' lap defaultAxis), - layout1_plots = [("am",HA_Bottom,VA_Left,(toPlot sinusoid1)), - ("am points", HA_Bottom,VA_Left,(toPlot sinusoid2))] - } + layout = layout1_title ^= "Amplitude Modulation" + $ updateXAxesData (const axis) + $ updateYAxesData (const axis) + $ layout1_plots ^= [("am",Left (toPlot sinusoid1)), + ("am points", Left (toPlot sinusoid2))] + $ defaultLayout1 lineWidth = chooseLineWidth otype ---------------------------------------------------------------------- -test2 :: [(Int,Int,Int,Double,Double)] -> OutputType -> IO Renderable -test2 prices otype = return (toRenderable layout) +test2 :: [(Int,Int,Int,Double,Double)] -> OutputType -> Renderable () +test2 prices otype = toRenderable layout where - lineStyle c = (plot_lines_style defaultPlotLines){ - line_width=3 * chooseLineWidth otype, - line_color = c - } - - price1 = defaultPlotLines { - plot_lines_style = lineStyle blue, - plot_lines_values = [[ Point (date d m y) v | (d,m,y,v,_) <- prices]] - } + lineStyle c = line_width ^= 3 * chooseLineWidth otype + $ line_color ^= c + $ defaultPlotLines ^. plot_lines_style - price2 = defaultPlotLines { - plot_lines_style = lineStyle green, - plot_lines_values = [[ Point (date d m y) v | (d,m,y,_,v) <- prices]] - } + price1 = plot_lines_style ^= lineStyle blue + $ plot_lines_values ^= [[ ((date d m y), v) | (d,m,y,v,_) <- prices]] + $ defaultPlotLines - baseAxis = defaultAxis{ - axis_grid=[], - axis_line_style=solidLine 1 fg, - axis_grid_style=solidLine 1 fg1, - axis_label_style=(axis_label_style defaultAxis){font_color=fg} - } + price2 = plot_lines_style ^= lineStyle green + $ plot_lines_values ^= [[ ((date d m y), v) | (d,m,y,_,v) <- prices]] + $ defaultPlotLines - vaxis = autoScaledAxis baseAxis + vaxis = mAxis $ axisGridNone.autoAxis bg = Color 0 0 0.25 fg = Color 1 1 1 fg1 = Color 0.0 0.0 0.15 - layout = defaultLayout1 { - layout1_title="Price History", - layout1_title_style=(layout1_title_style defaultLayout1){font_color=fg}, - layout1_background=solidFillStyle bg, - layout1_horizontal_axes=linkedAxes' (autoTimeAxis baseAxis), - layout1_vertical_axes=independentAxes vaxis vaxis, - layout1_plots = [("price 1", HA_Bottom,VA_Left,(toPlot price1)), - ("price 2", HA_Bottom,VA_Right,(toPlot price2))], - layout1_legend = Just (defaultLegendStyle{ - legend_label_style=(legend_label_style defaultLegendStyle){font_color=fg} - } ), - layout1_grid_last=False - } + layout = layout1_title ^="Price History" + $ layout1_background ^= solidFillStyle bg + $ updateAllAxesStyles (axis_grid_style ^= solidLine 1 fg1) + $ layout1_left_axis ^: laxis_data ^= vaxis + $ layout1_right_axis ^: laxis_data ^= vaxis + $ layout1_plots ^= [("price 1", Left (toPlot price1)), + ("price 2", Right (toPlot price2))] + $ layout1_grid_last ^= False + $ setForeground fg + $ defaultLayout1 -date dd mm yyyy = doubleFromLocalTime (LocalTime (fromGregorian (fromIntegral yyyy) mm dd) midnight) +date dd mm yyyy = (LocalTime (fromGregorian (fromIntegral yyyy) mm dd) midnight) ---------------------------------------------------------------------- -test3 :: OutputType -> IO Renderable -test3 otype = return (toRenderable layout) +test3 :: OutputType -> Renderable () +test3 otype = toRenderable layout where - price1 = defaultPlotFillBetween { - plot_fillbetween_style = solidFillStyle green1, - plot_fillbetween_values = [ (date d m y,(0,v2)) | (d,m,y,v1,v2) <- prices] - } + price1 = plot_fillbetween_style ^= solidFillStyle green1 + $ plot_fillbetween_values ^= [ (date d m y,(0,v2)) | (d,m,y,v1,v2) <- prices] + $ defaultPlotFillBetween - price2 = defaultPlotFillBetween { - plot_fillbetween_style = solidFillStyle red1, - plot_fillbetween_values = [ (date d m y,(0,v1)) | (d,m,y,v1,v2) <- prices] - } + price2 = plot_fillbetween_style ^= solidFillStyle red1 + $ plot_fillbetween_values ^= [ (date d m y,(0,v1)) | (d,m,y,v1,v2) <- prices] + $ defaultPlotFillBetween - layout = defaultLayout1 { - layout1_title="Price History", - layout1_horizontal_axes=linkedAxes' (autoTimeAxis defaultAxis), - layout1_vertical_axes=linkedAxes' (autoScaledAxis defaultAxis), - layout1_plots = [("price 1", HA_Bottom,VA_Left,(toPlot price1)), - ("price 2", HA_Bottom,VA_Left,(toPlot price2))] - } + layout = layout1_title ^= "Price History" + $ layout1_plots ^= [("price 1", Left (toPlot price1)), + ("price 2", Left (toPlot price2))] + $ defaultLayout1 ---------------------------------------------------------------------- -test4 :: OutputType -> IO Renderable -test4 otype = return (toRenderable layout) +test4 :: Bool -> Bool -> OutputType -> Renderable () +test4 xrev yrev otype = toRenderable layout where - points = defaultPlotPoints { - plot_points_style=filledCircles 3 red, - plot_points_values = [ Point x (10**x) | x <- [0.5,1,1.5,2,2.5] ] - } - - lines = defaultPlotLines { - plot_lines_values = [ [Point x (10**x) | x <- [0,3]] ] - } + points = plot_points_style ^= filledCircles 3 red + $ plot_points_values ^= [ (x, LogValue (10**x)) | x <- [0.5,1,1.5,2,2.5] ] + $ defaultPlotPoints - layout = defaultLayout1 { - layout1_title="Log/Linear Example", - layout1_horizontal_axes=linkedAxes' (autoScaledAxis defaultAxis{axis_title="horizontal"}), - layout1_vertical_axes=linkedAxes' (autoScaledLogAxis defaultAxis{axis_title="vertical"}), - layout1_plots = [("values",HA_Bottom,VA_Left,(toPlot points)), - ("values",HA_Bottom,VA_Left,(toPlot lines)) ] - } + lines = plot_lines_values ^= [ [(x, LogValue (10**x)) | x <- [0,3]] ] + $ defaultPlotLines + layout = layout1_title ^= "Log/Linear Example" + $ layout1_bottom_axis ^: laxis_title ^= "horizontal" + $ layout1_bottom_axis ^: laxis_reverse ^= xrev + $ layout1_left_axis ^: laxis_title ^= "vertical" + $ layout1_left_axis ^: laxis_reverse ^= yrev + $ layout1_plots ^= [("values",Left (toPlot points)), + ("values",Left (toPlot lines)) ] + $ defaultLayout1 ---------------------------------------------------------------------- -- Example thanks to Russell O'Connor -test5 :: OutputType -> IO Renderable -test5 otype = do - bits <- fmap randoms getStdGen - return (toRenderable (layout 1001 (trial bits))) +test5 :: OutputType -> Renderable () +test5 otype = toRenderable (layout 1001 (trial bits) :: Layout1 Double LogValue) where - layout n t = defaultLayout1 { - layout1_title="Simulation of betting on a biased coin", - layout1_horizontal_axes=linkedAxes (autoScaledAxis defaultAxis), - layout1_vertical_axes=linkedAxes (autoScaledLogAxis defaultAxis), - layout1_plots = [ - ("f=0.05",HA_Bottom,VA_Left,(toPlot (plot s1 n 0 (t 0.05)))), - ("f=0.1",HA_Bottom,VA_Left,(toPlot (plot s2 n 0 (t 0.1))))] - } + bits = randoms $ mkStdGen 0 - plot s n m t = defaultPlotLines { - plot_lines_style = s, - plot_lines_values = - [[Point (fromIntegral x) y | (x,y) <- - filter (\(x,_)->x `mod` (m+1)==0) $ take n $ zip [0..] t]] - } + layout n t = layout1_title ^= "Simulation of betting on a biased coin" + $ layout1_plots ^= [ + ("f=0.05", Left (toPlot (plot s1 n 0 (t 0.05)))), + ("f=0.1", Left (toPlot (plot s2 n 0 (t 0.1))))] + $ defaultLayout1 + plot s n m t = plot_lines_style ^= s + $ plot_lines_values ^= + [[(fromIntegral x, LogValue y) | (x,y) <- + filter (\(x,_)->x `mod` (m+1)==0) $ take n $ zip [0..] t]] + $ defaultPlotLines + b = 0.1 trial bits frac = scanl (*) 1 (map f bits) @@ -213,8 +185,8 @@ ---------------------------------------------------------------------- -- Test the Simple interface -test6 :: OutputType -> IO Renderable -test6 otype = return (toRenderable pp{layout1_title="Graphics.Rendering.Chart.Simple example"}) +test6 :: OutputType -> Renderable () +test6 otype = toRenderable (plotLayout pp){layout1_title_="Graphics.Rendering.Chart.Simple example"} where pp = plot xs sin "sin" cos "cos" "o" @@ -225,41 +197,60 @@ xs = [0,0.3..3] :: [Double] ---------------------------------------------------------------------- -test7 :: OutputType -> IO Renderable -test7 otype = return (toRenderable layout) +test7 :: OutputType -> Renderable () +test7 otype = toRenderable layout where + vals :: [(Double,Double,Double,Double)] vals = [ (x,sin (exp x),sin x/2,cos x/10) | x <- [1..20]] - bars = defaultPlotErrBars { - plot_errbars_values = [ErrPoint x y dx dy | (x,y,dx,dy) <- vals] - } - points = defaultPlotPoints { - plot_points_style=filledCircles 2 red, - plot_points_values = [Point x y | (x,y,dx,dy) <- vals] - } + bars = plot_errbars_values ^= [symErrPoint x y dx dy | (x,y,dx,dy) <- vals] + $ defaultPlotErrBars - layout = defaultLayout1 { - layout1_title= "errorbars example", - layout1_plots = [("test",HA_Bottom,VA_Left,(toPlot bars)), - ("test",HA_Bottom,VA_Left,(toPlot points))] - } + points = plot_points_style ^= filledCircles 2 red + $ plot_points_values ^= [(x,y) | (x,y,dx,dy) <- vals] + $ defaultPlotPoints + layout = layout1_title ^= "errorbars example" + $ layout1_plots ^= [("test",Left (toPlot bars)), + ("test",Left (toPlot points))] + $ defaultLayout1 + ---------------------------------------------------------------------- -test8 :: OutputType -> IO Renderable -test8 otype = return (toRenderable layout) +test8 :: OutputType -> Renderable () +test8 otype = toRenderable layout where values = [ ("eggs",38,e), ("milk",45,e), ("bread",11,e1), ("salmon",8,e) ] e = 0 e1 = 25 - layout = defaultPieLayout { - pie_title = "Pie Chart Example", - pie_plot = defaultPieChart { - pie_data = [ defaultPieItem{pitem_value=v,pitem_label=s,pitem_offset=o} - | (s,v,o) <- values ] - } + layout = pie_title ^= "Pie Chart Example" + $ pie_plot ^: pie_data ^= [ defaultPieItem{pitem_value_=v,pitem_label_=s,pitem_offset_=o} + | (s,v,o) <- values ] + $ defaultPieLayout + +---------------------------------------------------------------------- +-- a quick test to display labels with all combinations +-- of anchors +misc1 rot otype = fillBackground fwhite $ (gridToRenderable t) + where + t = weights (1,1) $ aboveN [ besideN [tval (lb h v) | h <- hs] | v <- vs ] + lb h v = addMargins (20,20,20,20) $ fillBackground fblue $ crossHairs $ rlabel fs h v rot s + s = "Labelling" + hs = [HTA_Left, HTA_Centre, HTA_Right] + vs = [VTA_Top, VTA_Centre, VTA_Bottom] + fwhite = solidFillStyle white + fblue = solidFillStyle (Color 0.8 0.8 1) + fs = defaultFontStyle{font_size_=20,font_weight_=C.FontWeightBold} + crossHairs r =Renderable { + minsize = minsize r, + render = \sz@(w,h) -> do + let xa = w / 2 + let ya = h / 2 + strokeLines [Point 0 ya,Point w ya] + strokeLines [Point xa 0,Point xa h] + render r sz } ---------------------------------------------------------------------- -allTests :: [ (String, OutputType -> IO Renderable) ] +allTests :: [ (String, OutputType -> Renderable ()) ] allTests = [ ("test1", test1) , ("test1a", test1a) @@ -268,11 +259,15 @@ , ("test2c", test2 (filterPrices (date 1 5 2005) (date 1 7 2005))) , ("test2d", test2 (filterPrices (date 1 1 2006) (date 10 1 2006))) , ("test3", test3) - , ("test4", test4) + , ("test4a", test4 False False) + , ("test4b", test4 True False) + , ("test4c", test4 False True) , ("test5", test5) , ("test6", test6) , ("test7", test7) , ("test8", test8) + , ("misc1", misc1 0) + , ("misc1a", misc1 45) ] filterPrices t1 t2 = [ v | v@(d,m,y,_,_) <- prices, let t = date d m y in t >= t1 && t <= t2] @@ -288,15 +283,15 @@ main1 ("--ps":tests) = showTests tests renderToPS main1 tests = showTests tests renderToWindow -showTests :: [String] -> ((String,OutputType -> IO Renderable) -> IO()) -> IO () +showTests :: [String] -> ((String,OutputType -> Renderable ()) -> IO()) -> IO () showTests tests ofn = mapM_ ofn (filter (match tests) allTests) match :: [String] -> (String,a) -> Bool match [] t = True match ts t = (fst t) `elem` ts -renderToWindow (n,ir) = do { r <- ir Window; renderableToWindow r 640 480} -renderToPNG (n,ir) = do { r <- ir PNG; renderableToPNGFile r 640 480 (n ++ ".png")} -renderToPS (n,ir) = do { r <- ir PS; renderableToPSFile r 640 480 (n ++ ".ps")} -renderToPDF (n,ir) = do { r <- ir PDF; renderableToPDFFile r 640 480 (n ++ ".pdf")} -renderToSVG (n,ir) = do { r <- ir SVG; renderableToSVGFile r 640 480 (n ++ ".svg")} +renderToWindow (n,ir) = renderableToWindow (ir Window) 640 480 +renderToPNG (n,ir) = renderableToPNGFile (ir PNG) 640 480 (n ++ ".png") +renderToPS (n,ir) = renderableToPSFile (ir PS) 640 480 (n ++ ".ps") +renderToPDF (n,ir) = renderableToPDFFile (ir PDF) 640 480 (n ++ ".pdf") +renderToSVG (n,ir) = renderableToSVGFile (ir SVG) 640 480 (n ++ ".svg")