Chart 0.8 → 0.9
raw patch · 13 files changed
+1710/−883 lines, 13 filesdep +arraydep +data-accessordep +data-accessor-template
Dependencies added: array, data-accessor, data-accessor-template
Files
- Chart.cabal +6/−4
- Graphics/Rendering/Chart.hs +25/−66
- Graphics/Rendering/Chart/Axis.hs +250/−175
- Graphics/Rendering/Chart/Grid.hs +242/−0
- Graphics/Rendering/Chart/Gtk.hs +4/−6
- Graphics/Rendering/Chart/Layout.hs +278/−107
- Graphics/Rendering/Chart/Legend.hs +75/−0
- Graphics/Rendering/Chart/Pie.hs +104/−41
- Graphics/Rendering/Chart/Plot.hs +168/−96
- Graphics/Rendering/Chart/Renderable.hs +213/−160
- Graphics/Rendering/Chart/Simple.hs +46/−40
- Graphics/Rendering/Chart/Types.hs +145/−29
- tests/test.hs +154/−159
Chart.cabal view
@@ -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
Graphics/Rendering/Chart.hs view
@@ -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
Graphics/Rendering/Chart/Axis.hs view
@@ -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 )
+ Graphics/Rendering/Chart/Grid.hs view
@@ -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))
Graphics/Rendering/Chart/Gtk.hs view
@@ -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
Graphics/Rendering/Chart/Layout.hs view
@@ -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))+
+ Graphics/Rendering/Chart/Legend.hs view
@@ -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 )+
Graphics/Rendering/Chart/Pie.hs view
@@ -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 ) +
Graphics/Rendering/Chart/Plot.hs view
@@ -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 )
Graphics/Rendering/Chart/Renderable.hs view
@@ -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+
Graphics/Rendering/Chart/Simple.hs view
@@ -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.
Graphics/Rendering/Chart/Types.hs view
@@ -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 )+
tests/test.hs view
@@ -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")