diff --git a/Chart.cabal b/Chart.cabal --- a/Chart.cabal +++ b/Chart.cabal @@ -1,5 +1,5 @@ Name: Chart -Version: 0.12 +Version: 0.13 License: BSD3 License-file: LICENSE Copyright: Tim Docker, 2006-2009 @@ -12,7 +12,21 @@ Cabal-Version: >= 1.6 Build-Type: Simple -Extra-Source-Files: tests/test.hs, tests/Prices.hs +Extra-Source-Files: + tests/all_tests.hs, + tests/Test1.hs, + tests/Test2.hs, + tests/Test3.hs, + tests/Test4.hs, + tests/Test5.hs, + tests/Test6.hs, + tests/Test7.hs, + tests/Test8.hs, + tests/Test9.hs, + tests/Test14.hs, + tests/Test15.hs, + tests/TestParametric.hs, + tests/Prices.hs flag splitbase description: Choose the new smaller, split-up base package. @@ -37,4 +51,5 @@ Graphics.Rendering.Chart.Pie, Graphics.Rendering.Chart.Simple, Graphics.Rendering.Chart.Grid + Graphics.Rendering.Chart.AreaSpots diff --git a/Graphics/Rendering/Chart.hs b/Graphics/Rendering/Chart.hs --- a/Graphics/Rendering/Chart.hs +++ b/Graphics/Rendering/Chart.hs @@ -22,9 +22,9 @@ -- 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. +-- number of fields. For each record type X, there is generally a +-- default value called defaultX with sensibly initialised fields. +-- For example, 'Layout1' has 'defaultLayout1', etc. -- -- For a simpler though less flexible API, see "Graphics.Rendering.Chart.Simple". -- @@ -38,6 +38,7 @@ module Graphics.Rendering.Chart.Axis, module Graphics.Rendering.Chart.Plot, module Graphics.Rendering.Chart.Legend, + module Graphics.Rendering.Chart.AreaSpots, module Graphics.Rendering.Chart.Pie, ) where @@ -49,3 +50,4 @@ import Graphics.Rendering.Chart.Plot import Graphics.Rendering.Chart.Legend import Graphics.Rendering.Chart.Pie +import Graphics.Rendering.Chart.AreaSpots diff --git a/Graphics/Rendering/Chart/AreaSpots.hs b/Graphics/Rendering/Chart/AreaSpots.hs new file mode 100644 --- /dev/null +++ b/Graphics/Rendering/Chart/AreaSpots.hs @@ -0,0 +1,107 @@ +-- | +-- Module : Graphics.Rendering.Chart.AreaSpots +-- Copyright : (c) Malcolm Wallace 2009 +-- License : BSD-style (see COPYRIGHT file) +-- +-- Area spots are a collection of unconnected filled circles, +-- with x,y position, and an independent z value to be represented +-- by the relative area of the spots. + +{-# OPTIONS_GHC -XTemplateHaskell #-} + +module Graphics.Rendering.Chart.AreaSpots + ( AreaSpots(..) + , defaultAreaSpots + + , area_spots_title + , area_spots_linethick + , area_spots_linecolour + , area_spots_fillcolour + , area_spots_max_radius + , area_spots_values + ) where + +import qualified Graphics.Rendering.Cairo as C + +import Graphics.Rendering.Chart.Types +import Graphics.Rendering.Chart.Plot +import Graphics.Rendering.Chart.Axis +import Data.Accessor.Template +import Data.Colour +import Data.Colour.Names + +import Control.Monad + +-- stuff that belongs in Data.Tuple +fst3 (a,_,_) = a +snd3 (_,a,_) = a +thd3 (_,_,a) = a + + +-- | A collection of unconnected spots, with x,y position, and an +-- independent z value to be represented by the area of the spot. +data AreaSpots z x y = AreaSpots + { area_spots_title_ :: String + , area_spots_linethick_ :: Double + , area_spots_linecolour_ :: AlphaColour Double + , area_spots_fillcolour_ :: AlphaColour Double + , area_spots_max_radius_ :: Double -- ^ the largest size of spot + , area_spots_values_ :: [(x,y,z)] + } + +defaultAreaSpots :: AreaSpots z x y +defaultAreaSpots = AreaSpots + { area_spots_title_ = "" + , area_spots_linethick_ = 0.1 + , area_spots_linecolour_ = opaque blue + , area_spots_fillcolour_ = flip withOpacity 0.2 blue + , area_spots_max_radius_ = 20 -- in pixels + , area_spots_values_ = [] + } + +instance (PlotValue z) => ToPlot (AreaSpots z) where + toPlot p = Plot { plot_render_ = renderAreaSpots p + , plot_legend_ = [(area_spots_title_ p, renderSpotLegend p)] + , plot_all_points_ = ( map fst3 (area_spots_values_ p) + , map snd3 (area_spots_values_ p) ) + } + +renderAreaSpots :: (PlotValue z) => + AreaSpots z x y -> PointMapFn x y -> CRender () +renderAreaSpots p pmap = preserveCState $ + forM_ (scaleMax ((area_spots_max_radius_ p)^2) + (area_spots_values_ p)) + (\ (x,y,z)-> do + let radius = sqrt z + let (CairoPointStyle drawSpotAt) = filledCircles radius + (area_spots_fillcolour_ p) + drawSpotAt (pmap (LValue x, LValue y)) + let (CairoPointStyle drawOutlineAt) = hollowCircles radius + (area_spots_linethick_ p) + (area_spots_linecolour_ p) + drawOutlineAt (pmap (LValue x, LValue y)) + ) + where + scaleMax :: PlotValue z => Double -> [(x,y,z)] -> [(x,y,Double)] + scaleMax n points = let largest = maximum (map (toValue . thd3) points) + scale v = n * toValue v / largest + in map (\ (x,y,z) -> (x,y, scale z)) points + +renderSpotLegend :: AreaSpots z x y -> Rect -> CRender () +renderSpotLegend p r@(Rect p1 p2) = preserveCState $ do + let radius = min (abs (p_y p1 - p_y p2)) (abs (p_x p1 - p_x p2)) + centre = linearInterpolate p1 p2 + let (CairoPointStyle drawSpotAt) = filledCircles radius + (area_spots_fillcolour_ p) + drawSpotAt centre + let (CairoPointStyle drawOutlineAt) = hollowCircles radius + (area_spots_linethick_ p) + (area_spots_linecolour_ p) + drawOutlineAt centre + where + linearInterpolate (Point x0 y0) (Point x1 y1) = + Point (x0 + abs(x1-x0)/2) (y0 + abs(y1-y0)/2) + +------------------------------------------------------------------------- +-- Template haskell to derive Data.Accessor.Accessor +$( deriveAccessors ''AreaSpots ) diff --git a/Graphics/Rendering/Chart/Axis.hs b/Graphics/Rendering/Chart/Axis.hs --- a/Graphics/Rendering/Chart/Axis.hs +++ b/Graphics/Rendering/Chart/Axis.hs @@ -26,6 +26,7 @@ -- @ -- +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -XTemplateHaskell #-} module Graphics.Rendering.Chart.Axis( @@ -93,51 +94,51 @@ import Data.Accessor.Template import Data.Colour (opaque) import Data.Colour.Names (black, lightgrey) +import Data.Ord (comparing) import Graphics.Rendering.Chart.Types import Graphics.Rendering.Chart.Renderable --- | The basic data associated with an axis showing values of type x +-- | The basic data associated with an axis showing values of type x. data AxisData x = AxisData { - -- | The axis_viewport_ function maps values into device - -- cordinates. + -- | The axis_viewport_ function maps values into device coordinates. axis_viewport_ :: Range -> x -> Double, -- | The tick marks on the axis as pairs. - -- The first element is the position on the axis - -- (in viewport units) and the second element is the - -- length of the tick in output coordinates. - -- The tick starts on the axis, and positive number are drawn - -- towards the plot area. - axis_ticks_ :: [(x,Double)], + -- The first element is the position on the axis + -- (in viewport units) and the second element is the + -- length of the tick in output coordinates. + -- The tick starts on the axis, and positive numbers are drawn + -- towards the plot area. + 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_ :: [ (x, String) ], + -- is the position on the axis (in viewport units) and + -- the second is the label text string. + axis_labels_ :: [ (x, String) ], -- | The positions on the axis (in viewport units) where - -- we want to show grid lines. - axis_grid_ :: [ x ] + -- we want to show grid lines. + axis_grid_ :: [ x ] } --- | Control values for how an axis gets displayed +-- | Control values for how an axis gets displayed. data AxisStyle = AxisStyle { - axis_line_style_ :: CairoLineStyle, + axis_line_style_ :: CairoLineStyle, axis_label_style_ :: CairoFontStyle, - axis_grid_style_ :: CairoLineStyle, + axis_grid_style_ :: CairoLineStyle, -- | How far the labels are to be drawn from the axis. - axis_label_gap_ :: Double + axis_label_gap_ :: Double } --- | A function to generate the axis data given the data values --- to be plotted against it. +-- | A function to generate the axis data, given the data values +-- to be plotted against it. type AxisFn x = [x] -> AxisData x -- | Collect the information we need to render an axis. The --- bool is true if the axis direction is reversed +-- bool is true if the axis direction is reversed. data AxisT x = AxisT RectEdge AxisStyle Bool (AxisData x) instance ToRenderable (AxisT x) where @@ -145,24 +146,24 @@ axisToRenderable :: AxisT x -> Renderable x axisToRenderable at = Renderable { - minsize=minsizeAxis at, - render=renderAxis at + minsize = minsizeAxis at, + render = renderAxis at } -axisGridHide :: AxisData x -> AxisData x -axisGridHide ad = ad{axis_grid_=[]} +axisGridHide :: AxisData x -> AxisData x +axisGridHide ad = ad{ axis_grid_ = [] } -axisGridAtTicks :: AxisData x -> AxisData x -axisGridAtTicks ad = ad{axis_grid_=map fst (axis_ticks_ ad)} +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)} +axisGridAtLabels :: AxisData x -> AxisData x +axisGridAtLabels ad = ad{ axis_grid_ = map fst (axis_labels_ ad) } -axisTicksHide :: AxisData x -> AxisData x -axisTicksHide ad = ad{axis_ticks_=[]} +axisTicksHide :: AxisData x -> AxisData x +axisTicksHide ad = ad{ axis_ticks_ = [] } -axisLabelsHide :: AxisData x -> AxisData x -axisLabelsHide ad = ad{axis_labels_=[]} +axisLabelsHide :: AxisData x -> AxisData x +axisLabelsHide ad = ad{ axis_labels_ = [] } minsizeAxis :: AxisT x -> CRender RectSize minsizeAxis (AxisT at as rev ad) = do @@ -171,9 +172,9 @@ setFontStyle (axis_label_style_ as) mapM textSize labels let (lw,lh) = foldl maxsz (0,0) labelSizes - let ag = axis_label_gap_ as - let tsize = maximum ([0] ++ [ max 0 (-l) | (v,l) <- axis_ticks_ ad ]) - let sz = case at of + let ag = axis_label_gap_ as + let tsize = maximum ([0] ++ [ max 0 (-l) | (v,l) <- axis_ticks_ ad ]) + let sz = case at of E_Top -> (lw,max (addIfNZ lh ag) tsize) E_Bottom -> (lw,max (addIfNZ lh ag) tsize) E_Left -> (max (addIfNZ lw ag) tsize, lh) @@ -181,13 +182,13 @@ return sz where - maxsz (w1,h1) (w2,h2) = (max w1 w2, max h1 h2) - addIfNZ a b | a == 0 = 0 + 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 +-- the ends of the axis. axisOverhang :: Ord x => AxisT x -> CRender (Double,Double) axisOverhang (AxisT at as rev ad) = do let labels = map snd (sort (axis_labels_ ad)) @@ -195,24 +196,24 @@ setFontStyle (axis_label_style_ as) mapM textSize labels case labelSizes of - [] -> return (0,0) - ls -> let l1 = head ls - l2 = last ls + [] -> return (0,0) + ls -> let l1 = head ls + l2 = last ls ohangv = return (snd l1 / 2, snd l2 / 2) ohangh = return (fst l1 / 2, fst l2 / 2) in case at of - E_Top -> ohangh + E_Top -> ohangh E_Bottom -> ohangh - E_Left -> ohangv - E_Right -> ohangh + E_Left -> ohangv + E_Right -> ohangh 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} - strokeLines [Point sx sy,Point ex ey] + strokePath [Point sx sy,Point ex ey] preserveCState $ do setLineStyle ls{line_cap_=C.LineCapButt} mapM_ drawTick (axis_ticks_ ad) @@ -226,20 +227,21 @@ drawTick (value,length) = let t1 = axisPoint value t2 = t1 `pvadd` (vscale length tp) - in strokeLines [t1,t2] + in strokePath [t1,t2] (hta,vta,lp) = 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)) - E_Left -> (HTA_Right,VTA_Centre,(Vector (-g) 0)) - E_Right -> (HTA_Left,VTA_Centre,(Vector g 0)) + E_Top -> (HTA_Centre, VTA_Bottom, (Vector 0 (-g))) + E_Bottom -> (HTA_Centre, VTA_Top, (Vector 0 g)) + E_Left -> (HTA_Right, VTA_Centre, (Vector (-g) 0)) + E_Right -> (HTA_Left, VTA_Centre, (Vector g 0)) drawLabel (value,s) = do drawText hta vta (axisPoint value `pvadd` lp) s -axisMapping :: AxisT z -> RectSize -> (Double,Double,Double,Double,Vector,z->Point) +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) @@ -248,9 +250,9 @@ where (x1,y1) = (0,0) - mapx xr y x = Point (axis_viewport_ ad (reverse xr) x) 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 + reverse r@(r0,r1) = if rev then (r1,r0) else r renderAxisGrid :: RectSize -> AxisT z -> CRender () renderAxisGrid sz@(w,h) at@(AxisT re as rev ad) = do @@ -260,153 +262,166 @@ where (sx,sy,ex,ey,tp,axisPoint) = axisMapping at sz - drawGridLine E_Top = vline + drawGridLine E_Top = vline drawGridLine E_Bottom = vline - drawGridLine E_Left = hline - drawGridLine E_Right = hline + drawGridLine E_Left = hline + drawGridLine E_Right = hline vline v = let v' = p_x (axisPoint v) - in strokeLines [Point v' 0,Point v' h] + in strokePath [Point v' 0,Point v' h] hline v = let v' = p_y (axisPoint v) - in strokeLines [Point 0 v',Point w v'] + in strokePath [Point 0 v',Point w v'] -stepsInt :: Int -> Range -> [Int] +stepsInt :: Integral a => a -> Range -> [a] stepsInt nSteps range = bestSize (goodness alt0) alt0 alts where - bestSize n a (a':as) = let n' = goodness a' in if n' < n then bestSize n' a' as else a + bestSize n a (a':as) = let n' = goodness a' in + if n' < n then bestSize n' a' as else a - goodness vs = abs (length vs - nSteps) + goodness vs = abs (genericLength vs - nSteps) - (alt0:alts) = map (\n -> steps n range) sampleSteps + (alt0:alts) = map (\n -> steps n range) sampleSteps - sampleSteps = [1,2,5] ++ sampleSteps1 - sampleSteps1 = [10,20,25,50] ++ map (*10) sampleSteps1 + sampleSteps = [1,2,5] ++ sampleSteps1 + sampleSteps1 = [10,20,25,50] ++ map (*10) sampleSteps1 steps size (min,max) = takeWhile ( Range -> [Rational] -steps nSteps (min,max) = [ (fromIntegral (min' + i)) * s | i <- [0..n] ] +steps :: RealFloat a => a -> (a,a) -> [Rational] +steps nSteps (min,max) = map ((s*) . fromIntegral) [min' .. max'] where - min' = floor (min / fromRational s) - max' = ceiling (max / fromRational s) - n = (max' - min') - s = chooseStep nSteps (min,max) + s = chooseStep nSteps (min,max) + min' = floor $ realToFrac min / s + max' = ceiling $ realToFrac max / s + n = (max' - min') -chooseStep :: Double -> Range -> Rational -chooseStep nsteps (min,max) = s + +chooseStep :: RealFloat a => a -> (a,a) -> Rational +chooseStep nsteps (x1,x2) = minimumBy (comparing proximity) steps where - mult = 10 ^^ (floor ((log (max-min) - log nsteps) / log 10)) - steps = map (mult*) [0.1, 0.2, 0.25, 0.5, 1.0, 2.0, 2.5, 5.0, 10, 20, 25, 50] - steps' = sort [ (abs((max-min)/(fromRational s) - nsteps), s) | s <- steps ] - s = snd (head steps') + delta = x2 - x1 + mult = 10 ^^ (floor $ log10 $ delta / nsteps) + steps = map (mult*) [0.1,0.2,0.25,0.5,1.0,2.0,2.5,5.0,10,20,25,50] + proximity x = abs $ delta / realToFrac x - nsteps -- | Given a target number of values, and a list of input points, --- find evenly spaced values from the set {1*X, 2*X, 2.5*X, 5*X} (where --- X is some power of ten) that evenly cover the input points. +-- find evenly spaced values from the set {1*X, 2*X, 2.5*X, 5*X} (where +-- X is some power of ten) that evenly cover the input points. autoSteps :: Int -> [Double] -> [Double] autoSteps nSteps vs = map fromRational $ steps (fromIntegral nSteps) r where - range [] = (0,1) - range _ | min == max = (min-0.5,min+0.5) - | otherwise = (min,max) + range [] = (0,1) + range _ | min == max = (min-0.5,min+0.5) + | otherwise = (min,max) (min,max) = (minimum ps,maximum ps) - ps = filter isValidNumber vs - r = range ps + ps = filter isValidNumber vs + r = range ps 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 + axis_viewport_ = newViewport, + axis_ticks_ = newTicks, + axis_grid_ = gridvs, + axis_labels_ = newLabels } where newViewport = vmap (min',max') - newTicks = [ (v,2) | v <- tickvs ] ++ [ (v,5) | v <- labelvs ] - newLabels = [(v,labelf v) | v <- labelvs] - min' = minimum labelvs - max' = maximum labelvs - - + newTicks = [ (v,2) | v <- tickvs ] ++ [ (v,5) | v <- labelvs ] + newLabels = [ (v,labelf v) | v <- labelvs ] + min' = minimum labelvs + max' = maximum labelvs -data GridMode = GridNone | GridAtMajor | GridAtMinor +makeAxis' :: Ord x => (x -> Double) -> (x -> String) -> ([x],[x],[x]) -> AxisData x +makeAxis' f labelf (labelvs, tickvs, gridvs) = AxisData { + axis_viewport_ = linMap f (minimum labelvs, maximum labelvs), + axis_ticks_ = zip tickvs (repeat 2) ++ zip labelvs (repeat 5), + axis_grid_ = gridvs, + axis_labels_ = [ (v,labelf v) | v <- labelvs ] + } data LinearAxisParams a = LinearAxisParams { - -- | The function used to show the axes labels - la_labelf_ :: a -> String, + -- | The function used to show the axes labels. + la_labelf_ :: a -> String, - -- | The target number of labels to be shown + -- | The target number of labels to be shown. la_nLabels_ :: Int, - -- | The target number of ticks to be shown - la_nTicks_ :: Int + -- | The target number of ticks to be shown. + la_nTicks_ :: Int } +defaultLinearAxis :: (Show a) => LinearAxisParams a defaultLinearAxis = LinearAxisParams { - la_labelf_ = showD, - la_nLabels_ = 5, - la_nTicks_ = 50 + la_labelf_ = showD, + la_nLabels_ = 5, + la_nTicks_ = 50 } -defaultIntAxis = LinearAxisParams { - la_labelf_ = show, +defaultIntAxis :: (Show a) => LinearAxisParams a +defaultIntAxis = LinearAxisParams { + la_labelf_ = show, la_nLabels_ = 5, - la_nTicks_ = 10 + la_nTicks_ = 10 } -- | Generate a linear axis automatically. --- The supplied axis is used as a template, with the viewport, ticks, labels --- 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 Double -> AxisFn Double -autoScaledAxis lap ps0 = makeAxis (la_labelf_ lap) (labelvs,tickvs,gridvs) +-- The supplied axis is used as a template, with the viewport, ticks, labels +-- 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 :: RealFloat a => LinearAxisParams a -> AxisFn a +autoScaledAxis lap ps0 = makeAxis' realToFrac (la_labelf_ lap) (labelvs,tickvs,gridvs) where - ps = filter isValidNumber ps0 + 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 = 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 + range [] = (0,1) + range _ | min == max = (min-1,min+1) + | otherwise = (min,max) + 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 showD x = case reverse $ show x of '0':'.':r -> reverse r - _ -> show x + _ -> show x -autoScaledIntAxis :: LinearAxisParams Int -> AxisFn Int -autoScaledIntAxis lap ps = makeAxis (la_labelf_ lap) (labelvs,tickvs,gridvs) + +autoScaledIntAxis :: (Integral i, PlotValue i) => + LinearAxisParams i -> AxisFn i +autoScaledIntAxis lap ps = + makeAxis (la_labelf_ lap) (labelvs,tickvs,gridvs) where (min,max) = (minimum ps,maximum ps) - range [] = (0,1) - range _ | min == max = (fromIntegral $ min-1, fromIntegral $ min+1) - | otherwise = (fromIntegral $ min, fromIntegral $ max) - labelvs :: [Int] - labelvs = stepsInt (la_nLabels_ lap) r - tickvs = stepsInt (la_nTicks_ lap) $ - (fromIntegral $ minimum labelvs,fromIntegral $ maximum labelvs) - gridvs = labelvs - r = range ps + range [] = (0,1) + range _ | min == max = (fromIntegral $ min-1, fromIntegral $ min+1) + | otherwise = (fromIntegral $ min, fromIntegral $ max) +-- labelvs :: [i] + labelvs = stepsInt (fromIntegral $ la_nLabels_ lap) r + tickvs = stepsInt (fromIntegral $ la_nTicks_ lap) + ( fromIntegral $ minimum labelvs + , fromIntegral $ maximum labelvs ) + gridvs = labelvs + r = range ps log10 :: (Floating a) => a -> a log10 = logBase 10 -frac x | 0 <= b = (a,b) +frac x | 0 <= b = (a,b) | otherwise = (a-1,b+1) where (a,b) = properFraction x {- - Rules: Do no subdivide between powers of 10 until all powers of 10 + Rules: Do not subdivide between powers of 10 until all powers of 10 get a major ticks. Do not subdivide between powers of ten as [1,2,4,6,8,10] when 5 gets a major ticks @@ -415,100 +430,106 @@ logTicks :: Range -> ([Rational],[Rational],[Rational]) logTicks (low,high) = (major,minor,major) where - ratio = high/low - lower a l = let (i,r) = frac (log10 a) in - (maximum (1:(filter (\x -> log10 (fromRational x) <= r) l)))*10^^i - upper a l = let (i,r) = properFraction (log10 a) in - (minimum (10:(filter (\x -> r <= log10 (fromRational x)) l)))*10^^i + ratio = high/low + lower a l = let (i,r) = frac (log10 a) in + (maximum (1:filter (\x -> log10 (fromRational x) <= r) l))*10^^i + upper a l = let (i,r) = properFraction (log10 a) in + (minimum (10:filter (\x -> r <= log10 (fromRational x)) l))*10^^i + powers :: (Double,Double) -> [Rational] -> [Rational] + powers (x,y) l = [ a*10^^p | p <- [(floor (log10 x))..(ceiling (log10 y))] + , a <- l ] + midselection r l = filter (inRange r l) (powers r l) inRange (a,b) l x = (lower a l <= x) && (x <= upper b l) - powers :: (Double,Double) -> [Rational] -> [Rational] - powers (x,y) l = [a*10^^p | p<- [(floor (log10 x))..(ceiling (log10 y))], a<- l] - midselection r l = filter (inRange r l) (powers r l) major | 17.5 < log10 ratio = map (\x -> 10^^(round x)) $ - steps (min 5 (log10 ratio)) (log10 low, log10 high) - | 12 < log10 ratio = map (\x -> 10^^(round x)) $ - steps ((log10 ratio)/5) (log10 low, log10 high) - | 6 < log10 ratio = map (\x -> 10^^(round x)) $ - steps ((log10 ratio)/2) (log10 low, log10 high) - | 3 < log10 ratio = midselection (low,high) [1,10] - | 20 < ratio = midselection (low,high) [1,5,10] - | 6 < ratio = midselection (low,high) [1,2,4,6,8,10] - | 3 < ratio = midselection (low,high) [1..10] - | otherwise = steps 5 (low,high) - (l',h') = (minimum major, maximum major) + steps (min 5 (log10 ratio)) + (log10 low, log10 high) + | 12 < log10 ratio = map (\x -> 10^^(round x)) $ + steps ((log10 ratio)/5) (log10 low, log10 high) + | 6 < log10 ratio = map (\x -> 10^^(round x)) $ + steps ((log10 ratio)/2) (log10 low, log10 high) + | 3 < log10 ratio = midselection (low,high) [1,10] + | 20 < ratio = midselection (low,high) [1,5,10] + | 6 < ratio = midselection (low,high) [1,2,4,6,8,10] + | 3 < ratio = midselection (low,high) [1..10] + | otherwise = steps 5 (low,high) + (l',h') = (minimum major, maximum major) (dl',dh') = (fromRational l', fromRational h') - ratio' = fromRational (h'/l') + ratio' = fromRational (h'/l') minor | 50 < log10 ratio' = map (\x -> 10^^(round x)) $ steps 50 (log10 $ dl', log10 $ dh') - | 6 < log10 ratio' = filter (\x -> l'<=x && x <=h') $ - powers (dl', dh') [1,10] - | 3 < log10 ratio' = filter (\x -> l'<=x && x <=h') $ - powers (dl',dh') [1,5,10] - | 6 < ratio' = filter (\x -> l'<=x && x <=h') $ - powers (dl',dh') [1..10] - | 3 < ratio' = filter (\x -> l'<=x && x <=h') $ - powers (dl',dh') [1,1.2..10] - | otherwise = steps 50 (dl', dh') + | 6 < log10 ratio' = filter (\x -> l'<=x && x <=h') $ + powers (dl', dh') [1,10] + | 3 < log10 ratio' = filter (\x -> l'<=x && x <=h') $ + powers (dl',dh') [1,5,10] + | 6 < ratio' = filter (\x -> l'<=x && x <=h') $ + powers (dl',dh') [1..10] + | 3 < ratio' = filter (\x -> l'<=x && x <=h') $ + powers (dl',dh') [1,1.2..10] + | otherwise = steps 50 (dl', dh') -- | Generate a log axis automatically. --- The supplied axis is used as a template, with the viewport, ticks, labels --- 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 :: LogAxisParams -> AxisFn LogValue -autoScaledLogAxis lap ps0 = makeAxis labelf (wrap rlabelvs, wrap rtickvs, wrap rgridvs) - where - ps = filter (\(LogValue x) -> isValidNumber x && 0 < x) ps0 - (min, max) = (minimum ps,maximum ps) - range [] = (3,30) - 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 +-- The supplied axis is used as a template, with the viewport, ticks, labels +-- and grid set appropriately for the data displayed against that axis. +-- The resulting axis will only show a grid if the template has some grid +-- values. +autoScaledLogAxis :: RealFloat a => LogAxisParams a -> AxisFn a +autoScaledLogAxis lap ps0 = + makeAxis' (realToFrac . log) (loga_labelf_ lap) (wrap rlabelvs, wrap rtickvs, wrap rgridvs) + where + ps = filter (\x -> isValidNumber x && 0 < x) ps0 + (min,max) = (minimum ps,maximum ps) + wrap = map fromRational + range [] = (3,30) + range _ | min == max = (realToFrac $ min/3, realToFrac $ max*3) + | otherwise = (realToFrac $ min, realToFrac $ max) + (rlabelvs, rtickvs, rgridvs) = logTicks (range ps) -data LogAxisParams = LogAxisParams { - -- | The function used to show the axes labels - loga_labelf_ :: LogValue -> String +data LogAxisParams a = LogAxisParams { + -- | The function used to show the axes labels. + loga_labelf_ :: a -> String } +defaultLogAxis :: Show a => LogAxisParams a defaultLogAxis = LogAxisParams { - loga_labelf_ = \(LogValue x) -> showD x + loga_labelf_ = showD } ---------------------------------------------------------------------- +defaultAxisLineStyle :: CairoLineStyle defaultAxisLineStyle = solidLine 1 $ opaque black + +defaultGridLineStyle :: CairoLineStyle defaultGridLineStyle = dashedLine 1 [5,5] $ opaque lightgrey +defaultAxisStyle :: AxisStyle defaultAxisStyle = AxisStyle { - axis_line_style_ = defaultAxisLineStyle, + axis_line_style_ = defaultAxisLineStyle, axis_label_style_ = defaultFontStyle, - axis_grid_style_ = defaultGridLineStyle, - axis_label_gap_ = 10 + axis_grid_style_ = defaultGridLineStyle, + axis_label_gap_ = 10 } ---------------------------------------------------------------------- --- | Map a LocalTime value to a plot cordinate +-- | Map a LocalTime value to a plot coordinate. doubleFromLocalTime :: LocalTime -> Double doubleFromLocalTime lt = fromIntegral (toModifiedJulianDay (localDay lt)) - + fromRational (timeOfDayToDayFraction (localTimeOfDay lt)) + + fromRational (timeOfDayToDayFraction (localTimeOfDay lt)) --- | Map a plot cordinate to a LocalTime +-- | Map a plot coordinate to a LocalTime. localTimeFromDouble :: Double -> LocalTime localTimeFromDouble v = LocalTime (ModifiedJulianDay i) (dayFractionToTimeOfDay (toRational d)) where (i,d) = properFraction v --- | TimeSeq is a (potentially infinite) set of times. When passes --- a reference time, the function returns a a pair of lists. The first --- contains all times in the set less than the reference time in --- decreasing order. The second contains all times in the set greater --- than or equal to the reference time, in increasing order. +-- | TimeSeq is a (potentially infinite) set of times. When passed +-- a reference time, the function returns a a pair of lists. The first +-- contains all times in the set less than the reference time in +-- decreasing order. The second contains all times in the set greater +-- than or equal to the reference time, in increasing order. type TimeSeq = LocalTime-> ([LocalTime],[LocalTime]) coverTS tseq min max = min' ++ enumerateTS tseq min max ++ max' @@ -516,7 +537,8 @@ min' = if elemTS min tseq then [] else take 1 (fst (tseq min)) max' = if elemTS max tseq then [] else take 1 (snd (tseq max)) -enumerateTS tseq min max = reverse (takeWhile (>=min) ts1) ++ takeWhile (<=max) ts2 +enumerateTS tseq min max = + reverse (takeWhile (>=min) ts1) ++ takeWhile (<=max) ts2 where (ts1,ts2) = tseq min @@ -527,38 +549,43 @@ -- | How to display a time type TimeLabelFn = LocalTime -> String --- | Create an 'AxisFn' to for a time axis. The first 'TimeSeq' sets the minor ticks, --- 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' +-- | Create an 'AxisFn' to for a time axis. The first 'TimeSeq' sets the +-- minor ticks, and the ultimate range will be aligned to its 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 -> 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] + 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 - (min,max) = case pts of - [] -> (refLocalTime,refLocalTime) - ps -> (minimum ps, maximum ps) + (min,max) = case pts of + [] -> (refLocalTime,refLocalTime) + ps -> (minimum ps, maximum ps) refLocalTime = LocalTime (ModifiedJulianDay 0) midnight - times = coverTS tseq min max - ltimes = coverTS lseq min max - min' = minimum times - max' = maximum times - 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 + times = coverTS tseq min max + ltimes = coverTS lseq min max + min' = minimum times + max' = maximum times + 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 normalizeTimeOfDay :: LocalTime -> LocalTime normalizeTimeOfDay t@(LocalTime day (TimeOfDay h m s)) - | s >= 60 = normalizeTimeOfDay (LocalTime day (TimeOfDay h (m+s`div'`60) (s`mod'`60))) - | m >= 60 = normalizeTimeOfDay (LocalTime day (TimeOfDay (h+m`div`60) (m`mod`60) s)) - | h >= 24 = LocalTime (addDays (fromIntegral (h`div`24)) day) (TimeOfDay (h`mod`24) m s) + | s >= 60 = normalizeTimeOfDay (LocalTime day (TimeOfDay h (m+s`div'`60) + (s`mod'`60))) + | m >= 60 = normalizeTimeOfDay (LocalTime day (TimeOfDay (h+m`div`60) + (m`mod`60) s)) + | h >= 24 = LocalTime (addDays (fromIntegral (h`div`24)) day) + (TimeOfDay (h`mod`24) m s) | otherwise = t addTod :: Int -> Int -> Int -> LocalTime -> LocalTime @@ -566,88 +593,89 @@ where t' = LocalTime day (TimeOfDay (h+dh) (m+dm) (s+fromIntegral ds)) --- | A 'TimeSeq' for hours +-- | A 'TimeSeq' for seconds. seconds :: TimeSeq seconds t = (iterate rev t1, tail (iterate fwd t1)) - where h0 = todHour (localTimeOfDay t) - m0 = todMin (localTimeOfDay t) - s0 = todSec (localTimeOfDay t) - t0 = LocalTime (localDay t) (TimeOfDay h0 m0 s0) - t1 = if t0 < t then t0 else (rev t0) - rev = addTod 0 0 (-1) - fwd = addTod 0 0 1 + where h0 = todHour (localTimeOfDay t) + m0 = todMin (localTimeOfDay t) + s0 = todSec (localTimeOfDay t) + t0 = LocalTime (localDay t) (TimeOfDay h0 m0 s0) + t1 = if t0 < t then t0 else (rev t0) + rev = addTod 0 0 (-1) + fwd = addTod 0 0 1 toTime h = LocalTime --- | A 'TimeSeq' for hours +-- | A 'TimeSeq' for minutes. minutes :: TimeSeq minutes t = (iterate rev t1, tail (iterate fwd t1)) - where h0 = todHour (localTimeOfDay t) - m0 = todMin (localTimeOfDay t) - t0 = LocalTime (localDay t) (TimeOfDay h0 m0 0) - t1 = if t0 < t then t0 else (rev t0) - rev = addTod 0 (-1)0 - fwd = addTod 0 1 0 + where h0 = todHour (localTimeOfDay t) + m0 = todMin (localTimeOfDay t) + t0 = LocalTime (localDay t) (TimeOfDay h0 m0 0) + t1 = if t0 < t then t0 else (rev t0) + rev = addTod 0 (-1)0 + fwd = addTod 0 1 0 toTime h = LocalTime --- | A 'TimeSeq' for hours +-- | A 'TimeSeq' for hours. hours :: TimeSeq hours t = (iterate rev t1, tail (iterate fwd t1)) - where h0 = todHour (localTimeOfDay t) - t0 = LocalTime (localDay t) (TimeOfDay h0 0 0) - t1 = if t0 < t then t0 else (rev t0) - rev = addTod (-1) 0 0 - fwd = addTod 1 0 0 + where h0 = todHour (localTimeOfDay t) + t0 = LocalTime (localDay t) (TimeOfDay h0 0 0) + t1 = if t0 < t then t0 else (rev t0) + rev = addTod (-1) 0 0 + fwd = addTod 1 0 0 toTime h = LocalTime --- | A 'TimeSeq' for calendar days +-- | A 'TimeSeq' for calendar days. days :: TimeSeq days t = (map toTime $ iterate rev t1, map toTime $ tail (iterate fwd t1)) - where t0 = (localDay t) - t1 = if (toTime t0) < t then t0 else (rev t0) - rev = pred - fwd = succ + where t0 = localDay t + t1 = if (toTime t0) < t then t0 else (rev t0) + rev = pred + fwd = succ toTime d = LocalTime d midnight --- | A 'TimeSeq' for calendar months +-- | A 'TimeSeq' for calendar months. months :: TimeSeq months t = (map toTime $ iterate rev t1, map toTime $ tail (iterate fwd t1)) - where t0 = let (y,m,d) = toGregorian $ localDay t in fromGregorian y m 1 - t1 = if toTime t0 < t then t0 else (rev t0) - rev = addGregorianMonthsClip (-1) - fwd = addGregorianMonthsClip 1 + where t0 = let (y,m,d) = toGregorian $ localDay t in fromGregorian y m 1 + t1 = if toTime t0 < t then t0 else (rev t0) + rev = addGregorianMonthsClip (-1) + fwd = addGregorianMonthsClip 1 toTime d = LocalTime d midnight --- | A 'TimeSeq' for calendar years +-- | A 'TimeSeq' for calendar years. years :: TimeSeq years t = (map toTime $ iterate rev t1, map toTime $ tail (iterate fwd t1)) - where t0 = let (y,m,d) = toGregorian $ localDay t in y - t1 = if toTime t0 < t then t0 else (rev t0) - rev = pred - fwd = succ + where t0 = let (y,m,d) = toGregorian $ localDay t in y + t1 = if toTime t0 < t then t0 else (rev t0) + rev = pred + fwd = succ toTime y = LocalTime (fromGregorian y 1 1) midnight --- | 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' +-- | 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 :: AxisFn LocalTime autoTimeAxis [] = timeAxis days days (formatTime defaultTimeLocale "%d-%b") [] autoTimeAxis pts | tdiff==0 && dsec<60 = timeAxis seconds seconds (ft "%H:%M:%S") pts | tdiff==0 && dsec<3600 = timeAxis minutes minutes (ft "%H:%M") pts - | tdiff < 1 = timeAxis hours hours (ft "%H:%M") pts - | tdiff < 2 = timeAxis days hours (ft "%d-%b") pts - | tdiff < 15 = timeAxis days days (ft "%d-%b") pts - | tdiff < 90 = timeAxis days months (ft "%b-%y") pts - | tdiff < 450 = timeAxis months months (ft "%b-%y") pts - | tdiff < 1800 = timeAxis months years (ft "%Y") pts - | otherwise = timeAxis years years (ft "%Y") pts + | tdiff < 1 = timeAxis hours hours (ft "%H:%M") pts + | tdiff < 2 = timeAxis days hours (ft "%d-%b") pts + | tdiff < 15 = timeAxis days days (ft "%d-%b") pts + | tdiff < 90 = timeAxis days months (ft "%b-%y") pts + | tdiff < 450 = timeAxis months months (ft "%b-%y") pts + | tdiff < 1800 = timeAxis months years (ft "%Y") pts + | otherwise = timeAxis years years (ft "%Y") pts where tdiff = diffDays (localDay t1) (localDay t0) dsec = fromIntegral (3600*(h1-h0)+60*(m1-m0))+(s1-s0) where (TimeOfDay h0 m0 s0) = localTimeOfDay t0 (TimeOfDay h1 m1 s1) = localTimeOfDay t1 - t1 = maximum pts - t0 = minimum pts - ft = formatTime defaultTimeLocale + t1 = maximum pts + t0 = minimum pts + ft = formatTime defaultTimeLocale unitAxis :: AxisData () @@ -661,74 +689,84 @@ ----------------------------------------------------------------------------- class Ord a => PlotValue a where - toValue :: a -> Double - autoAxis ::AxisFn a + toValue :: a -> Double + autoAxis :: AxisFn a instance PlotValue Double where - toValue = id + toValue = id autoAxis = autoScaledAxis defaultLinearAxis newtype LogValue = LogValue Double - deriving (Eq, Ord) + deriving (Eq, Ord, Num, Real, Fractional, RealFrac, Floating, RealFloat) instance Show LogValue where show (LogValue x) = show x instance PlotValue LogValue where toValue (LogValue x) = log x - autoAxis = autoScaledLogAxis defaultLogAxis + autoAxis = autoScaledLogAxis defaultLogAxis instance PlotValue Int where - toValue = fromIntegral - autoAxis = autoScaledIntAxis defaultIntAxis + toValue = fromIntegral + autoAxis = autoScaledIntAxis defaultIntAxis +instance PlotValue Integer where + toValue = fromIntegral + autoAxis = autoScaledIntAxis defaultIntAxis + instance PlotValue () where toValue () = 0 autoAxis = const unitAxis instance PlotValue LocalTime where - toValue = doubleFromLocalTime - autoAxis = autoTimeAxis + toValue = doubleFromLocalTime + autoAxis = autoTimeAxis ---------------------------------------------------------------------- -- | Type for capturing values plotted by index number --- (ie position in a list) rather than a numerical value +-- (ie position in a list) rather than a numerical value. newtype PlotIndex = PlotIndex { plotindex_i :: Int } - deriving (Eq,Ord) + deriving (Eq,Ord,Enum,Num,Real,Integral,Show) instance PlotValue PlotIndex where - toValue (PlotIndex i)= fromIntegral i - autoAxis = autoIndexAxis [] + toValue (PlotIndex i) = fromIntegral i + autoAxis = autoIndexAxis [] -- | Create an axis for values indexed by position. The --- list of strings are the labels to be used. -autoIndexAxis :: [String] -> [PlotIndex] -> AxisData PlotIndex +-- list of strings are the labels to be used. +autoIndexAxis :: Integral i => [String] -> [i] -> AxisData i autoIndexAxis labels vs = AxisData { - axis_viewport_= vport, - axis_ticks_ = [], - axis_labels_ = filter (\(i,l) -> i >= imin && i <= imax) (addIndexes labels), - axis_grid_ = [] + axis_viewport_ = vport, + axis_ticks_ = [], + axis_labels_ = filter (\(i,l) -> i >= imin && i <= imax) + (zip [0..] labels), + axis_grid_ = [] } where - vport r (PlotIndex i) = vmap (fi (plotindex_i imin) - 0.5, - fi (plotindex_i imax) + 0.5) r (fi i) + vport r i = linMap id ( fromIntegral imin - 0.5 + , fromIntegral imax + 0.5) r (fromIntegral i) imin = minimum vs imax = maximum vs - fi = fromIntegral :: Int -> Double - --- | Augment a list of values with index numbers for plotting +-- | Augment a list of values with index numbers for plotting. addIndexes :: [a] -> [(PlotIndex,a)] addIndexes as = map (\(i,a) -> (PlotIndex i,a)) (zip [0..] as) --- | A linear mapping of points in one range to another +-- | 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) +vmap (v1,v2) (v3,v4) v = v3 + (toValue v - toValue v1) * (v4-v3) + / (toValue v2 - toValue v1) +-- | A linear mapping of points in one range to another. +linMap :: (a -> Double) -> (a,a) -> Range -> a -> Double +linMap f (x1,x2) (d1,d2) x = + d1 + (d2 - d1) * (f x - f x1) / (f x2 - f x1) + ---------------------------------------------------------------------- --- Template haskell to derive an instance of Data.Accessor.Accessor for each field +-- Template haskell to derive an instance of Data.Accessor.Accessor for +-- each field. $( deriveAccessors ''AxisData ) $( deriveAccessors ''AxisStyle ) $( deriveAccessors ''LinearAxisParams ) diff --git a/Graphics/Rendering/Chart/Grid.hs b/Graphics/Rendering/Chart/Grid.hs --- a/Graphics/Rendering/Chart/Grid.hs +++ b/Graphics/Rendering/Chart/Grid.hs @@ -29,40 +29,45 @@ import Data.Colour import Data.Colour.Names -type Span = (Int,Int) -type Size = (Int,Int) +type Span = (Int,Int) +type Size = (Int,Int) + -- | When more space is available for an item than the total width of items, --- extra added space is proportional to 'space weight'. +-- extra added space is proportional to 'space weight'. type SpaceWeight = (Double,Double) -type Cell a = (a,Span,SpaceWeight) +type Cell a = (a,Span,SpaceWeight) -- | Abstract datatype representing a grid. -data Grid a = Value (a,Span,SpaceWeight) -- ^ A singleton grid item "a" spanning a given - -- rectangle (measured in grid cells), with - -- given space weight. - | Above (Grid a) (Grid a) Size -- ^ One grid above the other. "Size" is their cached - -- total size (so it is NOT specified manually). - | Beside (Grid a) (Grid a) Size -- ^ One grid horizontally beside the other - | Overlay (Grid a) (Grid a) Size -- ^ Two grids positioned one over the other - | Empty -- ^ An empty 1x1 grid cell - | Null -- ^ An empty 0x0 grid cell +data Grid a + = Value (a,Span,SpaceWeight) -- ^ A singleton grid item "a" spanning + -- a given rectangle (measured in grid + -- cells), with given space weight. + | Above (Grid a) (Grid a) Size -- ^ One grid above the other. "Size" is + -- their cached total size (so it is + -- NOT specified manually). + | Beside (Grid a) (Grid a) Size -- ^ One grid horizontally beside + -- the other. + | Overlay (Grid a) (Grid a) Size -- ^ Two grids positioned one over + -- the other. + | Empty -- ^ An empty 1x1 grid cell. + | Null -- ^ An empty 0x0 grid cell. 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 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 Null = 0 +height Empty = 1 +height (Value _) = 1 +height (Beside _ _ (w,h)) = h +height (Above _ _ (w,h)) = h height (Overlay _ _ (w,h)) = h -- | A 1x1 grid from a given value, with no extra space. @@ -84,22 +89,26 @@ above, beside :: Grid a -> Grid a -> Grid a above Null t = t above t Null = t -above t1 t2 = Above t1 t2 size +above t1 t2 = Above t1 t2 size where size = (max (width t1) (width t2), height t1 + height t2) --- | A value placed above the grid, occupying 1 row with the same horizontal span as the grid. +-- | A value placed above the grid, occupying 1 row with the same +-- horizontal span as the grid. fullRowAbove :: a -> Double -> Grid a -> Grid a fullRowAbove a w g = (weights (0,w) $ tspan a (width g,1)) `above` g --- | A value placed below the grid, occupying 1 row with the same horizontal span as the grid. +-- | A value placed below the grid, occupying 1 row with the same +-- horizontal span as the grid. fullRowBelow :: a -> Double -> Grid a -> Grid a fullRowBelow a w g = g `above` (weights (0,w) $ tspan a (width g,1)) --- | A value placed to the left of the grid, occupying 1 column with the same vertical span as the grid. +-- | A value placed to the left of the grid, occupying 1 column with +-- the same vertical span as the grid. fullColLeft :: a -> Double -> Grid a -> Grid a fullColLeft a w g = (weights (w,0) $ tspan a (1,height g)) `beside` g --- | A value placed to the right of the grid, occupying 1 column with the same vertical span as the grid. +-- | A value placed to the right of the grid, occupying 1 column with +-- the same vertical span as the grid. fullColRight :: a -> Double -> Grid a -> Grid a fullColRight a w g = g `beside` (weights (w,0) $ tspan a (1,height g)) @@ -113,61 +122,62 @@ 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)) +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 +aboveN = foldl above nullt besideN = foldl beside nullt -- | One grid over the other. The first argument is shallow, the second is deep. overlay :: Grid a -> Grid a -> Grid a 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)) +overlay t1 t2 = Overlay t1 t2 size + where size = (max (width t1) (width t2), max (height t1) (height t2)) +-- | A synonym for 'beside'. +(.|.) :: Grid a -> Grid a -> Grid a (.|.) = beside + +-- | A synonym for 'above'. +(./.) :: Grid a -> Grid a -> Grid a (./.) = above -- | Sets the space weight of *every* cell of the grid to given value. 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 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 + 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 +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)] @@ -179,16 +189,16 @@ 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 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 +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 +flatten2 i@(x,y) (Beside t1 t2 size) els = (f1.f2) els where f1 = flatten2 i t1 f2 = flatten2 (x + width t1, y) t2 @@ -209,11 +219,15 @@ getSizes :: Grid (Renderable a) -> CRender (DArray, DArray, DArray, DArray) getSizes t = do szs <- mapGridM minsize t :: CRender (Grid RectSize) - let szs' = flatten szs - let widths = accumArray max 0 (0, width t - 1) (foldT (ef wf fst) [] szs') - let heights = accumArray max 0 (0, height t - 1) (foldT (ef hf snd) [] szs') - let xweights = accumArray max 0 (0, width t - 1) (foldT (ef xwf fst) [] szs') - let yweights = accumArray max 0 (0, height t - 1) (foldT (ef ywf snd) [] szs') + let szs' = flatten szs + let widths = accumArray max 0 (0, width t - 1) + (foldT (ef wf fst) [] szs') + let heights = accumArray max 0 (0, height t - 1) + (foldT (ef hf snd) [] szs') + let xweights = accumArray max 0 (0, width t - 1) + (foldT (ef xwf fst) [] szs') + let yweights = accumArray max 0 (0, height t - 1) + (foldT (ef ywf snd) [] szs') return (widths,heights,xweights,yweights) where wf (x,y) (w,h) (ww,wh) = (x,w) @@ -222,8 +236,11 @@ ywf (x,y) (w,h) (xw,yw) = (y,yw) ef f ds loc (size,span,ew) r | ds span == 1 = (f loc size ew:r) - | otherwise = r + | otherwise = r +instance (ToRenderable a) => ToRenderable (Grid a) where + toRenderable = gridToRenderable . fmap toRenderable + gridToRenderable :: Grid (Renderable a) -> Renderable a gridToRenderable t = Renderable minsizef renderf where @@ -234,14 +251,14 @@ renderf (w,h) = do (widths, heights, xweights, yweights) <- getSizes t - let widths' = addExtraSpace w widths xweights + let widths' = addExtraSpace w widths xweights let heights' = addExtraSpace h heights yweights - let borders = (ctotal widths',ctotal heights') + let borders = (ctotal widths',ctotal heights') rf1 borders (0,0) t -- (x borders, y borders) -> (x,y) -> grid -> drawing rf1 borders loc@(i,j) t = case t of - Null -> return nullPickFn + Null -> return nullPickFn Empty -> return nullPickFn (Value (r,span,_)) -> do let (Rect p0 p1) = mkRect borders loc span @@ -253,14 +270,14 @@ (Above t1 t2 _) -> do pf1 <- rf1 borders (i,j) t1 pf2 <- rf1 borders (i,j+height t1) t2 - let pf p@(Point x y) = if y < (snd borders ! (j + height t1)) then pf1 p - else pf2 p + let pf p@(Point x y) = if y < (snd borders ! (j + height t1)) + then pf1 p else pf2 p return pf (Beside t1 t2 _) -> do pf1 <- rf1 borders (i,j) t1 pf2 <- rf1 borders (i+width t1,j) t2 - let pf p@(Point x y) = if x < (fst borders ! (i + width t1)) then pf1 p - else pf2 p + let pf p@(Point x y) = if x < (fst borders ! (i + width t1)) + then pf1 p else pf2 p return pf (Overlay t1 t2 _) -> do pf2 <- rf1 borders (i,j) t2 @@ -268,13 +285,14 @@ let pf p = pf1 p `mplus` pf2 p return pf - -- (x borders, y borders) -> (x,y) -> (w,h) -> rectangle of grid[x..x+w, y..y+h] + -- (x borders, y borders) -> (x,y) -> (w,h) + -- -> rectangle of grid[x..x+w, y..y+h] 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 + x1 = cwidths ! x y1 = cheights ! y - x2 = cwidths ! min (x+w) (snd $ bounds cwidths) + x2 = cwidths ! min (x+w) (snd $ bounds cwidths) y2 = cheights ! min (y+h) (snd $ bounds cheights) mx = fst (bounds cwidths) my = fst (bounds cheights) @@ -286,12 +304,13 @@ if totalws == 0 then sizes else listArray (bounds sizes) sizes' where - ws = elems weights + ws = elems weights totalws = sum ws - extra = size - sum (elems sizes) - extras = map (*(extra/totalws)) ws - sizes' = zipWith (+) extras (elems sizes) + extra = size - sum (elems sizes) + extras = map (*(extra/totalws)) ws + sizes' = zipWith (+) extras (elems sizes) -- [1,2,3] -> [0,1,3,6]. ctotal :: DArray -> DArray - ctotal a = listArray (let (i,j) = bounds a in (i,j+1)) (scanl (+) 0 (elems a)) + ctotal a = listArray (let (i,j) = bounds a in (i,j+1)) + (scanl (+) 0 (elems a)) diff --git a/Graphics/Rendering/Chart/Layout.hs b/Graphics/Rendering/Chart/Layout.hs --- a/Graphics/Rendering/Chart/Layout.hs +++ b/Graphics/Rendering/Chart/Layout.hs @@ -81,59 +81,59 @@ import Data.Colour.Names (white) -- | A @MAxisFn@ is a function that generates an (optional) axis --- given the points plotted against that axis. +-- given the points plotted against that axis. type MAxisFn t = [t] -> Maybe (AxisData t) data LayoutAxis x = LayoutAxis { laxis_title_style_ :: CairoFontStyle, - laxis_title_ :: String, - laxis_style_ :: AxisStyle, + laxis_title_ :: String, + laxis_style_ :: AxisStyle, - -- | function that determines whether an axis should be visible, - -- based upon the points plotted on this axis. The default value - -- is 'not.null' - laxis_visible_ :: [x] -> Bool, + -- | Function that determines whether an axis should be visible, + -- based upon the points plotted on this axis. The default value + -- is 'not.null'. + laxis_visible_ :: [x] -> Bool, - -- | function that generates the axis data, based upon the - -- points plotted. The default value is 'autoAxis'. - laxis_generate_ :: AxisFn x, + -- | Function that generates the axis data, based upon the + -- points plotted. The default value is 'autoAxis'. + laxis_generate_ :: AxisFn x, - -- | function that can be used to override the generated axis data. - -- The default value is 'id'. - laxis_override_ :: AxisData x -> AxisData x, + -- | Function that can be used to override the generated axis data. + -- The default value is 'id'. + laxis_override_ :: AxisData x -> AxisData x, - -- | True if left to right (bottom to top) is to show descending values - laxis_reverse_ :: Bool + -- | 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. It's --- parameterised by the types of values to be plotted on the horizonal --- and vertical axes. +-- 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_background_ :: CairoFillStyle, layout1_plot_background_ :: Maybe CairoFillStyle, - layout1_title_ :: String, - layout1_title_style_ :: CairoFontStyle, + 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_bottom_axis_ :: LayoutAxis x, + layout1_top_axis_ :: LayoutAxis x, + layout1_left_axis_ :: LayoutAxis y, + layout1_right_axis_ :: LayoutAxis y, - -- | function to map points from the left/right plot - -- to the left/right axes. The default value is 'id' - layout1_yaxes_control_ :: ([y],[y]) -> ([y],[y]), + -- | Function to map points from the left/right plot + -- to the left/right axes. The default value is 'id'. + layout1_yaxes_control_ :: ([y],[y]) -> ([y],[y]), - layout1_margin_ :: Double, - layout1_plots_ :: [Either (Plot x y) (Plot x y)], - layout1_legend_ :: Maybe(LegendStyle), + layout1_margin_ :: Double, + layout1_plots_ :: [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 + -- | True if the grid is to be rendered on top of the Plots. + layout1_grid_last_ :: Bool } data Layout1Pick x y = L1P_Legend String @@ -146,43 +146,45 @@ instance (Ord x, Ord y) => ToRenderable (Layout1 x y) where toRenderable = setPickFn nullPickFn.layout1ToRenderable --- | Encapsulates a 'Layout1' with a fixed abscissa type but arbitrary ordinate type. +-- | Encapsulates a 'Layout1' with a fixed abscissa type but +-- arbitrary ordinate type. data AnyLayout1 x = AnyLayout1 { - background :: CairoFillStyle, - titleRenderable :: Renderable (), - plotAreaGrid :: Grid (Renderable ()), + background :: CairoFillStyle, + titleRenderable :: Renderable (), + plotAreaGrid :: Grid (Renderable ()), legendRenderable :: Renderable (), - margin :: Double + margin :: Double } withAnyOrdinate :: (Ord x,Ord y) => Layout1 x y -> AnyLayout1 x withAnyOrdinate l = AnyLayout1 { - background = layout1_background_ l, - titleRenderable = mapPickFn (const ()) $ layout1TitleToRenderable l, - plotAreaGrid = fmap (mapPickFn (const ())) $ layout1PlotAreaToGrid l, + background = layout1_background_ l, + titleRenderable = mapPickFn (const ()) $ layout1TitleToRenderable l, + plotAreaGrid = fmap (mapPickFn (const ())) $ layout1PlotAreaToGrid l, legendRenderable = mapPickFn (const ()) $ layout1LegendsToRenderable l, - margin = layout1_margin_ l + margin = layout1_margin_ l } -- | Render several layouts with the same abscissa type stacked so that their --- origins and axis titles are aligned horizontally with respect to each other. --- The exterior margins and background are taken from the first element. +-- origins and axis titles are aligned horizontally with respect to each +-- other. The exterior margins and background are taken from the first +-- element. renderLayout1sStacked :: (Ord x) => [AnyLayout1 x] -> Renderable () -renderLayout1sStacked [] = emptyRenderable +renderLayout1sStacked [] = emptyRenderable renderLayout1sStacked ls@(l1:_) = gridToRenderable g where g = fullOverlayUnder (fillBackground (background l1) emptyRenderable) - $ addMarginsToGrid (lm,lm,lm,lm) - $ aboveN [ - fullRowAbove (titleRenderable l) 0 ( - fullRowBelow (legendRenderable l) 0 - (plotAreaGrid l)) - | l <- ls] + $ addMarginsToGrid (lm,lm,lm,lm) + $ aboveN [ fullRowAbove (titleRenderable l) 0 ( + fullRowBelow (legendRenderable l) 0 + (plotAreaGrid l)) + | l <- ls ] lm = margin l1 -addMarginsToGrid :: (Double,Double,Double,Double) -> Grid (Renderable a) -> Grid (Renderable a) +addMarginsToGrid :: (Double,Double,Double,Double) -> Grid (Renderable a) + -> Grid (Renderable a) addMarginsToGrid (t,b,l,r) g = aboveN [ besideN [er, ts, er], besideN [ls, g, rs], @@ -195,16 +197,18 @@ bs = tval $ spacer (0,b) rs = tval $ spacer (r,0) -layout1ToRenderable :: (Ord x, Ord y) => Layout1 x y -> Renderable (Layout1Pick x y) +layout1ToRenderable :: (Ord x, Ord y) => + Layout1 x y -> Renderable (Layout1Pick x y) layout1ToRenderable l = fillBackground (layout1_background_ l) $ gridToRenderable (layout1ToGrid l) -layout1ToGrid :: (Ord x, Ord y) => Layout1 x y -> Grid (Renderable (Layout1Pick x y)) -layout1ToGrid l = aboveN [ - tval $ layout1TitleToRenderable l, - weights (1,1) $ tval $ gridToRenderable $ - addMarginsToGrid (lm,lm,lm,lm) (layout1PlotAreaToGrid l), - tval $ layout1LegendsToRenderable l +layout1ToGrid :: (Ord x, Ord y) => + Layout1 x y -> Grid (Renderable (Layout1Pick x y)) +layout1ToGrid l = aboveN + [ tval $ layout1TitleToRenderable l + , weights (1,1) $ tval $ gridToRenderable $ + addMarginsToGrid (lm,lm,lm,lm) (layout1PlotAreaToGrid l) + , tval $ layout1LegendsToRenderable l ] where lm = layout1_margin_ l @@ -212,43 +216,46 @@ layout1TitleToRenderable :: (Ord x, Ord y) => Layout1 x y -> Renderable a layout1TitleToRenderable l = addMargins (lm/2,0,0,0) title where - title = label (layout1_title_style_ l) HTA_Centre VTA_Centre (layout1_title_ l) - lm = layout1_margin_ l + title = label (layout1_title_style_ l) HTA_Centre VTA_Centre + (layout1_title_ l) + lm = layout1_margin_ l -layout1LegendsToRenderable :: (Ord x, Ord y) => Layout1 x y -> Renderable (Layout1Pick x y) +layout1LegendsToRenderable :: (Ord x, Ord y) => + Layout1 x y -> Renderable (Layout1Pick x y) layout1LegendsToRenderable l = gridToRenderable g where - g = besideN [ tval $ mkLegend lefts, - weights (1,1) $ tval $ emptyRenderable, - tval $ mkLegend rights ] + g = besideN [ tval $ mkLegend lefts + , weights (1,1) $ tval $ emptyRenderable + , tval $ mkLegend rights ] lefts = concat [ plot_legend_ p | (Left p ) <- (layout1_plots_ l) ] rights = concat [ plot_legend_ p | (Right p) <- (layout1_plots_ l) ] - lm = layout1_margin_ l + lm = layout1_margin_ l mkLegend vals = case (layout1_legend_ l) of Nothing -> emptyRenderable - (Just ls) -> case filter ((/="").fst) vals of { - [] -> emptyRenderable ; - lvs -> addMargins (0,lm,lm,lm) - (mapPickFn L1P_Legend $ legendToRenderable (Legend True ls lvs)) - } + Just ls -> case filter ((/="").fst) vals of + [] -> emptyRenderable ; + lvs -> addMargins (0,lm,lm,lm) $ + mapPickFn L1P_Legend $ + legendToRenderable (Legend ls lvs) -layout1PlotAreaToGrid :: (Ord x, Ord y) => Layout1 x y -> Grid (Renderable (Layout1Pick x y)) +layout1PlotAreaToGrid :: (Ord x, Ord y) => + Layout1 x y -> Grid (Renderable (Layout1Pick x y)) layout1PlotAreaToGrid l = layer2 `overlay` layer1 where - layer1 = aboveN [ - besideN [er, er, er ], - besideN [er, er, er ], - besideN [er, er, weights (1,1) plots ] + layer1 = aboveN + [ besideN [er, er, er ] + , besideN [er, er, er ] + , besideN [er, er, weights (1,1) plots ] ] - 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 ] + 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 ] ] ttitle = atitle HTA_Centre VTA_Bottom 0 layout1_top_axis_ @@ -258,21 +265,26 @@ er = tval $ emptyRenderable - atitle ha va rot af = if ttext == "" then er else tval $ rlabel tstyle ha va rot ttext + 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) + ttext = laxis_title_ (af l) plots = tval $ mfill (layout1_plot_background_ l) $ plotsToRenderable l where - mfill Nothing = id + mfill Nothing = id mfill (Just fs) = fillBackground fs (ba,la,ta,ra) = getAxes l - 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 + 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 = tval $ axesSpacer fst ta fst la bl = tval $ axesSpacer fst ba snd la @@ -281,17 +293,17 @@ plotsToRenderable :: Layout1 x y -> Renderable (Layout1Pick x y) plotsToRenderable l = Renderable { - minsize=return (0,0), - render =renderPlots l + minsize = return (0,0), + render = renderPlots l } renderPlots :: Layout1 x y -> RectSize -> CRender (PickFn (Layout1Pick x y)) renderPlots l sz@(w,h) = do when (not (layout1_grid_last_ l)) renderGrids preserveCState $ do - -- render the plots - setClipRegion (Point 0 0) (Point w h) - mapM_ rPlot (layout1_plots_ l) + -- render the plots + setClipRegion (Point 0 0) (Point w h) + mapM_ rPlot (layout1_plots_ l) when (layout1_grid_last_ l) renderGrids return nullPickFn @@ -306,8 +318,8 @@ yrange = if yrev then (0, h) else (h, 0) pmfn (x,y) = Point (mapv xrange (axis_viewport_ xaxis xrange) x) (mapv yrange (axis_viewport_ yaxis yrange) y) - mapv (min,max) _ LMin = min - mapv (min,max) _ LMax = max + mapv (min,max) _ LMin = min + mapv (min,max) _ LMax = max mapv _ f (LValue v) = f v in plot_render_ p pmfn rPlot1 _ _ _ = return () @@ -323,89 +335,93 @@ oh2 <- maybeM (0,0) axisOverhang a2 return (spacer (f1 oh1, f2 oh2)) -getAxes :: Layout1 x y -> (Maybe (AxisT x), Maybe (AxisT y), Maybe (AxisT x), Maybe (AxisT y)) +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) - xvals = xvals0 ++ xvals1 - (yvals0',yvals1') = layout1_yaxes_control_ l (yvals0,yvals1) + xvals = xvals0 ++ xvals1 + (yvals0',yvals1') = layout1_yaxes_control_ l (yvals0,yvals1) bAxis = mkAxis E_Bottom (layout1_bottom_axis_ l) xvals - tAxis = mkAxis E_Top (layout1_top_axis_ l) xvals - lAxis = mkAxis E_Left (layout1_left_axis_ l) yvals0' + tAxis = mkAxis E_Top (layout1_top_axis_ l) xvals + lAxis = mkAxis E_Left (layout1_left_axis_ l) yvals0' rAxis = mkAxis E_Right (layout1_right_axis_ l) yvals1' mkAxis t laxis vals = case laxis_visible_ laxis vals of False -> Nothing - True -> Just (AxisT t style rev adata) + True -> Just (AxisT t style rev adata) where style = laxis_style_ laxis - rev = laxis_reverse_ laxis + rev = laxis_reverse_ laxis adata = (laxis_override_ laxis) (laxis_generate_ laxis vals) -allPlottedValues :: [(Either (Plot x y) (Plot x' y'))] -> ( [x], [x'], [y], [y'] ) +allPlottedValues :: [(Either (Plot x y) (Plot x' y'))] + -> ( [x], [x'], [y], [y'] ) allPlottedValues plots = (xvals0,xvals1,yvals0,yvals1) where - xvals0 = [ x | (Left p) <- plots, x <- fst $ plot_all_points_ p] - yvals0 = [ y | (Left p) <- plots, y <- snd $ plot_all_points_ p] + xvals0 = [ x | (Left p) <- plots, x <- fst $ plot_all_points_ p] + yvals0 = [ y | (Left p) <- plots, y <- snd $ plot_all_points_ p] xvals1 = [ x | (Right p) <- plots, x <- fst $ plot_all_points_ p] yvals1 = [ y | (Right p) <- plots, y <- snd $ plot_all_points_ p] defaultLayout1 :: (PlotValue x,PlotValue y) => Layout1 x y defaultLayout1 = Layout1 { - layout1_background_ = solidFillStyle $ opaque white, + layout1_background_ = solidFillStyle $ opaque white, layout1_plot_background_ = Nothing, - layout1_title_ = "", - layout1_title_style_ = defaultFontStyle{font_size_=15, font_weight_=C.FontWeightBold}, + layout1_title_ = "", + layout1_title_style_ = defaultFontStyle{font_size_ =15 + ,font_weight_ =C.FontWeightBold}, - layout1_top_axis_ = defaultLayoutAxis { - laxis_visible_ = const False - }, - layout1_bottom_axis_ = defaultLayoutAxis, - layout1_left_axis_ = defaultLayoutAxis, - layout1_right_axis_ = defaultLayoutAxis, + layout1_top_axis_ = defaultLayoutAxis {laxis_visible_ = const False}, + layout1_bottom_axis_ = defaultLayoutAxis, + layout1_left_axis_ = defaultLayoutAxis, + layout1_right_axis_ = defaultLayoutAxis, - layout1_yaxes_control_ = id, + layout1_yaxes_control_ = id, - layout1_margin_ = 10, - layout1_plots_ = [], - layout1_legend_ = Just defaultLegendStyle, - layout1_grid_last_ = False + 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_visible_ = not.null, - laxis_generate_ = autoAxis, - laxis_override_ = id, - laxis_reverse_ = False + laxis_title_ = "", + laxis_style_ = defaultAxisStyle, + laxis_visible_ = not.null, + laxis_generate_ = autoAxis, + laxis_override_ = id, + laxis_reverse_ = False } ---------------------------------------------------------------------- --- Template haskell to derive an instance of Data.Accessor.Accessor for each field +-- 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 +-- | 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) . +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) + (layout1_left_axis .> laxis_style ^: uf) . + (layout1_right_axis .> laxis_style ^: uf) --- | Helper to set the forground color uniformly on a Layout1 +-- | Helper to set the forground color uniformly on a Layout1. setLayout1Foreground :: AlphaColour Double -> Layout1 x y -> Layout1 x y -setLayout1Foreground 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)) +setLayout1Foreground 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)) -linkAxes (ys1,ys2) = (ys1++ys2,ys1++ys2) +linkAxes :: ([a], [a]) -> ([a], [a]) +linkAxes (ys1,ys2) = (ys1++ys2,ys1++ys2) + +independentAxes :: (a, b) -> (a, b) independentAxes (ys1,ys2) = (ys1,ys2) diff --git a/Graphics/Rendering/Chart/Legend.hs b/Graphics/Rendering/Chart/Legend.hs --- a/Graphics/Rendering/Chart/Legend.hs +++ b/Graphics/Rendering/Chart/Legend.hs @@ -9,11 +9,13 @@ module Graphics.Rendering.Chart.Legend( Legend(..), LegendStyle(..), + LegendOrientation(..), defaultLegendStyle, legendToRenderable, legend_label_style, legend_margin, legend_plot_size, + legend_orientation ) where import qualified Graphics.Rendering.Cairo as C @@ -31,50 +33,72 @@ data LegendStyle = LegendStyle { legend_label_style_ :: CairoFontStyle, - legend_margin_ :: Double, - legend_plot_size_ :: Double + legend_margin_ :: Double, + legend_plot_size_ :: Double, + legend_orientation_ :: LegendOrientation } -data Legend x y = Legend Bool LegendStyle [(String, Rect -> CRender ())] +-- | Legends can be constructed in two orientations: in rows +-- (where we specify the maximum number of columns), and in +-- columns (where we specify the maximum number of rows) +data LegendOrientation = LORows Int + | LOCols Int + +data Legend x y = Legend LegendStyle [(String, Rect -> CRender ())] + instance ToRenderable (Legend x y) where toRenderable = setPickFn nullPickFn.legendToRenderable legendToRenderable :: Legend x y -> Renderable String -legendToRenderable (Legend _ ls lvs) = gridToRenderable grid +legendToRenderable (Legend ls lvs) = gridToRenderable grid where - grid = besideN $ intersperse ggap1 (map (tval.rf) ps) + grid = case legend_orientation_ ls of + LORows n -> mkGrid n aboveG besideG + LOCols n -> mkGrid n besideG aboveG - ps :: [(String, [Rect -> CRender ()])] - ps = join_nub lvs + aboveG = aboveN.(intersperse ggap1) + besideG = besideN.(intersperse ggap1) - rf (title,rfs) = gridToRenderable grid1 + mkGrid n join1 join2 = join1 [ join2 (map rf ps1) | ps1 <- groups n ps ] + + ps :: [(String, [Rect -> CRender ()])] + ps = join_nub lvs + + rf (title,rfs) = besideN [gpic,ggap2,gtitle] where - grid1 = besideN $ intersperse ggap2 (map rp rfs) ++ [ggap2,gtitle] + gpic = besideN $ intersperse ggap2 (map rp rfs) gtitle = tval $ lbl title rp rfn = tval $ Renderable { - minsize = return (legend_plot_size_ ls, 0), - render = \(w,h) -> do - rfn (Rect (Point 0 0) (Point w h)) - return nullPickFn - } + minsize = return (legend_plot_size_ ls, 0), + render = \(w,h) -> do + rfn (Rect (Point 0 0) (Point w h)) + return nullPickFn + } - ggap1 = tval $ spacer (legend_margin_ ls,0) + ggap1 = tval $ spacer (legend_margin_ ls,legend_margin_ ls / 2) ggap2 = tval $ spacer1 (lbl "X") - lbl s = label (legend_label_style_ ls) HTA_Centre VTA_Centre s + lbl s = label (legend_label_style_ ls) HTA_Left VTA_Centre s +groups :: Int -> [a] -> [[a]] +groups n [] = [] +groups n vs = let (vs1,vs2) = splitAt n vs in vs1:groups n vs2 + 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 [] = [] +join_nub [] = [] +defaultLegendStyle :: LegendStyle defaultLegendStyle = LegendStyle { - legend_label_style_=defaultFontStyle, - legend_margin_=20, - legend_plot_size_=20 + legend_label_style_ = defaultFontStyle, + legend_margin_ = 20, + legend_plot_size_ = 20, + legend_orientation_ = LORows 4 } ---------------------------------------------------------------------- --- Template haskell to derive an instance of Data.Accessor.Accessor for each field +-- Template haskell to derive an instance of Data.Accessor.Accessor +-- for each field. $( deriveAccessors ''LegendStyle ) diff --git a/Graphics/Rendering/Chart/Pie.hs b/Graphics/Rendering/Chart/Pie.hs --- a/Graphics/Rendering/Chart/Pie.hs +++ b/Graphics/Rendering/Chart/Pie.hs @@ -66,67 +66,72 @@ import Graphics.Rendering.Chart.Grid data PieLayout = PieLayout { - pie_title_ :: String, + pie_title_ :: String, pie_title_style_ :: CairoFontStyle, - pie_plot_ :: PieChart, - pie_background_ :: CairoFillStyle, - pie_margin_ :: Double + pie_plot_ :: PieChart, + pie_background_ :: CairoFillStyle, + pie_margin_ :: Double } data PieChart = PieChart { - pie_data_ :: [PieItem], - pie_colors_ :: [AlphaColour Double], - pie_label_style_ :: CairoFontStyle, + pie_data_ :: [PieItem], + pie_colors_ :: [AlphaColour Double], + pie_label_style_ :: CairoFontStyle, pie_label_line_style_ :: CairoLineStyle, - pie_start_angle_ :: Double + pie_start_angle_ :: Double } data PieItem = PieItem { - pitem_label_ :: String, + pitem_label_ :: String, pitem_offset_ :: Double, - pitem_value_ :: Double + pitem_value_ :: Double } +defaultPieChart :: PieChart defaultPieChart = PieChart { - pie_data_ = [], - pie_colors_ = defaultColorSeq, - pie_label_style_ = defaultFontStyle, + pie_data_ = [], + pie_colors_ = defaultColorSeq, + pie_label_style_ = defaultFontStyle, pie_label_line_style_ = solidLine 1 $ opaque black, - pie_start_angle_ = 0 + pie_start_angle_ = 0 } +defaultPieItem :: PieItem defaultPieItem = PieItem "" 0 0 +defaultPieLayout :: PieLayout defaultPieLayout = PieLayout { - pie_background_ = solidFillStyle $ opaque white, - pie_title_ = "", - pie_title_style_ = defaultFontStyle{font_size_=15, font_weight_=C.FontWeightBold}, - pie_plot_ = defaultPieChart, - pie_margin_ = 10 + pie_background_ = solidFillStyle $ opaque 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) ( - gridToRenderable $ aboveN [ - tval $ addMargins (lm/2,0,0,0) title, - weights (1,1) $ tval $ addMargins (lm,lm,lm,lm) (toRenderable $ pie_plot_ 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 + lm = pie_margin_ p instance ToRenderable PieChart where toRenderable p = Renderable { - minsize=minsizePie p, - render=renderPie p + minsize = minsizePie p, + render = renderPie p } extraSpace p = do 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 maxw = foldr (max.fst) 0 textSizes + let maxh = foldr (max.snd) 0 textSizes + let maxo = foldr (max.pitem_offset_) 0 (pie_data_ p) let extra = label_rgap + label_rlength + maxo return (extra + maxw, extra + maxh ) @@ -134,26 +139,29 @@ (extraw,extrah) <- extraSpace p return (extraw * 2, extrah * 2) -renderPie p (w,h) = 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 (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 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 ] + in [ pi{pitem_value_=pitem_value_ pi/total} + | pi <- pie_data_ p ] - paint :: Point -> Double -> Double -> (AlphaColour Double, PieItem) -> CRender Double + paint :: Point -> Double -> Double -> (AlphaColour Double, PieItem) + -> CRender Double paint center radius a1 (color,pitem) = do - let ax = 360.0 * (pitem_value_ pitem) - let a2 = a1 + (ax / 2) - let a3 = a1 + ax + let ax = 360.0 * (pitem_value_ pitem) + let a2 = a1 + (ax / 2) + let a3 = a1 + ax let offset = pitem_offset_ pitem pieSlice (ray a2 offset) a1 a3 color @@ -168,19 +176,20 @@ setLineStyle (pie_label_line_style_ p) moveTo (ray angle (radius + label_rgap+offset)) - let p1 = (ray angle (radius + label_rgap + label_rlength+offset)) + let p1 = ray angle (radius+label_rgap+label_rlength+offset) lineTo p1 (tw,th) <- textSize name let (offset,anchor) = if angle < 90 || angle > 270 then ((0+),HTA_Left) else ((0-),HTA_Right) - c $ C.relLineTo (offset (tw + label_rgap)) 0 + c $ C.relLineTo (offset (tw + label_rgap)) 0 c $ C.stroke let p2 = p1 `pvadd` (Vector (offset label_rgap) 0) drawText anchor VTA_Bottom p2 name - pieSlice :: Point -> Double -> Double -> AlphaColour Double -> CRender () + pieSlice :: Point -> Double -> Double -> AlphaColour Double + -> CRender () pieSlice (Point x y) a1 a2 color = c $ do C.newPath C.arc x y radius (radian a1) (radian a2) @@ -197,8 +206,8 @@ ray :: Double -> Double -> Point ray angle r = Point x' y' where - x' = x + (cos' * x'') - y' = y + (sin' * x'') + x' = x + (cos' * x'') + y' = y + (sin' * x'') cos' = (cos . radian) angle sin' = (sin . radian) angle x'' = ((x + r) - x) @@ -212,8 +221,8 @@ label_rlength = 15 ---------------------------------------------------------------------- --- Template haskell to derive an instance of Data.Accessor.Accessor for each field +-- Template haskell to derive an instance of Data.Accessor.Accessor +-- for each field. $( deriveAccessors ''PieLayout ) $( deriveAccessors ''PieChart ) $( deriveAccessors ''PieItem ) - diff --git a/Graphics/Rendering/Chart/Plot.hs b/Graphics/Rendering/Chart/Plot.hs --- a/Graphics/Rendering/Chart/Plot.hs +++ b/Graphics/Rendering/Chart/Plot.hs @@ -23,6 +23,8 @@ -- -- * 'PlotHidden' -- +-- * 'PlotAnnotation' +-- -- 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 @@ -36,37 +38,49 @@ {-# OPTIONS_GHC -XTemplateHaskell #-} module Graphics.Rendering.Chart.Plot( + -- * Plot Plot(..), + joinPlot, + -- ** Typeclass for casting to plot ToPlot(..), + -- * Point plots PlotPoints(..), - PlotErrBars(..), + defaultPlotPoints, + -- * Lines plot PlotLines(..), - PlotFillBetween(..), + defaultPlotLines, + defaultPlotLineStyle, + hlinePlot, + vlinePlot, + -- * Plot with error bars + PlotErrBars(..), + defaultPlotErrBars, ErrPoint(..), + ErrValue(..), + symErrPoint, + -- * Plot with filled area + PlotFillBetween(..), + defaultPlotFillBetween, + -- * Bar plots PlotBars(..), + defaultPlotBars, PlotBarsStyle(..), PlotBarsSpacing(..), PlotBarsAlignment(..), BarsPlotValue(..), + -- * Invisible plot PlotHidden(..), - - symErrPoint, - - defaultPlotLineStyle, - defaultPlotPoints, - defaultPlotErrBars, - defaultPlotFillBetween, - defaultPlotLines, - defaultPlotBars, + -- Annotation plot + PlotAnnotation(..), + defaultPlotAnnotation, + -- * Accessors + -- | These accessors are generated by template haskell plot_lines_title, plot_lines_style, plot_lines_values, plot_lines_limit_values, - hlinePlot, - vlinePlot, - plot_render, plot_legend, plot_all_points, @@ -92,8 +106,14 @@ plot_bars_spacing, plot_bars_alignment, plot_bars_reference, - plot_bars_values + plot_bars_singleton_width, + plot_bars_values, + plot_annotation_hanchor, + plot_annotation_vanchor, + plot_annotation_angle, + plot_annotation_style, + plot_annotation_values ) where import qualified Graphics.Rendering.Cairo as C @@ -110,24 +130,39 @@ -- | Interface to control plotting on a 2D area. data Plot x y = Plot { - -- | Given the mapping between model space coordinates and device coordinates, - -- render this plot into a chart. - plot_render_ :: PointMapFn x y -> CRender (), + -- | Given the mapping between model space coordinates and device + -- coordinates, render this plot into a chart. + plot_render_ :: PointMapFn x y -> CRender (), -- | Details for how to show this plot in a legend. For each item - -- the string is the text to show, and the function renders a - -- graphical sample of the plot - plot_legend_ :: [ (String, Rect -> CRender ()) ], + -- the string is the text to show, and the function renders a + -- graphical sample of the plot. + plot_legend_ :: [ (String, Rect -> CRender ()) ], -- | All of the model space coordinates to be plotted. These are - -- used to autoscale the axes where necessary. + -- used to autoscale the axes where necessary. plot_all_points_ :: ([x],[y]) } --- | a type class abstracting the conversion of a value to a Plot. +-- | A type class abstracting the conversion of a value to a Plot. class ToPlot a where toPlot :: a x y -> Plot x y +-- | Join any two plots together (they will share a legend). +joinPlot :: Plot x y -> Plot x y -> Plot x y +joinPlot Plot{ plot_render_ = renderP + , plot_legend_ = legendP + , plot_all_points_ = (xsP,ysP) } + Plot{ plot_render_ = renderQ + , plot_legend_ = legendQ + , plot_all_points_ = (xsQ,ysQ) } + + = Plot{ plot_render_ = \a-> renderP a >> renderQ a + , plot_legend_ = legendP ++ legendQ + , plot_all_points_ = ( xsP++xsQ, ysP++ysQ ) + } + + ---------------------------------------------------------------------- mapXY :: PointMapFn x y -> ((x,y) -> Point) @@ -136,20 +171,19 @@ ---------------------------------------------------------------------- -- | Value defining a series of (possibly disjointed) lines, --- and a style in which to render them +-- and a style in which to render them. data PlotLines x y = PlotLines { - plot_lines_title_ :: String, - plot_lines_style_ :: CairoLineStyle, - plot_lines_values_ :: [[(x,y)]], + plot_lines_title_ :: String, + plot_lines_style_ :: CairoLineStyle, + plot_lines_values_ :: [[(x,y)]], plot_lines_limit_values_ :: [[(Limit x, Limit y)]] } - instance ToPlot PlotLines where toPlot p = Plot { - plot_render_ = renderPlotLines p, - plot_legend_ = [(plot_lines_title_ p, renderPlotLegendLines p)], - plot_all_points_ = (map fst pts ++ xs , map snd pts ++ ys) + plot_render_ = renderPlotLines p, + plot_legend_ = [(plot_lines_title_ p, renderPlotLegendLines p)], + plot_all_points_ = ( map fst pts ++ xs, map snd pts ++ ys ) } where pts = concat (plot_lines_values_ p) @@ -162,63 +196,60 @@ mapM_ (drawLines (mapXY pmap)) (plot_lines_values_ p) mapM_ (drawLines pmap) (plot_lines_limit_values_ p) where - drawLines pmap (p:ps) = do - moveTo (pmap p) - mapM_ (\p -> lineTo (pmap p)) ps - c $ C.stroke + drawLines mapfn pts = strokePath (map mapfn pts) renderPlotLegendLines :: PlotLines x y -> Rect -> CRender () renderPlotLegendLines p r@(Rect p1 p2) = preserveCState $ do 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 + strokePath [Point (p_x p1) y, Point (p_x p2) y] +defaultPlotLineStyle :: CairoLineStyle defaultPlotLineStyle = (solidLine 1 $ opaque blue){ - line_cap_ = C.LineCapRound, + line_cap_ = C.LineCapRound, line_join_ = C.LineJoinRound } +defaultPlotLines :: PlotLines x y defaultPlotLines = PlotLines { - plot_lines_title_ = "", - plot_lines_style_ = defaultPlotLineStyle, - plot_lines_values_ = [], + plot_lines_title_ = "", + plot_lines_style_ = defaultPlotLineStyle, + plot_lines_values_ = [], plot_lines_limit_values_ = [] } --- | Helper function to plot a single horizontal line +-- | Helper function to plot a single horizontal line. hlinePlot :: String -> CairoLineStyle -> b -> Plot a b hlinePlot t ls v = toPlot defaultPlotLines { - plot_lines_title_=t, - plot_lines_style_=ls, - plot_lines_limit_values_=[[(LMin, LValue v),(LMax, LValue v)]] + plot_lines_title_ = t, + plot_lines_style_ = ls, + plot_lines_limit_values_ = [[(LMin, LValue v),(LMax, LValue v)]] } --- | Helper function to plot a single vertical line +-- | Helper function to plot a single vertical line. vlinePlot :: String -> CairoLineStyle -> a -> Plot a b vlinePlot t ls v = toPlot defaultPlotLines { - plot_lines_title_=t, - plot_lines_style_=ls, - plot_lines_limit_values_=[[(LValue v,LMin),(LValue v,LMax)]] + plot_lines_title_ = t, + plot_lines_style_ = ls, + plot_lines_limit_values_ = [[(LValue v,LMin),(LValue v,LMax)]] } ---------------------------------------------------------------------- -- | Value defining a series of datapoints, and a style in --- which to render them +-- which to render them. data PlotPoints x y = PlotPoints { - plot_points_title_ :: String, - plot_points_style_ :: CairoPointStyle, + plot_points_title_ :: String, + plot_points_style_ :: CairoPointStyle, plot_points_values_ :: [(x,y)] } instance ToPlot PlotPoints where toPlot p = Plot { - plot_render_ = renderPlotPoints p, - plot_legend_ = [(plot_points_title_ p, renderPlotLegendPoints p)], - plot_all_points_ = (map fst pts, map snd pts) + plot_render_ = renderPlotPoints p, + plot_legend_ = [(plot_points_title_ p, renderPlotLegendPoints p)], + plot_all_points_ = (map fst pts, map snd pts) } where pts = plot_points_values_ p @@ -233,77 +264,75 @@ 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_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)) + drawPoint (Point (p_x p2) ((p_y p1 + p_y p2)/2)) where (CairoPointStyle drawPoint) = (plot_points_style_ p) +defaultPlotPoints :: PlotPoints x y defaultPlotPoints = PlotPoints { - plot_points_title_ = "", - plot_points_style_ =defaultPointStyle, + plot_points_title_ = "", + plot_points_style_ = defaultPointStyle, plot_points_values_ = [] } ---------------------------------------------------------------------- -- | Value specifying a plot filling the area between two sets of Y --- coordinates, given common X coordinates. +-- coordinates, given common X coordinates. data PlotFillBetween x y = PlotFillBetween { - plot_fillbetween_title_ :: String, - plot_fillbetween_style_ :: CairoFillStyle, + plot_fillbetween_title_ :: String, + plot_fillbetween_style_ :: CairoFillStyle, plot_fillbetween_values_ :: [ (x, (y,y))] } instance ToPlot PlotFillBetween where toPlot p = Plot { - plot_render_ = renderPlotFillBetween p, - plot_legend_ = [(plot_fillbetween_title_ p, renderPlotLegendFill p)], - plot_all_points_ = plotAllPointsFillBetween p + plot_render_ = renderPlotFillBetween p, + plot_legend_ = [(plot_fillbetween_title_ p,renderPlotLegendFill p)], + plot_all_points_ = plotAllPointsFillBetween p } renderPlotFillBetween :: PlotFillBetween x y -> PointMapFn x y -> CRender () -renderPlotFillBetween p pmap = renderPlotFillBetween' p (plot_fillbetween_values_ p) pmap +renderPlotFillBetween p pmap = + renderPlotFillBetween' p (plot_fillbetween_values_ p) pmap renderPlotFillBetween' p [] _ = return () renderPlotFillBetween' p vs pmap = preserveCState $ do setFillStyle (plot_fillbetween_style_ p) - moveTo p0 - mapM_ lineTo p1s - mapM_ lineTo (reverse p2s) - lineTo p0 - c $ C.fill + fillPath ([p0] ++ p1s ++ reverse p2s ++ [p0]) where - pmap' = mapXY pmap + pmap' = mapXY pmap (p0:p1s) = map pmap' [ (x,y1) | (x,(y1,y2)) <- vs ] - p2s = map pmap' [ (x,y2) | (x,(y1,y2)) <- vs ] + p2s = map pmap' [ (x,y2) | (x,(y1,y2)) <- vs ] renderPlotLegendFill :: PlotFillBetween x y -> Rect -> CRender () renderPlotLegendFill p r = preserveCState $ do setFillStyle (plot_fillbetween_style_ p) - rectPath r - c $ C.fill + fillPath (rectPath r) plotAllPointsFillBetween :: PlotFillBetween x y -> ([x],[y]) -plotAllPointsFillBetween p = ([x|(x,(_,_)) <- pts], concat [[y1,y2]|(_,(y1,y2)) <- pts]) +plotAllPointsFillBetween p = ( [ x | (x,(_,_)) <- pts ] + , concat [ [y1,y2] | (_,(y1,y2)) <- pts ] ) where pts = plot_fillbetween_values_ p +defaultPlotFillBetween :: PlotFillBetween x y defaultPlotFillBetween = PlotFillBetween { - plot_fillbetween_title_ = "", - plot_fillbetween_style_ = solidFillStyle (opaque $ sRGB 0.5 0.5 1.0), - plot_fillbetween_values_= [] + plot_fillbetween_title_ = "", + plot_fillbetween_style_ = solidFillStyle (opaque $ sRGB 0.5 0.5 1.0), + plot_fillbetween_values_ = [] } ---------------------------------------------------------------------- --- | Value for holding a point with associated error bounds for --- each axis. +-- | Value for holding a point with associated error bounds for each axis. data ErrValue x = ErrValue { - ev_low :: x, + ev_low :: x, ev_best :: x, ev_high :: x } deriving Show @@ -313,27 +342,30 @@ ep_y :: ErrValue y } deriving Show --- | When the error is symetric, we can simply pass in dx for the error +-- | When the error is symmetric, we can simply pass in dx for the error. +symErrPoint :: (Num a, Num b) => a -> b -> a -> b -> ErrPoint a b 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 +-- which to render them. data PlotErrBars x y = PlotErrBars { - plot_errbars_title_ :: String, - plot_errbars_line_style_ :: CairoLineStyle, + plot_errbars_title_ :: String, + plot_errbars_line_style_ :: CairoLineStyle, plot_errbars_tick_length_ :: Double, - plot_errbars_overhang_ :: Double, - plot_errbars_values_ :: [ErrPoint x y] + plot_errbars_overhang_ :: Double, + plot_errbars_values_ :: [ErrPoint x y] } instance ToPlot PlotErrBars where toPlot p = Plot { - plot_render_ = renderPlotErrBars p, - plot_legend_ = [(plot_errbars_title_ p,renderPlotLegendErrBars p)], - plot_all_points_ = ( concat [[ev_low x,ev_high x] |ErrPoint x _ <- pts ], - concat [[ev_low y,ev_high y] |ErrPoint _ y <- pts ] ) + plot_render_ = renderPlotErrBars p, + plot_legend_ = [(plot_errbars_title_ p, renderPlotLegendErrBars p)], + plot_all_points_ = ( concat [ [ev_low x,ev_high x] + | ErrPoint x _ <- pts ] + , concat [ [ev_low y,ev_high y] + | ErrPoint _ y <- pts ] ) } where pts = plot_errbars_values_ p @@ -344,11 +376,11 @@ where 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) + where (Point x' y') = pmap' (x,y) (Point xl' yl') = pmap' (xl,yl) (Point xh' yh') = pmap' (xh,yh) drawErrBar = drawErrBar0 p - pmap' = mapXY pmap + pmap' = mapXY pmap drawErrBar0 ps (ErrPoint (ErrValue xl x xh) (ErrValue yl y yh)) = do let tl = plot_errbars_tick_length_ ps @@ -371,112 +403,118 @@ renderPlotLegendErrBars :: PlotErrBars x y -> Rect -> CRender () renderPlotLegendErrBars p r@(Rect p1 p2) = preserveCState $ do - drawErrBar (symErrPoint (p_x p1) ((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) + 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) + dx = min ((p_x p2 - p_x p1)/6) ((p_y p2 - p_y p1)/2) +defaultPlotErrBars :: PlotErrBars x y defaultPlotErrBars = PlotErrBars { - plot_errbars_title_ = "", - plot_errbars_line_style_ = solidLine 1 $ opaque blue, + plot_errbars_title_ = "", + plot_errbars_line_style_ = solidLine 1 $ opaque blue, plot_errbars_tick_length_ = 3, - plot_errbars_overhang_ = 0, - plot_errbars_values_ = [] + plot_errbars_overhang_ = 0, + plot_errbars_values_ = [] } ---------------------------------------------------------------------- class PlotValue a => BarsPlotValue a where barsReference :: a - barsAdd :: a -> a -> a + barsAdd :: a -> a -> a instance BarsPlotValue Double where barsReference = 0 - barsAdd = (+) + barsAdd = (+) instance BarsPlotValue Int where barsReference = 0 - barsAdd = (+) + barsAdd = (+) -data PlotBarsStyle = BarsStacked -- ^ Bars for a fixed x are stacked vertically - -- on top of each other - | BarsClustered -- ^ Bars for a fixed x are put horizontally - -- beside each other +data PlotBarsStyle + = BarsStacked -- ^ Bars for a fixed x are stacked vertically + -- on top of each other. + | BarsClustered -- ^ Bars for a fixed x are put horizontally + -- beside each other. deriving (Show) -data PlotBarsSpacing = BarsFixWidth Double -- ^ All bars have the same width in pixels - | BarsFixGap Double -- ^ There is the same interval in pixels - -- between adjacent bars +data PlotBarsSpacing + = BarsFixWidth Double -- ^ All bars have the same width in pixels. + | BarsFixGap Double Double -- ^ (BarsFixGap g mw) means make the gaps between + -- the bars equal to g, but with a minimum bar width + -- of mw deriving (Show) -- | How bars for a given (x,[y]) are aligned with respect to screen --- coordinate corresponding to x (deviceX) +-- coordinate corresponding to x (deviceX). data PlotBarsAlignment = BarsLeft -- ^ The left edge of bars is at deviceX | BarsCentered -- ^ The right edge of bars is at deviceX | BarsRight -- ^ Bars are centered around deviceX deriving (Show) -- | Value describing how to plot a set of bars. --- Note that the input data is typed [(x,[y])], ie for each x value --- we plot several y values. Typically the size of each [y] list would --- be the same. +-- Note that the input data is typed [(x,[y])], ie for each x value +-- we plot several y values. Typically the size of each [y] list would +-- be the same. data PlotBars x y = PlotBars { -- | This value specifies whether each value from [y] should be - -- shown beside or above the previous value. - plot_bars_style_ :: PlotBarsStyle, + -- shown beside or above the previous value. + plot_bars_style_ :: PlotBarsStyle, -- | The style in which to draw each element of [y]. A fill style - -- is required, and if a linestyle is given, each bar will be - -- outlined. - plot_bars_item_styles_ :: [ (CairoFillStyle,Maybe CairoLineStyle) ], + -- is required, and if a linestyle is given, each bar will be + -- outlined. + plot_bars_item_styles_ :: [ (CairoFillStyle,Maybe CairoLineStyle) ], - -- | The title of each element of [y]. These will be shown in the - -- legend. - plot_bars_titles_ :: [String], + -- | The title of each element of [y]. These will be shown in the legend. + plot_bars_titles_ :: [String], -- | This value controls how the widths of the bars are - -- calculated. Either the widths of the bars, or the gaps between - -- them can be fixed. - plot_bars_spacing_ :: PlotBarsSpacing, + -- calculated. Either the widths of the bars, or the gaps between + -- them can be fixed. + plot_bars_spacing_ :: PlotBarsSpacing, -- | This value controls how bars for a fixed x are aligned with - -- respect to the device coordinate corresponding to x - plot_bars_alignment_ :: PlotBarsAlignment, + -- respect to the device coordinate corresponding to x. + plot_bars_alignment_ :: PlotBarsAlignment, -- | The starting level for the chart (normally 0). - plot_bars_reference_ :: y, + plot_bars_reference_ :: y, plot_bars_singleton_width_ :: Double, - -- | The actual points to be plotted - plot_bars_values_ :: [ (x,[y]) ] + -- | The actual points to be plotted. + plot_bars_values_ :: [ (x,[y]) ] } defaultPlotBars :: BarsPlotValue y => PlotBars x y defaultPlotBars = PlotBars { - plot_bars_style_ = BarsClustered, - plot_bars_item_styles_ = cycle istyles, - plot_bars_titles_ = [], - plot_bars_spacing_ = BarsFixGap 10, - plot_bars_alignment_ = BarsCentered, - plot_bars_values_ = [], + plot_bars_style_ = BarsClustered, + plot_bars_item_styles_ = cycle istyles, + plot_bars_titles_ = [], + plot_bars_spacing_ = BarsFixGap 10 2, + plot_bars_alignment_ = BarsCentered, + plot_bars_values_ = [], plot_bars_singleton_width_ = 20, - plot_bars_reference_ = barsReference + plot_bars_reference_ = barsReference } where - istyles = map mkstyle defaultColorSeq - mkstyle c = (solidFillStyle c,Just (solidLine 1.0 $ opaque black)) + istyles = map mkstyle defaultColorSeq + mkstyle c = (solidFillStyle c, Just (solidLine 1.0 $ opaque black)) plotBars :: (BarsPlotValue y) => PlotBars x y -> Plot x y plotBars p = Plot { - plot_render_ = renderPlotBars p, - plot_legend_ = zip (plot_bars_titles_ p) (map renderPlotLegendBars (plot_bars_item_styles_ p)), - plot_all_points_ = allBarPoints p + plot_render_ = renderPlotBars p, + plot_legend_ = zip (plot_bars_titles_ p) + (map renderPlotLegendBars + (plot_bars_item_styles_ p)), + plot_all_points_ = allBarPoints p } -renderPlotBars :: (BarsPlotValue y) => PlotBars x y -> PointMapFn x y -> CRender () +renderPlotBars :: (BarsPlotValue y) => + PlotBars x y -> PointMapFn x y -> CRender () renderPlotBars p pmap = case (plot_bars_style_ p) of BarsClustered -> forM_ vals clusteredBars BarsStacked -> forM_ vals stackedBars @@ -484,13 +522,12 @@ clusteredBars (x,ys) = preserveCState $ do forM_ (zip3 [0,1..] ys styles) $ \(i, y, (fstyle,_)) -> do setFillStyle fstyle - barPath (offset i) x yref0 y + fillPath (barPath (offset i) x yref0 y) c $ C.fill forM_ (zip3 [0,1..] ys styles) $ \(i, y, (_,mlstyle)) -> do whenJust mlstyle $ \lstyle -> do setLineStyle lstyle - barPath (offset i) x yref0 y - c $ C.stroke + strokePath (barPath (offset i) x yref0 y) offset = case (plot_bars_alignment_ p) of BarsLeft -> \i -> fromIntegral i * width @@ -506,13 +543,11 @@ } forM_ (zip y2s styles) $ \((y0,y1), (fstyle,_)) -> do setFillStyle fstyle - barPath ofs x y0 y1 - c $ C.fill + fillPath (barPath ofs x y0 y1) forM_ (zip y2s styles) $ \((y0,y1), (_,mlstyle)) -> do whenJust mlstyle $ \lstyle -> do setLineStyle lstyle - barPath ofs x y0 y1 - c $ C.stroke + strokePath (barPath ofs x y0 y1) barPath xos x y0 y1 = do let (Point x' y') = pmap' (x,y1) @@ -522,9 +557,10 @@ yref0 = plot_bars_reference_ p vals = plot_bars_values_ p width = case plot_bars_spacing_ p of - BarsFixGap gap -> case (plot_bars_style_ p) of - BarsClustered -> (minXInterval - gap) / fromIntegral nys - BarsStacked -> (minXInterval - gap) + BarsFixGap gap minw -> let w = max (minXInterval - gap) minw in + case (plot_bars_style_ p) of + BarsClustered -> w / fromIntegral nys + BarsStacked -> w BarsFixWidth width -> width styles = plot_bars_item_styles_ p @@ -533,41 +569,40 @@ then plot_bars_singleton_width_ p else minimum diffs where - xs = fst (allBarPoints p) + xs = fst (allBarPoints p) mxs = nub $ sort $ map mapX xs - nys = maximum [ length ys | (x,ys) <- vals ] + nys = maximum [ length ys | (x,ys) <- vals ] - pmap' = mapXY pmap + pmap' = mapXY pmap mapX x = p_x (pmap' (x,barsReference)) whenJust :: (Monad m) => Maybe a -> (a -> m ()) -> m () whenJust (Just a) f = f a -whenJust _ _ = return () +whenJust _ _ = return () allBarPoints :: (BarsPlotValue y) => PlotBars x y -> ([x],[y]) allBarPoints p = case (plot_bars_style_ p) of - BarsClustered -> ( [x| (x,_) <- pts], concat [ys| (_,ys) <- pts] ) - BarsStacked -> ( [x| (x,_) <- pts], concat [stack ys | (_,ys) <- pts] ) + BarsClustered -> ( [x| (x,_) <- pts], y0:concat [ys| (_,ys) <- pts] ) + BarsStacked -> ( [x| (x,_) <- pts], y0:concat [stack ys | (_,ys) <- pts] ) where pts = plot_bars_values_ p - y0 = plot_bars_reference_ p + y0 = plot_bars_reference_ p stack :: (BarsPlotValue y) => [y] -> [y] stack ys = scanl1 barsAdd ys -renderPlotLegendBars :: (CairoFillStyle,Maybe CairoLineStyle) -> Rect -> CRender () +renderPlotLegendBars :: (CairoFillStyle,Maybe CairoLineStyle) -> Rect + -> CRender () renderPlotLegendBars (fstyle,mlstyle) r@(Rect p1 p2) = do setFillStyle fstyle - rectPath r - c $ C.fill + fillPath (rectPath r) ---------------------------------------------------------------------- -- | Value defining some hidden x and y values. The values don't --- get displayed, but still affect axis scaling. - +-- get displayed, but still affect axis scaling. data PlotHidden x y = PlotHidden { plot_hidden_x_values_ :: [x], plot_hidden_y_values_ :: [y] @@ -575,13 +610,65 @@ instance ToPlot PlotHidden where toPlot ph = Plot { - plot_render_ = \_ -> return (), - plot_legend_ = [], + plot_render_ = \_ -> return (), + plot_legend_ = [], plot_all_points_ = (plot_hidden_x_values_ ph, plot_hidden_y_values_ ph) - } + } + + ---------------------------------------------------------------------- --- Template haskell to derive an instance of Data.Accessor.Accessor for each field + +-- | Value for describing a series of text annotations +-- to be placed at arbitrary points on the graph. Annotations +-- can be rotated and styled. Rotation angle is given in degrees, +-- rotation is performend around the anchor point. + +data PlotAnnotation x y = PlotAnnotation { + plot_annotation_hanchor_ :: HTextAnchor, + plot_annotation_vanchor_ :: VTextAnchor, + plot_annotation_angle_ :: Double, + plot_annotation_style_ :: CairoFontStyle, + plot_annotation_values_ :: [(x,y,String)] +} + + +instance ToPlot PlotAnnotation where + toPlot p = Plot { + plot_render_ = renderAnnotation p, + plot_legend_ = [], + plot_all_points_ = (map (\(x,_,_)->x) vs , map (\(_,y,_)->y) vs) + } + where + vs = plot_annotation_values_ p + + +renderAnnotation :: PlotAnnotation x y -> PointMapFn x y -> CRender () + +renderAnnotation p pMap = preserveCState $ do + setFontStyle style + mapM_ drawOne values + where hta = plot_annotation_hanchor_ p + vta = plot_annotation_vanchor_ p + values = plot_annotation_values_ p + angle = plot_annotation_angle_ p + style = plot_annotation_style_ p + drawOne (x,y,s) = drawTextR hta vta angle point s + where point = pMap (LValue x, LValue y) + +defaultPlotAnnotation = PlotAnnotation { + plot_annotation_hanchor_ = HTA_Centre, + plot_annotation_vanchor_ = VTA_Centre, + plot_annotation_angle_ = 0, + plot_annotation_style_ = defaultFontStyle, + plot_annotation_values_ = [] +} + + + +---------------------------------------------------------------------- +-- Template haskell to derive an instance of Data.Accessor.Accessor +-- for each field. $( deriveAccessors ''Plot ) $( deriveAccessors ''PlotLines ) $( deriveAccessors ''PlotPoints ) @@ -589,3 +676,4 @@ $( deriveAccessors ''PlotErrBars ) $( deriveAccessors ''PlotBars ) $( deriveAccessors ''PlotHidden ) +$( deriveAccessors ''PlotAnnotation ) diff --git a/Graphics/Rendering/Chart/Renderable.hs b/Graphics/Rendering/Chart/Renderable.hs --- a/Graphics/Rendering/Chart/Renderable.hs +++ b/Graphics/Rendering/Chart/Renderable.hs @@ -47,75 +47,61 @@ import Graphics.Rendering.Chart.Types --- | A function that maps a point in device coordinates --- to some value. +-- | 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. +-- 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. +-- graphic element. data Renderable a = Renderable { - -- | a Cairo action to calculate a minimum size, + -- | A Cairo action to calculate a minimum size. minsize :: CRender RectSize, - -- | a Cairo action for drawing it within a rectangle. - -- The rectangle is from the origin to the given point. + -- | 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) + -- 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. - +-- | A type class abtracting the conversion of a value to a Renderable. class ToRenderable a where toRenderable :: a -> Renderable () +emptyRenderable :: Renderable a emptyRenderable = spacer (0,0) --- | Create a blank renderable with a specified minimum size +-- | Create a blank renderable with a specified minimum size. spacer :: RectSize -> Renderable a -spacer sz = Renderable { +spacer sz = Renderable { minsize = return sz, render = \_ -> return nullPickFn } -- | Create a blank renderable with a minimum size the same as --- some other renderable. +-- some other renderable. spacer1 :: Renderable a -> Renderable b -spacer1 r = Renderable { - minsize = minsize r, - render = \_ -> return nullPickFn -} +spacer1 r = r{ render = \_ -> return nullPickFn } --- | Replace the pick function of a renderable with another +-- | 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; } - } +setPickFn pickfn r = r{ render = \sz -> do { render r sz; return pickfn; } } --- | Map a function over result of a renderables pickfunction. +-- | Map a function over result of a renderable's 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)); - } - } +mapPickFn f r = r{ render = \sz -> do pf <- render r sz + return (fmap f . pf) } -- | Add some spacing at the edges of a renderable. -addMargins :: (Double,Double,Double,Double) -- ^ The spacing to be added - -> Renderable a -- ^ The source 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 @@ -127,13 +113,13 @@ preserveCState $ do c $ C.translate l t pickf <- render rd (w-l-r,h-t-b) - mtx <- c $ C.getMatrix + mtx <- c $ C.getMatrix return (mkpickf pickf (w,h) mtx) mkpickf pickf (w,h) mtx pt | within pt' rect = pickf pt' - | otherwise = Nothing + | otherwise = Nothing where - pt' = transform mtx pt + pt' = transform mtx pt rect = (Rect (Point 0 0) (Point w h)) transform :: C.Matrix -> Point -> Point @@ -141,7 +127,7 @@ -- | Overlay a renderable over a solid background fill. fillBackground :: CairoFillStyle -> Renderable a -> Renderable a -fillBackground fs r = Renderable { minsize = minsize r, render = rf } +fillBackground fs r = r{ render = rf } where rf rsize@(w,h) = do preserveCState $ do @@ -151,7 +137,7 @@ render r rsize -- | Output the given renderable to a PNG file of the specifed size --- (in pixels), to the specified file. +-- (in pixels), to the specified file. renderableToPNGFile :: Renderable a -> Int -> Int -> FilePath -> IO () renderableToPNGFile chart width height path = C.withImageSurface C.FormatARGB32 width height $ \result -> do @@ -171,47 +157,50 @@ c $ C.showPage -- | Output the given renderable to a PDF file of the specifed size --- (in points), to the specified file. +-- (in points), to the specified file. 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 a -> Int -> Int -> FilePath -> IO () -renderableToPSFile = renderableToFile C.withPSSurface +-- (in points), to the specified file. +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. +-- (in points), to the specified file. renderableToSVGFile :: Renderable a -> Int -> Int -> FilePath -> IO () renderableToSVGFile = renderableToFile C.withSVGSurface +bitmapEnv :: CEnv bitmapEnv = CEnv (adjfn 0.5) (adjfn 0.0) where adjfn offset (Point x y) = Point (adj x) (adj y) where adj v = (fromIntegral.round) v +offset +vectorEnv :: CEnv vectorEnv = CEnv id id -- | Helper function for using a renderable, when we generate it --- in the CRender monad. +-- 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 } + render = \ r -> do { a <- ca; render a r } } ---------------------------------------------------------------------- -- Labels --- | Construct a renderable from a text string, aligned with the axes +-- | 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 -- | 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 +-- 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 @@ -228,15 +217,15 @@ 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_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 - yadj (w,h) VTA_Top y1 y2 = y1 +(w*asr+h*acr)/2 + xadj (w,h) HTA_Right x1 x2 = x2 -(w*acr+h*asr)/2 + yadj (w,h) VTA_Top y1 y2 = y1 +(w*asr+h*acr)/2 yadj (w,h) VTA_Centre y1 y2 = (y1+y2)/2 yadj (w,h) VTA_Bottom y1 y2 = y2 - (w*asr+h*acr)/2 - rot' = rot / 180 * pi - (cr,sr) = (cos rot', sin rot') + rot' = rot / 180 * pi + (cr,sr) = (cos rot', sin rot') (acr,asr) = (abs cr, abs sr) ---------------------------------------------------------------------- @@ -247,36 +236,45 @@ | RCornerRounded Double data Rectangle = Rectangle { - rect_minsize_ :: RectSize, - rect_fillStyle_ :: Maybe CairoFillStyle, - rect_lineStyle_ :: Maybe CairoLineStyle, + 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_minsize_. +rect_minsize :: Accessor Rectangle RectSize +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_fillStyle_. +rect_fillStyle :: Accessor Rectangle (Maybe CairoFillStyle) +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_lineStyle_. +rect_lineStyle :: Accessor Rectangle (Maybe CairoLineStyle) +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}) +-- | Accessor for field rect_cornerStyle_. +rect_cornerStyle :: Accessor Rectangle RectCornerStyle +rect_cornerStyle = accessor (\v->rect_cornerStyle_ v) + (\a v -> v{rect_cornerStyle_=a}) +defaultRectangle :: Rectangle defaultRectangle = Rectangle { - rect_minsize_ = (0,0), - rect_fillStyle_ = Nothing, - rect_lineStyle_ = Nothing, + 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) + mf = return (rect_minsize_ rectangle) rf sz = preserveCState $ do maybeM () (fill sz) (rect_fillStyle_ rectangle) maybeM () (stroke sz) (rect_lineStyle_ rectangle) diff --git a/Graphics/Rendering/Chart/Simple.hs b/Graphics/Rendering/Chart/Simple.hs --- a/Graphics/Rendering/Chart/Simple.hs +++ b/Graphics/Rendering/Chart/Simple.hs @@ -22,7 +22,8 @@ -- -- Examples: -- --- > renderableToWindow (toRenderable $ plotLayout $ 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" -- @@ -32,7 +33,7 @@ ----------------------------------------------------------------------------- module Graphics.Rendering.Chart.Simple( plot, PlotKind(..), xcoords, plotWindow, plotPDF, plotPS, - plotLayout + plotLayout, plotPNG, Layout1DDD ) where import Data.Maybe ( catMaybes ) @@ -44,12 +45,14 @@ styleColor :: Int -> AlphaColour Double styleColor ind = colorSequence !! ind - where colorSequence = cycle $ map opaque [blue, red, green, yellow, cyan, magenta, black] + where colorSequence = cycle $ map opaque [ blue, red, green, yellow + , cyan, magenta, black ] styleSymbol :: Int -> PlotKind styleSymbol ind = symbolSequence !! ind - where symbolSequence = cycle [ Ex, HollowCircle, Square, Diamond, - Triangle, DownTriangle, Plus, Star, FilledCircle ] + where symbolSequence = cycle [ Ex, HollowCircle, Square, Diamond + , Triangle, DownTriangle, Plus, Star + , FilledCircle ] -- When defaultLayout1 has been generalized, change this signature to -- [InternalPlot x y] -> Layout1 x y z @@ -57,80 +60,91 @@ iplot foobar = defaultLayout1 { 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 - rest = dropWhile isIPY xyss - ip (_:xyss) = ip xyss - ip [] = [] - isIPY (IPY _ _) = True - isIPY _ = False - toplot (IPX xs _, IPY ys yks) ind = map Left plots - where vs = zip xs ys - plots = case catMaybes $ map plotas yks of - [] -> [toPlot $ defaultPlotLines - { plot_lines_title_ = name yks, - plot_lines_values_ = [vs], - plot_lines_style_ = solidLine 1 (styleColor ind) }] - xs -> xs - plotas Solid = Just $ toPlot $ defaultPlotLines - { plot_lines_title_ = name yks, - plot_lines_values_ = [vs], - plot_lines_style_ = solidLine 1 (styleColor ind) } - plotas Dashed = Just $ toPlot $ defaultPlotLines - { plot_lines_title_ = name yks, - plot_lines_values_ = [vs], - plot_lines_style_ = dashedLine 1 [10,10] (styleColor ind) } - plotas Dotted = Just $ toPlot $ defaultPlotLines - { plot_lines_title_ = name yks, - plot_lines_values_ = [vs], - plot_lines_style_ = dashedLine 1 [1,11] (styleColor ind) } - plotas FilledCircle = Just $ toPlot $ defaultPlotPoints - { plot_points_title_ = name yks, - plot_points_values_ = vs, - plot_points_style_=filledCircles 4 (styleColor ind) } - plotas HollowCircle = Just $ toPlot $ defaultPlotPoints - { plot_points_title_ = name yks, - plot_points_values_ = vs, - plot_points_style_=hollowCircles 5 1 (styleColor ind) } - plotas Triangle = Just $ toPlot $ defaultPlotPoints - { plot_points_title_ = name yks, - plot_points_values_ = vs, - plot_points_style_=hollowPolygon 7 1 3 False (styleColor ind) } - plotas DownTriangle = Just $ toPlot $ defaultPlotPoints - { plot_points_title_ = name yks, - plot_points_values_ = vs, - plot_points_style_=hollowPolygon 7 1 3 True (styleColor ind) } - plotas Square = Just $ toPlot $ defaultPlotPoints - { plot_points_title_ = name yks, - plot_points_values_ = vs, - plot_points_style_=hollowPolygon 7 1 4 False (styleColor ind) } - plotas Diamond = Just $ toPlot $ defaultPlotPoints - { plot_points_title_ = name yks, - plot_points_values_ = vs, - plot_points_style_=hollowPolygon 7 1 4 True (styleColor ind) } - plotas Plus = Just $ toPlot $ defaultPlotPoints - { plot_points_title_ = name yks, - plot_points_values_ = vs, - plot_points_style_=plusses 7 1 (styleColor ind) } - plotas Ex = Just $ toPlot $ defaultPlotPoints - { plot_points_title_ = name yks, - plot_points_values_ = vs, - plot_points_style_=exes 7 1 (styleColor ind) } - plotas Star = Just $ toPlot $ defaultPlotPoints - { plot_points_title_ = name yks, - plot_points_values_ = vs, - plot_points_style_=stars 7 1 (styleColor ind) } - plotas Symbols = plotas (styleSymbol ind) - plotas _ = Nothing + where + ip (xs@(IPX _ _):xyss) = map (\ys -> (xs,ys)) yss ++ ip rest + where yss = takeWhile isIPY xyss + rest = dropWhile isIPY xyss + ip (_:xyss) = ip xyss + ip [] = [] + isIPY (IPY _ _) = True + isIPY _ = False + toplot (IPX xs _, IPY ys yks) ind = map Left plots + where + vs = zip xs ys + plots = case catMaybes $ map plotas yks of + [] -> [ toPlot $ defaultPlotLines + { plot_lines_title_ = name yks, + plot_lines_values_ = [vs], + plot_lines_style_ = solidLine 1 (styleColor ind) + } ] + xs -> xs + plotas Solid = Just $ toPlot $ defaultPlotLines + { plot_lines_title_ = name yks, + plot_lines_values_ = [vs], + plot_lines_style_ = solidLine 1 (styleColor ind) } + plotas Dashed = Just $ toPlot $ defaultPlotLines + { plot_lines_title_ = name yks, + plot_lines_values_ = [vs], + plot_lines_style_ = dashedLine 1 [10,10] + (styleColor ind) } + plotas Dotted = Just $ toPlot $ defaultPlotLines + { plot_lines_title_ = name yks, + plot_lines_values_ = [vs], + plot_lines_style_ = dashedLine 1 [1,11] + (styleColor ind) } + plotas FilledCircle = Just $ toPlot $ defaultPlotPoints + { plot_points_title_ = name yks, + plot_points_values_ = vs, + plot_points_style_ = filledCircles 4 + (styleColor ind) } + plotas HollowCircle = Just $ toPlot $ defaultPlotPoints + { plot_points_title_ = name yks, + plot_points_values_ = vs, + plot_points_style_ = hollowCircles 5 1 + (styleColor ind) } + plotas Triangle = Just $ toPlot $ defaultPlotPoints + { plot_points_title_ = name yks, + plot_points_values_ = vs, + plot_points_style_ = hollowPolygon 7 1 3 False + (styleColor ind) } + plotas DownTriangle = Just $ toPlot $ defaultPlotPoints + { plot_points_title_ = name yks, + plot_points_values_ = vs, + plot_points_style_ = hollowPolygon 7 1 3 True + (styleColor ind) } + plotas Square = Just $ toPlot $ defaultPlotPoints + { plot_points_title_ = name yks, + plot_points_values_ = vs, + plot_points_style_ = hollowPolygon 7 1 4 False + (styleColor ind) } + plotas Diamond = Just $ toPlot $ defaultPlotPoints + { plot_points_title_ = name yks, + plot_points_values_ = vs, + plot_points_style_ = hollowPolygon 7 1 4 True + (styleColor ind) } + plotas Plus = Just $ toPlot $ defaultPlotPoints + { plot_points_title_ = name yks, + plot_points_values_ = vs, + plot_points_style_ = plusses 7 1 (styleColor ind) } + plotas Ex = Just $ toPlot $ defaultPlotPoints + { plot_points_title_ = name yks, + plot_points_values_ = vs, + plot_points_style_ = exes 7 1 (styleColor ind) } + plotas Star = Just $ toPlot $ defaultPlotPoints + { plot_points_title_ = name yks, + plot_points_values_ = vs, + plot_points_style_ = stars 7 1 (styleColor ind) } + plotas Symbols = plotas (styleSymbol ind) + plotas _ = Nothing name :: [PlotKind] -> String name (Name s:_) = s -name (_:ks) = name ks -name [] = "" +name (_:ks) = name ks +name [] = "" str2k :: String -> [PlotKind] -str2k "" = [] -str2k ". " = [Dotted] +str2k "" = [] +str2k ". " = [Dotted] str2k s@('?':_) = str2khelper s Symbols str2k s@('@':_) = str2khelper s FilledCircle str2k s@('#':_) = str2khelper s Square @@ -141,19 +155,20 @@ str2k s@('x':_) = str2khelper s Ex str2k s@('*':_) = str2khelper s Star str2k s@('.':_) = str2khelper s LittleDot -str2k "- " = [Dashed] -str2k "-" = [Solid] -str2k n = [Name n] +str2k "- " = [Dashed] +str2k "-" = [Solid] +str2k n = [Name n] str2khelper :: String -> PlotKind -> [PlotKind] str2khelper s@(_:r) x = case str2k r of - [] -> [x] - [Name _] -> [Name s] - xs -> x:xs + [] -> [x] + [Name _] -> [Name s] + xs -> x:xs -- | Type to define a few simple properties of each plot. data PlotKind = Name String | FilledCircle | HollowCircle - | Triangle | DownTriangle | Square | Diamond | Plus | Ex | Star | Symbols + | Triangle | DownTriangle | Square | Diamond + | Plus | Ex | Star | Symbols | LittleDot | Dashed | Dotted | Solid deriving ( Eq, Show, Ord ) data InternalPlot x y = IPY [y] [PlotKind] | IPX [x] [PlotKind] @@ -164,42 +179,45 @@ 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 (filter isValidNumber xs) ks : nameDoubles uus' - nameDoubles (UDoubles xs:uus) = case grabName uus of - (ks,uus') -> IPY (filter isValidNumber xs) ks : nameDoubles uus' - nameDoubles (_:uus) = nameDoubles uus - nameDoubles [] = [] - evalfuncs :: [UPlot] -> [UPlot] - evalfuncs (UDoubles xs:uus) = X xs : map ef (takeWhile (not.isX) uus) - ++ evalfuncs (dropWhile (not.isX) uus) - where ef (UFunction f) = UDoubles (map f xs) - ef u = u - evalfuncs (X xs:uus) = X xs : map ef (takeWhile (not.isX) uus) - ++ evalfuncs (dropWhile (not.isX) uus) - where ef (UFunction f) = UDoubles (map f xs) - ef u = u - evalfuncs (u:uus) = u : evalfuncs uus - evalfuncs [] = [] - grabName :: [UPlot] -> ([PlotKind],[UPlot]) - grabName (UString n:uus) = case grabName uus of - (ks,uus') -> (str2k n++ks,uus') - grabName (UKind ks:uus) = case grabName uus of - (ks',uus') -> (ks++ks',uus') - grabName uus = ([],uus) - isX (X _) = True - isX _ = False + where + nameDoubles :: [UPlot] -> [InternalPlot Double Double] + nameDoubles (X xs: uus) = case grabName uus of + (ks,uus') -> IPX (filter isValidNumber xs) ks + : nameDoubles uus' + nameDoubles (UDoubles xs:uus)= case grabName uus of + (ks,uus') -> IPY (filter isValidNumber xs) ks + : nameDoubles uus' + nameDoubles (_:uus) = nameDoubles uus + nameDoubles [] = [] + evalfuncs :: [UPlot] -> [UPlot] + evalfuncs (UDoubles xs:uus) = X xs : map ef (takeWhile (not.isX) uus) + ++ evalfuncs (dropWhile (not.isX) uus) + where ef (UFunction f) = UDoubles (map f xs) + ef u = u + evalfuncs (X xs:uus) = X xs : map ef (takeWhile (not.isX) uus) + ++ evalfuncs (dropWhile (not.isX) uus) + where ef (UFunction f) = UDoubles (map f xs) + ef u = u + evalfuncs (u:uus) = u : evalfuncs uus + evalfuncs [] = [] + grabName :: [UPlot] -> ([PlotKind],[UPlot]) + grabName (UString n:uus) = case grabName uus of + (ks,uus') -> (str2k n++ks,uus') + grabName (UKind ks:uus) = case grabName uus of + (ks',uus') -> (ks++ks',uus') + grabName uus = ([],uus) + isX (X _) = True + isX _ = False -- | The main plotting function. The idea behind PlotType is shamelessly --- copied from Text.Printf (and is not exported). All you need to know is --- that your arguments need to be in class PlotArg. And PlotArg consists --- of functions and [Double] and String and PlotKind or [PlotKind]. +-- copied from Text.Printf (and is not exported). All you need to know is +-- that your arguments need to be in class PlotArg. And PlotArg consists +-- of functions and [Double] and String and PlotKind or [PlotKind]. plot :: PlotType a => a plot = pl [] class PlotType t where - pl :: [UPlot] -> t + pl :: [UPlot] -> t instance (PlotArg a, PlotType r) => PlotType (a -> r) where pl args = \ a -> pl (toUPlot a ++ args) instance PlotType Layout1DDD where @@ -210,48 +228,52 @@ plotWindow :: PlotWindowType a => a plotWindow = plw [] class PlotWindowType t where - plw :: [UPlot] -> t + plw :: [UPlot] -> t instance (PlotArg a, PlotWindowType r) => PlotWindowType (a -> r) where plw args = \ a -> plw (toUPlot a ++ args) instance PlotWindowType (IO a) where - plw args = do renderableToWindow (toRenderable $ uplot (reverse args)) 640 480 - return undefined + plw args = do + renderableToWindow (toRenderable $ uplot (reverse args)) 640 480 + return undefined -- | Save a plot as a PDF file. plotPDF :: PlotPDFType a => String -> a plotPDF fn = pld fn [] class PlotPDFType t where - pld :: FilePath -> [UPlot] -> t + pld :: FilePath -> [UPlot] -> t instance (PlotArg a, PlotPDFType r) => PlotPDFType (a -> r) where pld fn args = \ a -> pld fn (toUPlot a ++ args) instance PlotPDFType (IO a) where - pld fn args = do renderableToPDFFile (toRenderable $ uplot (reverse args)) 640 480 fn - return undefined + pld fn args = do + renderableToPDFFile (toRenderable $ uplot (reverse args)) 640 480 fn + return undefined -- | Save a plot as a postscript file. plotPS :: PlotPSType a => String -> a plotPS fn = pls fn [] class PlotPSType t where - pls :: FilePath -> [UPlot] -> t + pls :: FilePath -> [UPlot] -> t instance (PlotArg a, PlotPSType r) => PlotPSType (a -> r) where pls fn args = \ a -> pls fn (toUPlot a ++ args) instance PlotPSType (IO a) where - pls fn args = do renderableToPSFile (toRenderable $ uplot (reverse args)) 640 480 fn - return undefined + pls fn args = do + renderableToPSFile (toRenderable $ uplot (reverse args)) 640 480 fn + return undefined --- | Save a plot as a png file +-- | Save a plot as a png file. plotPNG :: PlotPNGType a => String -> a plotPNG fn = plp fn [] class PlotPNGType t where - plp :: FilePath -> [UPlot] -> t + plp :: FilePath -> [UPlot] -> t instance (PlotArg a, PlotPNGType r) => PlotPNGType (a -> r) where plp fn args = \ a -> plp fn (toUPlot a ++ args) instance PlotPNGType (IO a) where - plp fn args = do renderableToPNGFile (toRenderable $ uplot (reverse args)) 640 480 fn - return undefined + plp fn args = do + renderableToPNGFile (toRenderable $ uplot (reverse args)) 640 480 fn + return undefined @@ -279,6 +301,7 @@ instance PlotArg PlotKind where toUPlot = (:[]) . UKind . (:[]) + class IsPlot c where toUPlot' :: [c] -> [UPlot] diff --git a/Graphics/Rendering/Chart/Types.hs b/Graphics/Rendering/Chart/Types.hs --- a/Graphics/Rendering/Chart/Types.hs +++ b/Graphics/Rendering/Chart/Types.hs @@ -46,10 +46,11 @@ preserveCState, setClipRegion, - strokeLines, moveTo, lineTo, rectPath, + strokePath, + fillPath, isValidNumber, maybeM, @@ -84,6 +85,7 @@ HTextAnchor(..), VTextAnchor(..), drawText, + drawTextR, textSize, CRender(..), @@ -115,7 +117,7 @@ import Data.Colour.SRGB import Data.Colour.Names --- | A point in two dimensions +-- | A point in two dimensions. data Point = Point { p_x :: Double, p_y :: Double @@ -126,40 +128,40 @@ v_y :: Double } deriving Show --- | scale a vector by a constant +-- | Scale a vector by a constant. vscale :: Double -> Vector -> Vector vscale c (Vector x y) = (Vector (x*c) (y*c)) --- | add a point and a vector +-- | Add a point and a vector. pvadd :: Point -> Vector -> Point pvadd (Point x1 y1) (Vector x2 y2) = (Point (x1+x2) (y1+y2)) --- | subtract a vector from a point +-- | Subtract a vector from a point. pvsub :: Point -> Vector -> Point pvsub (Point x1 y1) (Vector x2 y2) = (Point (x1-x2) (y1-y2)) --- | subtract two points +-- | Subtract two points. psub :: Point -> Point -> Vector psub (Point x1 y1) (Point x2 y2) = (Vector (x1-x2) (y1-y2)) data Limit a = LMin | LValue a | LMax deriving Show --- | a function mapping between points +-- | A function mapping between points. type PointMapFn x y = (Limit x, Limit y) -> Point --- | A rectangle is defined by two points +-- | A rectangle is defined by two points. data Rect = Rect Point Point deriving Show data RectEdge = E_Top | E_Bottom | E_Left | E_Right --- | Create a rectangle based upon the coordinates of 4 points +-- | 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) --- | Test if a point is within a rectangle +-- | 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 @@ -170,21 +172,21 @@ -- | The environment present in the CRender Monad. data CEnv = CEnv { -- | An adjustment applied immediately prior to points - -- being displayed in device coordinates + -- being displayed in device coordinates. -- - -- When device coordinates correspond to pixels, a cleaner - -- image is created if this transform rounds to the nearest - -- pixel. With higher-resolution output, this transform can - -- just be the identity function. + -- When device coordinates correspond to pixels, a cleaner + -- image is created if this transform rounds to the nearest + -- pixel. With higher-resolution output, this transform can + -- just be the identity function. cenv_point_alignfn :: Point -> Point, -- | A adjustment applied immediately prior to coordinates - -- being transformed + -- being transformed. cenv_coord_alignfn :: Point -> Point } -- | The reader monad containing context information to control --- the rendering process. +-- the rendering process. newtype CRender a = DR (ReaderT CEnv C.Render a) deriving (Functor, Monad, MonadReader CEnv) @@ -196,37 +198,37 @@ ---------------------------------------------------------------------- --- | Abstract data type for the style of a plotted point +-- | Abstract data type for the style of a plotted point. -- --- The contained Cairo action draws a point in the desired --- style, at the supplied device coordinates. +-- The contained Cairo action draws a point in the desired +-- style, at the supplied device coordinates. newtype CairoPointStyle = CairoPointStyle (Point -> CRender ()) --- | Data type for the style of a line +-- | Data type for the style of a line. data CairoLineStyle = CairoLineStyle { - line_width_ :: Double, - line_color_ :: AlphaColour Double, + line_width_ :: Double, + line_color_ :: AlphaColour Double, line_dashes_ :: [Double], - line_cap_ :: C.LineCap, - line_join_ :: C.LineJoin + line_cap_ :: C.LineCap, + line_join_ :: C.LineJoin } --- | Abstract data type for a fill style +-- | Abstract data type for a fill style. -- --- The contained Cairo action sets the required fill --- style in the Cairo rendering state. +-- The contained Cairo action sets the required fill +-- style in the Cairo rendering state. newtype CairoFillStyle = CairoFillStyle (CRender ()) --- | Data type for a font +-- | Data type for a font. data CairoFontStyle = CairoFontStyle { - font_name_ :: String, - font_size_ :: Double, - font_slant_ :: C.FontSlant, + font_name_ :: String, + font_size_ :: Double, + font_slant_ :: C.FontSlant, font_weight_ :: C.FontWeight, - font_color_ :: AlphaColour Double + font_color_ :: AlphaColour Double } -type Range = (Double,Double) +type Range = (Double,Double) type RectSize = (Double,Double) defaultColorSeq :: [AlphaColour Double] @@ -254,6 +256,7 @@ p' <- alignp p c $ C.lineTo (p_x p') (p_y p') +setClipRegion :: Point -> Point -> CRender () setClipRegion p2 p3 = do c $ C.moveTo (p_x p2) (p_y p2) c $ C.lineTo (p_x p2) (p_y p3) @@ -262,29 +265,49 @@ c $ C.lineTo (p_x p2) (p_y p2) c $ C.clip --- | stroke the lines between successive points -strokeLines :: [Point] -> CRender () -strokeLines (p1:ps) = do - c $ C.newPath - moveTo p1 - mapM_ lineTo ps - c $ C.stroke -strokeLines _ = return () - --- | make a path from a rectangle -rectPath :: Rect -> CRender () -rectPath (Rect p1@(Point x1 y1) p3@(Point x2 y2)) = do - c $ C.newPath - moveTo p1 >> lineTo p2 >> lineTo p3 >> lineTo p4 >> lineTo p1 - where +-- | Make a path from a rectangle. +rectPath :: Rect -> [Point] +rectPath (Rect p1@(Point x1 y1) p3@(Point x2 y2)) = [p1,p2,p3,p4,p1] + where p2 = (Point x1 y2) p4 = (Point x2 y1) +stepPath :: [Point] -> CRender() +stepPath (p:ps) = c $ do + C.newPath + C.moveTo (p_x p) (p_y p) + mapM_ (\p -> C.lineTo (p_x p) (p_y p)) ps +stepPath _ = return () + +-- | Draw lines between the specified points. +-- +-- The points will be "corrected" by the cenv_point_alignfn, so that +-- when drawing bitmaps, 1 pixel wide lines will be centred on the +-- pixels. +strokePath :: [Point] -> CRender() +strokePath pts = do + alignfn <- fmap cenv_point_alignfn ask + stepPath (map alignfn pts) + c $ C.stroke + +-- | Fill the region with the given corners. +-- +-- The points will be "corrected" by the cenv_coord_alignfn, so that +-- when drawing bitmaps, the edges of the region will fall between +-- pixels. +fillPath :: [Point] -> CRender() +fillPath pts = do + alignfn <- fmap cenv_coord_alignfn ask + stepPath (map alignfn pts) + c $ C.fill + +setFontStyle :: CairoFontStyle -> CRender () setFontStyle f = do c $ C.selectFontFace (font_name_ f) (font_slant_ f) (font_weight_ f) c $ C.setFontSize (font_size_ f) c $ setSourceColor (font_color_ f) +setLineStyle :: CairoLineStyle -> CRender () setLineStyle ls = do c $ C.setLineWidth (line_width_ ls) c $ setSourceColor (line_color_ ls) @@ -294,16 +317,18 @@ [] -> return () ds -> c $ C.setDash ds 0 +setFillStyle :: CairoFillStyle -> CRender () setFillStyle (CairoFillStyle s) = s colourChannel :: (Floating a, Ord a) => AlphaColour a -> Colour a colourChannel c = darken (recip (alphaChannel c)) (c `over` black) +setSourceColor :: AlphaColour Double -> C.Render () setSourceColor c = let (RGB r g b) = toSRGB $ colourChannel c in C.setSourceRGBA r g b (alphaChannel c) --- | Return the bounding rectancgle for a text string rendered --- in the current context. +-- | Return the bounding rectangle for a text string rendered +-- in the current context. textSize :: String -> CRender RectSize textSize s = c $ do te <- C.textExtents s @@ -313,27 +338,37 @@ data HTextAnchor = HTA_Left | HTA_Centre | HTA_Right data VTextAnchor = VTA_Top | VTA_Centre | VTA_Bottom | VTA_BaseLine --- | Function to draw a textual label anchored by one of it's corners --- or edges. +-- | Function to draw a textual label anchored by one of its corners +-- or edges. drawText :: HTextAnchor -> VTextAnchor -> Point -> String -> CRender () -drawText hta vta (Point x y) s = c $ do - te <- C.textExtents s - fe <- C.fontExtents - let lx = xadj hta (C.textExtentsWidth te) - let ly = yadj vta te fe - C.moveTo (x+lx) (y+ly) - C.showText s - where - xadj HTA_Left w = 0 - xadj HTA_Centre w = (-w/2) - xadj HTA_Right w = (-w) - yadj VTA_Top te fe = C.fontExtentsAscent fe - yadj VTA_Centre te fe = - (C.textExtentsYbearing te) / 2 - yadj VTA_BaseLine te fe = 0 - yadj VTA_Bottom te fe = -(C.fontExtentsDescent fe) +drawText hta vta p s = drawTextR hta vta 0 p s +-- | Function to draw a textual label anchored by one of its corners +-- or edges, with rotation. Rotation angle is given in degrees, +-- rotation is performed around anchor point. +drawTextR :: HTextAnchor -> VTextAnchor -> Double -> Point -> String -> CRender () +drawTextR hta vta angle (Point x y) s = preserveCState $ draw + where + draw = c $ do te <- C.textExtents s + fe <- C.fontExtents + let lx = xadj hta (C.textExtentsWidth te) + let ly = yadj vta te fe + C.translate x y + C.rotate theta + C.moveTo lx ly + C.showText s + theta = angle*pi/180.0 + xadj HTA_Left w = 0 + xadj HTA_Centre w = (-w/2) + xadj HTA_Right w = (-w) + yadj VTA_Top te fe = C.fontExtentsAscent fe + yadj VTA_Centre te fe = - (C.textExtentsYbearing te) / 2 + yadj VTA_BaseLine te fe = 0 + yadj VTA_Bottom te fe = -(C.fontExtentsDescent fe) + + -- | Execute a rendering action in a saved context (ie bracketed --- between C.save and C.restore) +-- between C.save and C.restore). preserveCState :: CRender a -> CRender a preserveCState a = do c $ C.save @@ -344,8 +379,8 @@ ---------------------------------------------------------------------- filledCircles :: - Double -- ^ radius of circle - -> AlphaColour Double -- ^ colour + Double -- ^ Radius of circle. + -> AlphaColour Double -- ^ Colour. -> CairoPointStyle filledCircles radius cl = CairoPointStyle rf where @@ -357,8 +392,8 @@ c $ C.fill hollowCircles :: - Double -- ^ radius of circle - -> Double -- ^ thickness of line + Double -- ^ Radius of circle. + -> Double -- ^ Thickness of line. -> AlphaColour Double -> CairoPointStyle hollowCircles radius w cl = CairoPointStyle rf @@ -372,9 +407,9 @@ c $ C.stroke hollowPolygon :: - Double -- ^ radius of circle - -> Double -- ^ thickness of line - -> Int -- ^ Number of vertices + Double -- ^ Radius of circle. + -> Double -- ^ Thickness of line. + -> Int -- ^ Number of vertices. -> Bool -- ^ Is right-side-up? -> AlphaColour Double -> CairoPointStyle @@ -384,18 +419,21 @@ c $ C.setLineWidth w c $ setSourceColor cl c $ C.newPath - let intToAngle n = if isrot - then fromIntegral n * 2*pi / fromIntegral sides - else (0.5 + fromIntegral n)*2*pi/fromIntegral sides + let intToAngle n = + if isrot + then fromIntegral n * 2*pi / fromIntegral sides + else (0.5 + fromIntegral n)*2*pi / fromIntegral sides angles = map intToAngle [0 .. sides-1] - (p:ps) = map (\a -> Point (x + radius * sin a) (y + radius * cos a)) angles + (p:ps) = map (\a -> Point (x + radius * sin a) + (y + radius * cos a)) + angles moveTo p mapM_ lineTo (ps++[p]) c $ C.stroke filledPolygon :: - Double -- ^ radius of circle - -> Int -- ^ Number of vertices + Double -- ^ Radius of circle. + -> Int -- ^ Number of vertices. -> Bool -- ^ Is right-side-up? -> AlphaColour Double -> CairoPointStyle @@ -404,18 +442,20 @@ do (Point x y ) <- alignp p c $ setSourceColor cl c $ C.newPath - let intToAngle n = if isrot - then fromIntegral n * 2*pi / fromIntegral sides - else (0.5 + fromIntegral n)*2*pi/fromIntegral sides + let intToAngle n = + if isrot + then fromIntegral n * 2*pi/fromIntegral sides + else (0.5 + fromIntegral n)*2*pi/fromIntegral sides angles = map intToAngle [0 .. sides-1] - (p:ps) = map (\a -> Point (x + radius * sin a) (y + radius * cos a)) angles + (p:ps) = map (\a -> Point (x + radius * sin a) + (y + radius * cos a)) angles moveTo p mapM_ lineTo (ps++[p]) c $ C.fill plusses :: - Double -- ^ radius of circle - -> Double -- ^ thickness of line + Double -- ^ Radius of circle. + -> Double -- ^ Thickness of line. -> AlphaColour Double -> CairoPointStyle plusses radius w cl = CairoPointStyle rf @@ -430,8 +470,8 @@ c $ C.stroke exes :: - Double -- ^ radius of circle - -> Double -- ^ thickness of line + Double -- ^ Radius of circle. + -> Double -- ^ Thickness of line. -> AlphaColour Double -> CairoPointStyle exes radius w cl = CairoPointStyle rf @@ -447,8 +487,8 @@ c $ C.stroke stars :: - Double -- ^ radius of circle - -> Double -- ^ thickness of line + Double -- ^ Radius of circle. + -> Double -- ^ Thickness of line. -> AlphaColour Double -> CairoPointStyle stars radius w cl = CairoPointStyle rf @@ -468,14 +508,14 @@ c $ C.stroke solidLine :: - Double -- ^ width of line + Double -- ^ Width of line. -> AlphaColour Double -> CairoLineStyle solidLine w cl = CairoLineStyle w cl [] C.LineCapButt C.LineJoinMiter dashedLine :: - Double -- ^ width of line - -> [Double] -- ^ the dash pattern in device coordinates + Double -- ^ Width of line. + -> [Double] -- ^ The dash pattern in device coordinates. -> AlphaColour Double -> CairoLineStyle dashedLine w ds cl = CairoLineStyle w cl ds C.LineCapButt C.LineJoinMiter @@ -486,22 +526,27 @@ solidFillStyle cl = CairoFillStyle fn where fn = c $ setSourceColor cl +defaultPointStyle :: CairoPointStyle defaultPointStyle = filledCircles 1 $ opaque white +defaultFontStyle :: CairoFontStyle defaultFontStyle = CairoFontStyle { - font_name_ = "sans", - font_size_ = 10, - font_slant_ = C.FontSlantNormal, + font_name_ = "sans", + font_size_ = 10, + font_slant_ = C.FontSlantNormal, font_weight_ = C.FontWeightNormal, - font_color_ = opaque black + font_color_ = opaque black } +isValidNumber :: (RealFloat a) => a -> Bool isValidNumber v = not (isNaN v) && not (isInfinite v) +maybeM :: (Monad m) => b -> (a -> m b) -> Maybe a -> m b maybeM v = maybe (return v) ---------------------------------------------------------------------- --- Template haskell to derive an instance of Data.Accessor.Accessor for each field +-- Template haskell to derive an instance of Data.Accessor.Accessor +-- for each field. $( deriveAccessors ''CairoLineStyle ) $( deriveAccessors ''CairoFontStyle ) diff --git a/tests/Prices.hs b/tests/Prices.hs --- a/tests/Prices.hs +++ b/tests/Prices.hs @@ -1,7 +1,9 @@ module Prices where -prices :: [(Int,Int,Int,Double,Double)] -prices = [ +import Data.Time.Calendar +import Data.Time.LocalTime + +rawPrices = [ (03,05,2005, 16.18, 42.02), (04,05,2005, 16.25, 42.31), (05,05,2005, 16.50, 42.95), @@ -294,3 +296,17 @@ (30,03,2007, 27.60, 77.96), (31,03,2007, 28.00, 78.85) ] + +prices :: [(LocalTime,Double,Double)] +prices = [ (mkDate dd mm yyyy, p1, p2) | (dd,mm,yyyy,p1,p2) <- rawPrices ] + +filterPrices t1 t2 = [ v | v@(d,_,_) <- prices, let t = d in t >= t1 && t <= t2] + +prices1 = filterPrices (mkDate 1 1 2005) (mkDate 31 12 2005) +prices2 = filterPrices (mkDate 1 6 2005) (mkDate 1 9 2005) +prices3 = filterPrices (mkDate 1 1 2006) (mkDate 10 1 2006) +prices4 = filterPrices (mkDate 1 8 2005) (mkDate 31 8 2005) + +mkDate dd mm yyyy = (LocalTime (fromGregorian (fromIntegral yyyy) mm dd) midnight) + + diff --git a/tests/Test1.hs b/tests/Test1.hs new file mode 100644 --- /dev/null +++ b/tests/Test1.hs @@ -0,0 +1,41 @@ +module Test1 where + +import Graphics.Rendering.Chart +import Graphics.Rendering.Chart.Gtk +import Data.Colour +import Data.Colour.Names +import Data.Colour.SRGB +import Data.Accessor +import System.Environment(getArgs) + +chart lwidth = toRenderable (layout lwidth) + +layout :: Double -> Layout1 Double Double +layout lwidth = layout1 + where + layout1 = layout1_title ^= "Amplitude Modulation" + $ layout1_plots ^= [Left (toPlot sinusoid1), + Left (toPlot sinusoid2)] + $ layout1_plot_background ^= Just (solidFillStyle $ opaque white) + $ defaultLayout1 + + am x = (sin (x*pi/45) + 1) / 2 * (sin (x*pi/5)) + + sinusoid1 = plot_lines_values ^= [[ (x,(am x)) | x <- [0,(0.5)..400]]] + $ plot_lines_style ^= solidLine lwidth (opaque blue) + $ plot_lines_title ^="am" + $ defaultPlotLines + + sinusoid2 = plot_points_style ^= filledCircles 2 (opaque red) + $ plot_points_values ^= [ (x,(am x)) | x <- [0,7..400]] + $ plot_points_title ^="am points" + $ defaultPlotPoints + +main1 :: [String] -> IO() +main1 ["small"] = renderableToPNGFile (chart 0.25) 320 240 "test1_small.png" +main1 ["big"] = renderableToPNGFile (chart 0.25) 800 600 "test1_big.png" +main1 _ = renderableToWindow (chart 1.00) 640 480 + +main = getArgs >>= main1 + + diff --git a/tests/Test14.hs b/tests/Test14.hs new file mode 100644 --- /dev/null +++ b/tests/Test14.hs @@ -0,0 +1,48 @@ +module Test14 where + +import Graphics.Rendering.Chart +import Graphics.Rendering.Chart.Gtk +import Data.Colour +import Data.Colour.Names +import Data.Accessor +import System.Random +import System.Environment(getArgs) +import Prices(prices1) + +-- demonstrate AreaSpots + +chart :: Double -> Renderable () +chart lwidth = toRenderable layout + where + layout = layout1_title ^="Price History" + $ layout1_background ^= solidFillStyle (opaque white) + $ layout1_left_axis ^: laxis_override ^= axisTicksHide + $ layout1_plots ^= [ Left (toPlot price1), Left (toPlot spots) ] + $ setLayout1Foreground (opaque black) + $ defaultLayout1 + + price1 = plot_lines_style ^= lineStyle + $ plot_lines_values ^= [[ (d, v) | (d,v,_) <- prices1]] + $ plot_lines_title ^= "price 1" + $ defaultPlotLines + + spots = area_spots_title ^= "random value" + $ area_spots_max_radius ^= 20 + $ area_spots_values ^= values + $ defaultAreaSpots + + points = map (\ (d,v,z)-> (d,v) ) values + values = [ (d, v, z) | ((d,v,_),z) <- zip prices1 zs ] + zs :: [Int] + zs = randoms $ mkStdGen 0 + + lineStyle = line_width ^= 3 * lwidth + $ line_color ^= opaque blue + $ defaultPlotLines ^. plot_lines_style + +main1 :: [String] -> IO() +main1 ["small"] = renderableToPNGFile (chart 0.25) 320 240 "test14_small.png" +main1 ["big"] = renderableToPNGFile (chart 0.25) 800 600 "test14_big.png" +main1 _ = renderableToWindow (chart 1.00) 640 480 + +main = getArgs >>= main1 diff --git a/tests/Test15.hs b/tests/Test15.hs new file mode 100644 --- /dev/null +++ b/tests/Test15.hs @@ -0,0 +1,45 @@ +module Test15 where + +import Graphics.Rendering.Chart +import Graphics.Rendering.Chart.Gtk +import Data.Colour +import Data.Colour.Names +import Data.Accessor +import System.Environment(getArgs) + +chart lo = toRenderable layout + where + layout = + layout1_title ^= "Legend Test" + $ layout1_title_style ^: font_size ^= 10 + $ layout1_bottom_axis ^: laxis_generate ^= autoIndexAxis alabels + $ layout1_left_axis ^: laxis_override ^= (axisGridHide.axisTicksHide) + $ layout1_plots ^= [ Left (plotBars bars2) ] + $ layout1_legend ^= Just lstyle + $ defaultLayout1 :: Layout1 PlotIndex Double + + bars2 = plot_bars_titles ^= ["A","B","C","D","E","F","G","H","I","J"] + $ plot_bars_values ^= addIndexes [[2,3,4,2,1,5,6,4,8,1,3], + [7,4,5,6,2,4,4,5,7,8,9] + ] + $ plot_bars_style ^= BarsClustered + $ plot_bars_spacing ^= BarsFixGap 30 5 + $ plot_bars_item_styles ^= map mkstyle (cycle defaultColorSeq) + $ defaultPlotBars + + alabels = [ "X", "Y" ] + + lstyle = legend_orientation ^= lo + $ defaultLegendStyle + + btitle = "" + mkstyle c = (solidFillStyle c, Nothing) + +main1 :: [String] -> IO() +main1 ["small"] = renderableToPNGFile (chart (LORows 3)) 320 240 "test15_small.png" +main1 ["big"] = renderableToPNGFile (chart (LORows 3)) 800 600 "test15_big.png" +main1 _ = renderableToWindow (chart (LORows 3)) 640 480 + +main = getArgs >>= main1 + + diff --git a/tests/Test2.hs b/tests/Test2.hs new file mode 100644 --- /dev/null +++ b/tests/Test2.hs @@ -0,0 +1,64 @@ +module Test2 where + +import Graphics.Rendering.Chart +import Graphics.Rendering.Chart.Gtk +import Data.Time.LocalTime +import Data.Colour +import Data.Colour.Names +import Data.Colour.SRGB +import Data.Accessor +import System.Environment(getArgs) +import Prices(prices2) + +chart :: [(LocalTime,Double,Double)] -> Bool -> Double -> Renderable () +chart prices showMinMax lwidth = toRenderable layout + where + + lineStyle c = line_width ^= 3 * lwidth + $ line_color ^= c + $ defaultPlotLines ^. plot_lines_style + + limitLineStyle c = line_width ^= lwidth + $ line_color ^= opaque c + $ line_dashes ^= [5,10] + $ defaultPlotLines ^. plot_lines_style + + price1 = plot_lines_style ^= lineStyle (opaque blue) + $ plot_lines_values ^= [[ (d, v) | (d,v,_) <- prices]] + $ plot_lines_title ^= "price 1" + $ defaultPlotLines + + price2 = plot_lines_style ^= lineStyle (opaque green) + $ plot_lines_values ^= [[ (d, v) | (d,_,v) <- prices]] + $ plot_lines_title ^= "price 2" + $ defaultPlotLines + + (min1,max1) = (minimum [v | (_,v,_) <- prices],maximum [v | (_,v,_) <- prices]) + (min2,max2) = (minimum [v | (_,_,v) <- prices],maximum [v | (_,_,v) <- prices]) + limits | showMinMax = [ Left $ hlinePlot "min/max" (limitLineStyle blue) min1, + Left $ hlinePlot "" (limitLineStyle blue) max1, + Right $ hlinePlot "min/max" (limitLineStyle green) min2, + Right $ hlinePlot "" (limitLineStyle green) max2 ] + | otherwise = [] + + bg = opaque $ sRGB 0 0 0.25 + fg = opaque white + fg1 = opaque $ sRGB 0.0 0.0 0.15 + + layout = layout1_title ^="Price History" + $ layout1_background ^= solidFillStyle bg + $ updateAllAxesStyles (axis_grid_style ^= solidLine 1 fg1) + $ layout1_left_axis ^: laxis_override ^= axisGridHide + $ layout1_right_axis ^: laxis_override ^= axisGridHide + $ layout1_bottom_axis ^: laxis_override ^= axisGridHide + $ layout1_plots ^= ([Left (toPlot price1), Right (toPlot price2)] ++ limits) + $ layout1_grid_last ^= False + $ setLayout1Foreground fg + $ defaultLayout1 + +main1 :: [String] -> IO() +main1 ["small"] = renderableToPNGFile (chart prices2 True 0.25) 320 240 "test2_small.png" +main1 ["big"] = renderableToPNGFile (chart prices2 True 0.25) 800 600 "test2_big.png" +main1 _ = renderableToWindow (chart prices2 True 1.00) 640 480 + +main = getArgs >>= main1 diff --git a/tests/Test3.hs b/tests/Test3.hs new file mode 100644 --- /dev/null +++ b/tests/Test3.hs @@ -0,0 +1,40 @@ +module Test3 where + +import Graphics.Rendering.Chart +import Graphics.Rendering.Chart.Gtk +import Data.Time.LocalTime +import Data.Colour +import Data.Colour.Names +import Data.Colour.SRGB +import Data.Accessor +import System.Environment(getArgs) +import Prices(prices1) + +green1 = opaque $ sRGB 0.5 1 0.5 +blue1 = opaque $ sRGB 0.5 0.5 1 + +chart = toRenderable layout + where + price1 = plot_fillbetween_style ^= solidFillStyle green1 + $ plot_fillbetween_values ^= [ (d,(0,v2)) | (d,v1,v2) <- prices1] + $ plot_fillbetween_title ^= "price 1" + $ defaultPlotFillBetween + + price2 = plot_fillbetween_style ^= solidFillStyle blue1 + $ plot_fillbetween_values ^= [ (d,(0,v1)) | (d,v1,v2) <- prices1] + $ plot_fillbetween_title ^= "price 2" + $ defaultPlotFillBetween + + layout = layout1_title ^= "Price History" + $ layout1_grid_last ^= True + $ layout1_plots ^= [Left (toPlot price1), + Left (toPlot price2)] + $ defaultLayout1 + + +main1 :: [String] -> IO() +main1 ["small"] = renderableToPNGFile chart 320 240 "test3_small.png" +main1 ["big"] = renderableToPNGFile chart 800 600 "test3_big.png" +main1 _ = renderableToWindow chart 640 480 + +main = getArgs >>= main1 diff --git a/tests/Test4.hs b/tests/Test4.hs new file mode 100644 --- /dev/null +++ b/tests/Test4.hs @@ -0,0 +1,39 @@ +module Test4 where + +import Graphics.Rendering.Chart +import Graphics.Rendering.Chart.Gtk +import Data.Colour +import Data.Colour.Names +import Data.Accessor +import System.Environment(getArgs) + +chart :: Bool -> Bool -> Renderable () +chart xrev yrev = toRenderable layout + where + + points = plot_points_style ^= filledCircles 3 (opaque red) + $ plot_points_values ^= [ (x, 10**x) | x <- [0.5,1,1.5,2,2.5 :: Double] ] + $ plot_points_title ^= "values" + $ defaultPlotPoints + + lines = plot_lines_values ^= [ [(x, 10**x) | x <- [0,3]] ] + $ plot_lines_title ^= "values" + $ defaultPlotLines + + layout = layout1_title ^= "Log/Linear Example" + $ layout1_bottom_axis ^: laxis_title ^= "horizontal" + $ layout1_bottom_axis ^: laxis_reverse ^= xrev + $ layout1_left_axis ^: laxis_generate ^= autoScaledLogAxis defaultLogAxis + $ layout1_left_axis ^: laxis_title ^= "vertical" + $ layout1_left_axis ^: laxis_reverse ^= yrev + $ layout1_plots ^= [Left (toPlot points), Left (toPlot lines) ] + $ defaultLayout1 + +main1 :: [String] -> IO() +main1 ["small"] = renderableToPNGFile (chart False False) 320 240 "test4_small.png" +main1 ["big"] = renderableToPNGFile (chart False False) 800 600 "test4_big.png" +main1 _ = renderableToWindow (chart False False) 640 480 + +main = getArgs >>= main1 + + diff --git a/tests/Test5.hs b/tests/Test5.hs new file mode 100644 --- /dev/null +++ b/tests/Test5.hs @@ -0,0 +1,50 @@ +module Test5 where + +import Graphics.Rendering.Chart +import Graphics.Rendering.Chart.Gtk +import Data.Colour +import Data.Colour.Names +import Data.Accessor +import System.Random +import System.Environment(getArgs) + +---------------------------------------------------------------------- +-- Example thanks to Russell O'Connor + +chart :: Double -> Renderable () +chart lwidth = toRenderable (layout 1001 (trial bits) :: Layout1 Double LogValue) + where + bits = randoms $ mkStdGen 0 + + layout n t = layout1_title ^= "Simulation of betting on a biased coin" + $ layout1_plots ^= [ + Left (toPlot (plot "f=0.05" s1 n 0 (t 0.05))), + Left (toPlot (plot "f=0.1" s2 n 0 (t 0.1))) + ] + $ defaultLayout1 + + plot tt 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]] + $ plot_lines_title ^= tt + $ defaultPlotLines + + b = 0.1 + + trial bits frac = scanl (*) 1 (map f bits) + where + f True = (1+frac*(1+b)) + f False = (1-frac) + + s1 = solidLine lwidth $ opaque green + s2 = solidLine lwidth $ opaque blue + +main1 :: [String] -> IO() +main1 ["small"] = renderableToPNGFile (chart 0.25) 320 240 "test5_small.png" +main1 ["big"] = renderableToPNGFile (chart 0.25) 800 600 "test5_big.png" +main1 _ = renderableToWindow (chart 1.00) 640 480 + +main = getArgs >>= main1 + + diff --git a/tests/Test6.hs b/tests/Test6.hs new file mode 100644 --- /dev/null +++ b/tests/Test6.hs @@ -0,0 +1,24 @@ +module Test6 where + +import Graphics.Rendering.Chart +import Graphics.Rendering.Chart.Simple +import Graphics.Rendering.Chart.Gtk +import System.Environment(getArgs) + +chart :: Renderable () +chart = toRenderable (plotLayout pp){layout1_title_="Graphics.Rendering.Chart.Simple example"} + where + pp = plot xs sin "sin" + cos "cos" "o" + (sin.sin.cos) "sin.sin.cos" "." + (/3) "- " + (const 0.5) + [0.1,0.7,0.5::Double] "+" + xs = [0,0.3..3] :: [Double] + +main1 :: [String] -> IO() +main1 ["small"] = renderableToPNGFile chart 320 240 "test6_small.png" +main1 ["big"] = renderableToPNGFile chart 800 600 "test6_big.png" +main1 _ = renderableToWindow chart 640 480 + +main = getArgs >>= main1 diff --git a/tests/Test7.hs b/tests/Test7.hs new file mode 100644 --- /dev/null +++ b/tests/Test7.hs @@ -0,0 +1,36 @@ +module Test7 where + +import Graphics.Rendering.Chart +import Graphics.Rendering.Chart.Gtk +import Data.Colour +import Data.Colour.Names +import Data.Accessor +import System.Environment(getArgs) + +chart = toRenderable layout + where + vals :: [(Double,Double,Double,Double)] + vals = [ (x,sin (exp x),sin x/2,cos x/10) | x <- [1..20]] + bars = plot_errbars_values ^= [symErrPoint x y dx dy | (x,y,dx,dy) <- vals] + $ plot_errbars_title ^="test" + $ defaultPlotErrBars + + points = plot_points_style ^= filledCircles 2 (opaque red) + $ plot_points_values ^= [(x,y) | (x,y,dx,dy) <- vals] + $ plot_points_title ^= "test data" + $ defaultPlotPoints + + layout = layout1_title ^= "Error Bars" + $ layout1_plots ^= [Left (toPlot bars), + Left (toPlot points)] + $ defaultLayout1 + + +main1 :: [String] -> IO() +main1 ["small"] = renderableToPNGFile chart 320 240 "test7_small.png" +main1 ["big"] = renderableToPNGFile chart 800 600 "test7_big.png" +main1 _ = renderableToWindow chart 640 480 + +main = getArgs >>= main1 + + diff --git a/tests/Test8.hs b/tests/Test8.hs new file mode 100644 --- /dev/null +++ b/tests/Test8.hs @@ -0,0 +1,26 @@ +module Test8 where + +import Graphics.Rendering.Chart +import Graphics.Rendering.Chart.Gtk +import Data.Accessor +import System.Environment(getArgs) + +chart :: Renderable () +chart = toRenderable layout + where + values = [ ("eggs",38,e), ("milk",45,e), ("bread",11,e1), ("salmon",8,e) ] + e = 0 + e1 = 25 + 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 + +main1 :: [String] -> IO() +main1 ["small"] = renderableToPNGFile chart 320 240 "test8_small.png" +main1 ["big"] = renderableToPNGFile chart 800 600 "test8_big.png" +main1 _ = renderableToWindow chart 640 480 + +main = getArgs >>= main1 + + diff --git a/tests/Test9.hs b/tests/Test9.hs new file mode 100644 --- /dev/null +++ b/tests/Test9.hs @@ -0,0 +1,40 @@ +module Test9 where + +import Graphics.Rendering.Chart +import Graphics.Rendering.Chart.Gtk +import Data.Colour +import Data.Colour.Names +import Data.Accessor +import System.Environment(getArgs) + +chart borders = toRenderable layout + where + layout = + layout1_title ^= "Sample Bars" ++ btitle + $ layout1_title_style ^: font_size ^= 10 + $ layout1_bottom_axis ^: laxis_generate ^= autoIndexAxis alabels + $ layout1_left_axis ^: laxis_override ^= (axisGridHide.axisTicksHide) + $ layout1_plots ^= [ Left (plotBars bars2) ] + $ defaultLayout1 :: Layout1 PlotIndex Double + + bars2 = plot_bars_titles ^= ["Cash","Equity"] + $ plot_bars_values ^= addIndexes [[20,45],[45,30],[30,20],[70,25]] + $ plot_bars_style ^= BarsClustered + $ plot_bars_spacing ^= BarsFixGap 30 5 + $ plot_bars_item_styles ^= map mkstyle (cycle defaultColorSeq) + $ defaultPlotBars + + alabels = [ "Jun", "Jul", "Aug", "Sep", "Oct" ] + + btitle = if borders then "" else " (no borders)" + bstyle = if borders then Just (solidLine 1.0 $ opaque black) else Nothing + mkstyle c = (solidFillStyle c, bstyle) + +main1 :: [String] -> IO() +main1 ["small"] = renderableToPNGFile (chart True) 320 240 "test9_small.png" +main1 ["big"] = renderableToPNGFile (chart True) 800 600 "test9_big.png" +main1 _ = renderableToWindow (chart True) 640 480 + +main = getArgs >>= main1 + + diff --git a/tests/TestParametric.hs b/tests/TestParametric.hs new file mode 100644 --- /dev/null +++ b/tests/TestParametric.hs @@ -0,0 +1,30 @@ +module TestParametric where + +import Graphics.Rendering.Chart +import Graphics.Rendering.Chart.Gtk +import Data.Colour +import Data.Colour.Names +import Data.Accessor +import System.Environment(getArgs) + +chart lwidth = toRenderable layout + where + circle = [ (r a * sin (a*dr),r a * cos (a*dr)) | a <- [0,0.5..360::Double] ] + where + dr = 2 * pi / 360 + r a = 0.8 * cos (a * 20 * pi /360) + + circleP = plot_lines_values ^= [circle] + $ plot_lines_style ^= solidLine lwidth (opaque blue) + $ defaultPlotLines + + layout = layout1_title ^= "Parametric Plot" + $ layout1_plots ^= [Left (toPlot circleP)] + $ defaultLayout1 + +main1 :: [String] -> IO() +main1 ["small"] = renderableToPNGFile (chart 0.25) 320 240 "test_parametric_small.png" +main1 ["big"] = renderableToPNGFile (chart 0.25) 800 600 "test_parametric_big.png" +main1 _ = renderableToWindow (chart 1.00) 640 480 + +main = getArgs >>= main1 diff --git a/tests/all_tests.hs b/tests/all_tests.hs new file mode 100644 --- /dev/null +++ b/tests/all_tests.hs @@ -0,0 +1,385 @@ +import qualified Graphics.Rendering.Cairo as C +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.LocalTime +import Data.Accessor +import Data.Accessor.Tuple +import Data.Colour +import Data.Colour.Names +import Data.Colour.SRGB +import Data.List(sort,nub,scanl1) +import qualified Data.Map as Map +import Control.Monad +import Prices +import qualified Test1 +import qualified Test2 +import qualified Test3 +import qualified Test4 +import qualified Test5 +import qualified Test6 +import qualified Test7 +import qualified Test8 +import qualified Test9 +import qualified Test14 +import qualified Test15 +import qualified TestParametric + +data OutputType = Window | PNG | PS | PDF | SVG + +chooseLineWidth Window = 1.0 +chooseLineWidth PNG = 1.0 +chooseLineWidth PDF = 0.25 +chooseLineWidth PS = 0.25 +chooseLineWidth SVG = 0.25 + +fwhite = solidFillStyle $ opaque white + +test1a :: Double -> Renderable () +test1a lwidth = fillBackground fwhite $ (gridToRenderable t) + where + t = weights (1,1) $ aboveN [ besideN [rf g1, rf g2, rf g3], + besideN [rf g4, rf g5, rf g6] ] + + g1 = layout1_title ^= "minimal" + $ layout1_bottom_axis ^: laxis_override ^= (axisGridHide.axisTicksHide) + $ layout1_left_axis ^: laxis_override ^= (axisGridHide.axisTicksHide) + $ Test1.layout lwidth + + g2 = layout1_title ^= "with borders" + $ layout1_bottom_axis ^: laxis_override ^= (axisGridHide.axisTicksHide) + $ layout1_left_axis ^: laxis_override ^= (axisGridHide.axisTicksHide) + $ layout1_top_axis ^: axisBorderOnly + $ layout1_right_axis ^: axisBorderOnly + $ Test1.layout lwidth + + g3 = layout1_title ^= "default" + $ Test1.layout lwidth + + g4 = layout1_title ^= "tight grid" + $ layout1_left_axis ^: laxis_generate ^= axis + $ layout1_left_axis ^: laxis_override ^= axisGridAtTicks + $ layout1_bottom_axis ^: laxis_generate ^= axis + $ layout1_bottom_axis ^: laxis_override ^= axisGridAtTicks + $ Test1.layout lwidth + where + axis = autoScaledAxis ( + la_nLabels ^= 5 + $ la_nTicks ^= 20 + $ defaultLinearAxis + ) + + g5 = layout1_title ^= "y linked" + $ layout1_yaxes_control ^= linkAxes + $ Test1.layout lwidth + + g6 = layout1_title ^= "everything" + $ layout1_yaxes_control ^= linkAxes + $ layout1_top_axis ^: laxis_visible ^= const True + $ Test1.layout lwidth + + rf = tval.toRenderable + + axisBorderOnly = (laxis_visible ^= const True) + . (laxis_override ^= (axisGridHide.axisTicksHide.axisLabelsHide)) + +---------------------------------------------------------------------- +test4d :: OutputType -> Renderable () +test4d otype = toRenderable layout + where + + points = plot_points_style ^= filledCircles 3 (opaque red) + $ plot_points_values ^= [ (x, 10**x) | x <- [0.5,1,1.5,2,2.5::Double] ] + $ plot_points_title ^= "values" + $ defaultPlotPoints + + lines = plot_lines_values ^= [ [(x, 10**x) | x <- [0,3]] ] + $ plot_lines_title ^= "values" + $ defaultPlotLines + + layout = layout1_title ^= "Log/Linear Example" + $ layout1_bottom_axis ^: laxis_title ^= "horizontal" + $ layout1_bottom_axis ^: laxis_reverse ^= False + $ layout1_left_axis ^: laxis_generate ^= autoScaledLogAxis defaultLogAxis + $ layout1_left_axis ^: laxis_title ^= "vertical" + $ layout1_left_axis ^: laxis_reverse ^= False + $ layout1_plots ^= [Left (toPlot points `joinPlot` toPlot lines) ] + $ defaultLayout1 + +---------------------------------------------------------------------- + +test9 :: PlotBarsAlignment -> OutputType -> Renderable () +test9 alignment otype = fillBackground fwhite $ (gridToRenderable t) + where + t = weights (1,1) $ aboveN [ besideN [rf g0, rf g1, rf g2], + besideN [rf g3, rf g4, rf g5] ] + + g0 = layout "clustered 1" + $ plot_bars_style ^= BarsClustered + $ plot_bars_spacing ^= BarsFixWidth 25 + $ bars1 + + g1 = layout "clustered/fix width " + $ plot_bars_style ^= BarsClustered + $ plot_bars_spacing ^= BarsFixWidth 25 + $ bars2 + + g2 = layout "clustered/fix gap " + $ plot_bars_style ^= BarsClustered + $ plot_bars_spacing ^= BarsFixGap 10 5 + $ bars2 + + g3 = layout "stacked 1" + $ plot_bars_style ^= BarsStacked + $ plot_bars_spacing ^= BarsFixWidth 25 + $ bars1 + + g4 = layout "stacked/fix width" + $ plot_bars_style ^= BarsStacked + $ plot_bars_spacing ^= BarsFixWidth 25 + $ bars2 + + g5 = layout "stacked/fix gap" + $ plot_bars_style ^= BarsStacked + $ plot_bars_spacing ^= BarsFixGap 10 5 + $ bars2 + + rf = tval.toRenderable + + alabels = [ "Jun", "Jul", "Aug", "Sep", "Oct" ] + + + layout title bars = + layout1_title ^= (show alignment ++ "/" ++ title) + $ layout1_title_style ^: font_size ^= 10 + $ layout1_bottom_axis ^: laxis_generate ^= autoIndexAxis alabels + $ layout1_left_axis ^: laxis_override ^= (axisGridHide.axisTicksHide) + $ layout1_plots ^= [ Left (plotBars bars) ] + $ defaultLayout1 :: Layout1 PlotIndex Double + + bars1 = plot_bars_titles ^= ["Cash"] + $ plot_bars_values ^= addIndexes [[20],[45],[30],[70]] + $ plot_bars_alignment ^= alignment + $ defaultPlotBars + + bars2 = plot_bars_titles ^= ["Cash","Equity"] + $ plot_bars_values ^= addIndexes [[20,45],[45,30],[30,20],[70,25]] + $ plot_bars_alignment ^= alignment + $ defaultPlotBars + +------------------------------------------------------------------------------- + +test10 :: [(LocalTime,Double,Double)] -> OutputType -> Renderable () +test10 prices otype = toRenderable layout + where + + lineStyle c = line_width ^= 3 * chooseLineWidth otype + $ line_color ^= c + $ defaultPlotLines ^. plot_lines_style + + price1 = plot_lines_style ^= lineStyle (opaque blue) + $ plot_lines_values ^= [[ (d,v) | (d,v,_) <- prices]] + $ plot_lines_title ^= "price 1" + $ defaultPlotLines + + price1_area = plot_fillbetween_values ^= [(d, (v * 0.95, v * 1.05)) | (d,v,_) <- prices] + $ plot_fillbetween_style ^= solidFillStyle (withOpacity blue 0.2) + $ defaultPlotFillBetween + + price2 = plot_lines_style ^= lineStyle (opaque red) + $ plot_lines_values ^= [[ (d, v) | (d,_,v) <- prices]] + $ plot_lines_title ^= "price 2" + $ defaultPlotLines + + price2_area = plot_fillbetween_values ^= [(d, (v * 0.95, v * 1.05)) | (d,_,v) <- prices] + $ plot_fillbetween_style ^= solidFillStyle (withOpacity red 0.2) + $ defaultPlotFillBetween + + fg = opaque black + fg1 = opaque $ sRGB 0.0 0.0 0.15 + + layout = layout1_title ^="Price History" + $ layout1_background ^= solidFillStyle (opaque white) + $ layout1_right_axis ^: laxis_override ^= axisGridHide + $ layout1_plots ^= [ Left (toPlot price1_area), Right (toPlot price2_area) + , Left (toPlot price1), Right (toPlot price2) + ] + $ setLayout1Foreground fg + $ defaultLayout1 + +------------------------------------------------------------------------------- +-- A quick test of stacked layouts + +test11 :: OutputType -> Renderable () +test11 otype = renderLayout1sStacked [withAnyOrdinate layout1, withAnyOrdinate layout2] + where + vs1 :: [(Int,Int)] + vs1 = [ (2,2), (3,40), (8,400), (12,60) ] + + vs2 :: [(Int,Double)] + vs2 = [ (0,0.7), (3,0.35), (4,0.25), (7, 0.6), (10,0.4) ] + + allx = map fst vs1 ++ map fst vs2 + extendRange = PlotHidden allx [] + + plot1 = plot_points_style ^= filledCircles 5 (opaque red) + $ plot_points_values ^= vs1 + $ defaultPlotPoints + + layout1 = layout1_title ^= "Integer Axis" + $ layout1_plots ^= [Left (toPlot plot1), Left (toPlot extendRange)] + $ defaultLayout1 + + plot2 = plot_lines_values ^= [vs2] + $ defaultPlotLines + + layout2 = layout1_title ^= "Float Axis" + $ layout1_plots ^= [Left (toPlot plot2), Left (toPlot extendRange)] + $ defaultLayout1 + +------------------------------------------------------------------------------- +-- More of an example that a test: +-- configuring axes explicitly configured axes + +test12 :: OutputType -> Renderable () +test12 otype = toRenderable layout + where + vs1 :: [(Int,Int)] + vs1 = [ (2,10), (3,40), (8,400), (12,60) ] + + baxis = AxisData { + axis_viewport_ = vmap (0,15), + axis_ticks_ = [(v,3) | v <- [0,1..15]], + axis_grid_ = [0,5..15], + axis_labels_ = [(v,show v) | v <- [0,5..15]] + } + + laxis = AxisData { + axis_viewport_ = vmap (0,500), + axis_ticks_ = [(v,3) | v <- [0,25..500]], + axis_grid_ = [0,100..500], + axis_labels_ = [(v,show v) | v <- [0,100..500]] + } + + plot = plot_lines_values ^= [vs1] + $ defaultPlotLines + + layout = layout1_plots ^= [Left (toPlot plot)] + $ layout1_bottom_axis ^: laxis_generate ^= const baxis + $ layout1_left_axis ^: laxis_generate ^= const laxis + $ layout1_title ^= "Explicit Axes" + $ defaultLayout1 + + +------------------------------------------------------------------------------- +-- Plot annotations test + +test13 otype = fillBackground fwhite $ (gridToRenderable t) + where + t = weights (1,1) $ aboveN [ besideN [tval (annotated h v) | h <- hs] | v <- vs ] + hs = [HTA_Left, HTA_Centre, HTA_Right] + vs = [VTA_Top, VTA_Centre, VTA_Bottom] + points=[-2..2] + pointPlot :: PlotPoints Int Int + pointPlot = plot_points_style^= filledCircles 2 (opaque red) + $ plot_points_values ^= [(x,x)|x<-points] + $ defaultPlotPoints + p = Left (toPlot pointPlot) + annotated h v = toRenderable ( layout1_plots ^= [Left (toPlot labelPlot), Left (toPlot rotPlot), p] $ defaultLayout1 ) + where labelPlot = plot_annotation_hanchor ^= h + $ plot_annotation_vanchor ^= v + $ plot_annotation_values ^= [(x,x,"Hello World (plain)")|x<-points] + $ defaultPlotAnnotation + rotPlot = plot_annotation_angle ^= -45.0 + $ plot_annotation_style ^= defaultFontStyle{font_size_=10,font_weight_=C.FontWeightBold, font_color_ =(opaque blue) } + $ plot_annotation_values ^= [(x,x,"Hello World (fancy)")|x<-points] + $ labelPlot + + +---------------------------------------------------------------------- +-- 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 $ opaque white + fblue = solidFillStyle $ opaque $ sRGB 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 + strokePath [Point 0 ya,Point w ya] + strokePath [Point xa 0,Point xa h] + render r sz + } + +---------------------------------------------------------------------- +allTests :: [ (String, OutputType -> Renderable ()) ] +allTests = + [ ("test1", \o -> Test1.chart (chooseLineWidth o) ) + , ("test1a", \o -> test1a (chooseLineWidth o) ) + , ("test2a", \o -> Test2.chart prices False (chooseLineWidth o)) + , ("test2b", \o -> Test2.chart prices1 False (chooseLineWidth o)) + , ("test2c", \o -> Test2.chart prices2 False (chooseLineWidth o)) + , ("test2d", \o -> Test2.chart prices3 False (chooseLineWidth o)) + , ("test2e", \o -> Test2.chart prices4 True (chooseLineWidth o)) + , ("test3", const Test3.chart) + , ("test4a", const (Test4.chart False False)) + , ("test4b", const (Test4.chart True False)) + , ("test4c", const (Test4.chart False True)) + , ("test4d", test4d) + , ("test5", \o -> Test5.chart (chooseLineWidth o)) + , ("test6", const Test6.chart) + , ("test7", const Test7.chart) + , ("test8", const Test8.chart) + , ("test9", const (Test9.chart True)) + , ("test9b", const (Test9.chart False)) + , ("test9c", test9 BarsCentered) + , ("test9l", test9 BarsLeft) + , ("test9r", test9 BarsRight) + , ("test10", test10 prices1) + , ("test11", test11) + , ("test12", test12) + , ("test13", test13) + , ("test14", \o -> Test14.chart (chooseLineWidth o) ) + , ("test15a", const (Test15.chart (LORows 2))) + , ("test15b", const (Test15.chart (LOCols 2))) + , ("misc1", misc1 0) + , ("misc1a", misc1 45) + , ("parametric", \o -> TestParametric.chart (chooseLineWidth o) ) + ] + +main = do + args <- getArgs + main1 args + +main1 :: [String] -> IO () +main1 ("--png":tests) = showTests tests renderToPNG +main1 ("--pdf":tests) = showTests tests renderToPDF +main1 ("--svg":tests) = showTests tests renderToSVG +main1 ("--ps":tests) = showTests tests renderToPS +main1 tests = showTests tests renderToWindow + +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) = 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") diff --git a/tests/test.hs b/tests/test.hs deleted file mode 100644 --- a/tests/test.hs +++ /dev/null @@ -1,493 +0,0 @@ -import qualified Graphics.Rendering.Cairo as C -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 Data.Colour -import Data.Colour.Names -import Data.Colour.SRGB -import Data.List(sort,nub,scanl1) -import qualified Data.Map as Map -import Control.Monad -import Prices - -data OutputType = Window | PNG | PS | PDF | SVG - -chooseLineWidth Window = 1.0 -chooseLineWidth PNG = 1.0 -chooseLineWidth PDF = 0.25 -chooseLineWidth PS = 0.25 -chooseLineWidth SVG = 0.25 - -green1 = opaque $ sRGB 0.5 1 0.5 -red1 = opaque $ sRGB 0.5 0.5 1 -fwhite = solidFillStyle $ opaque white -fparchment = solidFillStyle $ opaque $ sRGB 1.0 0.99 0.90 - ----------------------------------------------------------------------- -test1Layout otype = layout - where - am :: Double -> Double - am x = (sin (x*pi/45) + 1) / 2 * (sin (x*pi/5)) - - sinusoid1 = plot_lines_values ^= [[ (x,(am x)) | x <- [0,(0.5)..400]]] - $ plot_lines_style ^= solidLine lineWidth (opaque blue) - $ plot_lines_title ^="am" - $ defaultPlotLines - - sinusoid2 = plot_points_style ^= filledCircles 2 (opaque red) - $ plot_points_values ^= [ (x,(am x)) | x <- [0,7..400]] - $ plot_points_title ^="am points" - $ defaultPlotPoints - - layout = layout1_plots ^= [Left (toPlot sinusoid1), - Left (toPlot sinusoid2)] - $ layout1_background ^= fparchment - $ layout1_plot_background ^= Just fwhite - $ defaultLayout1 - - lineWidth = chooseLineWidth otype - -test1 :: OutputType -> Renderable () -test1 otype = toRenderable layout - where - layout = layout1_title ^= "Amplitude Modulation" - $ (test1Layout otype) - -test1a :: OutputType -> Renderable () -test1a otype = fillBackground fwhite $ (gridToRenderable t) - where - t = weights (1,1) $ aboveN [ besideN [rf g1, rf g2, rf g3], - besideN [rf g4, rf g5, rf g6] ] - - g1 = layout1_title ^= "minimal" - $ layout1_bottom_axis ^: laxis_override ^= (axisGridHide.axisTicksHide) - $ layout1_left_axis ^: laxis_override ^= (axisGridHide.axisTicksHide) - $ test1Layout otype - - g2 = layout1_title ^= "with borders" - $ layout1_bottom_axis ^: laxis_override ^= (axisGridHide.axisTicksHide) - $ layout1_left_axis ^: laxis_override ^= (axisGridHide.axisTicksHide) - $ layout1_top_axis ^: axisBorderOnly - $ layout1_right_axis ^: axisBorderOnly - $ test1Layout otype - - g3 = layout1_title ^= "default" - $ test1Layout otype - - g4 = layout1_title ^= "tight grid" - $ layout1_left_axis ^: laxis_generate ^= axis - $ layout1_left_axis ^: laxis_override ^= axisGridAtTicks - $ layout1_bottom_axis ^: laxis_generate ^= axis - $ layout1_bottom_axis ^: laxis_override ^= axisGridAtTicks - $ test1Layout otype - where - axis = autoScaledAxis ( - la_nLabels ^= 5 - $ la_nTicks ^= 20 - $ defaultLinearAxis - ) - - g5 = layout1_title ^= "y linked" - $ layout1_yaxes_control ^= linkAxes - $ test1Layout otype - - g6 = layout1_title ^= "everything" - $ layout1_yaxes_control ^= linkAxes - $ layout1_top_axis ^: laxis_visible ^= const True - $ test1Layout otype - - rf = tval.toRenderable - - axisBorderOnly = (laxis_visible ^= const True) - . (laxis_override ^= (axisGridHide.axisTicksHide.axisLabelsHide)) - ----------------------------------------------------------------------- -test2 :: [(Int,Int,Int,Double,Double)] -> Bool -> OutputType -> Renderable () -test2 prices showMinMax otype = toRenderable layout - where - - lineStyle c = line_width ^= 3 * chooseLineWidth otype - $ line_color ^= c - $ defaultPlotLines ^. plot_lines_style - - limitLineStyle c = line_width ^= chooseLineWidth otype - $ line_color ^= opaque c - $ line_dashes ^= [5,10] - $ defaultPlotLines ^. plot_lines_style - - price1 = plot_lines_style ^= lineStyle (opaque blue) - $ plot_lines_values ^= [[ ((date d m y), v) | (d,m,y,v,_) <- prices]] - $ plot_lines_title ^= "price 1" - $ defaultPlotLines - - price2 = plot_lines_style ^= lineStyle (opaque green) - $ plot_lines_values ^= [[ ((date d m y), v) | (d,m,y,_,v) <- prices]] - $ plot_lines_title ^= "price 2" - $ defaultPlotLines - - (min1,max1) = (minimum [v | (_,_,_,v,_) <- prices],maximum [v | (_,_,_,v,_) <- prices]) - (min2,max2) = (minimum [v | (_,_,_,_,v) <- prices],maximum [v | (_,_,_,_,v) <- prices]) - limits | showMinMax = [ Left $ hlinePlot "min/max" (limitLineStyle blue) min1, - Left $ hlinePlot "" (limitLineStyle blue) max1, - Right $ hlinePlot "min/max" (limitLineStyle green) min2, - Right $ hlinePlot "" (limitLineStyle green) max2 ] - | otherwise = [] - - bg = opaque $ sRGB 0 0 0.25 - fg = opaque white - fg1 = opaque $ sRGB 0.0 0.0 0.15 - - layout = layout1_title ^="Price History" - $ layout1_background ^= solidFillStyle bg - $ updateAllAxesStyles (axis_grid_style ^= solidLine 1 fg1) - $ layout1_left_axis ^: laxis_override ^= axisGridHide - $ layout1_right_axis ^: laxis_override ^= axisGridHide - $ layout1_bottom_axis ^: laxis_override ^= axisGridHide - $ layout1_plots ^= ([Left (toPlot price1), Right (toPlot price2)] ++ limits) - $ layout1_grid_last ^= False - $ setLayout1Foreground fg - $ defaultLayout1 - -date dd mm yyyy = (LocalTime (fromGregorian (fromIntegral yyyy) mm dd) midnight) - ----------------------------------------------------------------------- -test3 :: OutputType -> Renderable () -test3 otype = toRenderable layout - where - - price1 = plot_fillbetween_style ^= solidFillStyle green1 - $ plot_fillbetween_values ^= [ (date d m y,(0,v2)) | (d,m,y,v1,v2) <- prices] - $ plot_fillbetween_title ^= "price 1" - $ defaultPlotFillBetween - - price2 = plot_fillbetween_style ^= solidFillStyle red1 - $ plot_fillbetween_values ^= [ (date d m y,(0,v1)) | (d,m,y,v1,v2) <- prices] - $ plot_fillbetween_title ^= "price 2" - $ defaultPlotFillBetween - - layout = layout1_title ^= "Price History" - $ layout1_grid_last ^= True - $ layout1_plots ^= [Left (toPlot price1), - Left (toPlot price2)] - $ defaultLayout1 - ----------------------------------------------------------------------- -test4 :: Bool -> Bool -> OutputType -> Renderable () -test4 xrev yrev otype = toRenderable layout - where - - points = plot_points_style ^= filledCircles 3 (opaque red) - $ plot_points_values ^= [ (x, LogValue (10**x)) | x <- [0.5,1,1.5,2,2.5] ] - $ plot_points_title ^= "values" - $ defaultPlotPoints - - lines = plot_lines_values ^= [ [(x, LogValue (10**x)) | x <- [0,3]] ] - $ plot_lines_title ^= "values" - $ 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 ^= [Left (toPlot points), Left (toPlot lines) ] - $ defaultLayout1 - ----------------------------------------------------------------------- --- Example thanks to Russell O'Connor - -test5 :: OutputType -> Renderable () -test5 otype = toRenderable (layout 1001 (trial bits) :: Layout1 Double LogValue) - where - bits = randoms $ mkStdGen 0 - - layout n t = layout1_title ^= "Simulation of betting on a biased coin" - $ layout1_plots ^= [ - Left (toPlot (plot "f=0.05" s1 n 0 (t 0.05))), - Left (toPlot (plot "f=0.1" s2 n 0 (t 0.1))) - ] - $ defaultLayout1 - - plot tt 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]] - $ plot_lines_title ^= tt - $ defaultPlotLines - - b = 0.1 - - trial bits frac = scanl (*) 1 (map f bits) - where - f True = (1+frac*(1+b)) - f False = (1-frac) - - s1 = solidLine lineWidth $ opaque green - s2 = solidLine lineWidth $ opaque blue - - lineWidth = chooseLineWidth otype - - ----------------------------------------------------------------------- --- Test the Simple interface - -test6 :: OutputType -> Renderable () -test6 otype = toRenderable (plotLayout pp){layout1_title_="Graphics.Rendering.Chart.Simple example"} - where - pp = plot xs sin "sin" - cos "cos" "o" - (sin.sin.cos) "sin.sin.cos" "." - (/3) "- " - (const 0.5) - [0.1,0.7,0.5::Double] "+" - xs = [0,0.3..3] :: [Double] - ----------------------------------------------------------------------- -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 = plot_errbars_values ^= [symErrPoint x y dx dy | (x,y,dx,dy) <- vals] - $ plot_errbars_title ^="test" - $ defaultPlotErrBars - - points = plot_points_style ^= filledCircles 2 (opaque red) - $ plot_points_values ^= [(x,y) | (x,y,dx,dy) <- vals] - $ plot_points_title ^= "test" - $ defaultPlotPoints - - layout = layout1_title ^= "errorbars example" - $ layout1_plots ^= [Left (toPlot bars), - Left (toPlot points)] - $ defaultLayout1 - ----------------------------------------------------------------------- - -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 = pie_title ^= "Pie Chart Example" - $ pie_plot ^: pie_data ^= [ defaultPieItem{pitem_value_=v,pitem_label_=s,pitem_offset_=o} - | (s,v,o) <- values ] - $ defaultPieLayout - ----------------------------------------------------------------------- - - -test9 :: PlotBarsAlignment -> OutputType -> Renderable () -test9 alignment otype = fillBackground fwhite $ (gridToRenderable t) - where - t = weights (1,1) $ aboveN [ besideN [rf g0, rf g1, rf g2], - besideN [rf g3, rf g4, rf g5] ] - - g0 = layout "clustered 1" - $ plot_bars_style ^= BarsClustered - $ plot_bars_spacing ^= BarsFixWidth 25 - $ bars1 - - g1 = layout "clustered/fix width " - $ plot_bars_style ^= BarsClustered - $ plot_bars_spacing ^= BarsFixWidth 25 - $ bars2 - - g2 = layout "clustered/fix gap " - $ plot_bars_style ^= BarsClustered - $ plot_bars_spacing ^= BarsFixGap 10 - $ bars2 - - g3 = layout "stacked 1" - $ plot_bars_style ^= BarsStacked - $ plot_bars_spacing ^= BarsFixWidth 25 - $ bars1 - - g4 = layout "stacked/fix width" - $ plot_bars_style ^= BarsStacked - $ plot_bars_spacing ^= BarsFixWidth 25 - $ bars2 - - g5 = layout "stacked/fix gap" - $ plot_bars_style ^= BarsStacked - $ plot_bars_spacing ^= BarsFixGap 10 - $ bars2 - - rf = tval.toRenderable - - alabels = [ "Jun", "Jul", "Aug", "Sep", "Oct" ] - - - layout title bars = - layout1_title ^= (show alignment ++ "/" ++ title) - $ layout1_title_style ^: font_size ^= 10 - $ layout1_bottom_axis ^: laxis_generate ^= autoIndexAxis alabels - $ layout1_left_axis ^: laxis_override ^= (axisGridHide.axisTicksHide) - $ layout1_plots ^= [ Left (plotBars bars) ] - $ defaultLayout1 :: Layout1 PlotIndex Double - - bars1 = plot_bars_titles ^= ["Cash"] - $ plot_bars_values ^= addIndexes [[20],[45],[30],[70]] - $ plot_bars_alignment ^= alignment - $ defaultPlotBars - - bars2 = plot_bars_titles ^= ["Cash","Equity"] - $ plot_bars_values ^= addIndexes [[20,45],[45,30],[30,20],[70,25]] - $ plot_bars_alignment ^= alignment - $ defaultPlotBars - -------------------------------------------------------------------------------- - -test10 :: [(Int,Int,Int,Double,Double)] -> OutputType -> Renderable () -test10 prices otype = toRenderable layout - where - - lineStyle c = line_width ^= 3 * chooseLineWidth otype - $ line_color ^= c - $ defaultPlotLines ^. plot_lines_style - - price1 = plot_lines_style ^= lineStyle (opaque blue) - $ plot_lines_values ^= [[ ((date d m y), v) | (d,m,y,v,_) <- prices]] - $ plot_lines_title ^= "price 1" - $ defaultPlotLines - - price1_area = plot_fillbetween_values ^= [((date d m y), (v * 0.95, v * 1.05)) | (d,m,y,v,_) <- prices] - $ plot_fillbetween_style ^= solidFillStyle (withOpacity blue 0.2) - $ defaultPlotFillBetween - - price2 = plot_lines_style ^= lineStyle (opaque red) - $ plot_lines_values ^= [[ ((date d m y), v) | (d,m,y,_,v) <- prices]] - $ plot_lines_title ^= "price 2" - $ defaultPlotLines - - price2_area = plot_fillbetween_values ^= [((date d m y), (v * 0.95, v * 1.05)) | (d,m,y,_,v) <- prices] - $ plot_fillbetween_style ^= solidFillStyle (withOpacity red 0.2) - $ defaultPlotFillBetween - - fg = opaque black - fg1 = opaque $ sRGB 0.0 0.0 0.15 - - layout = layout1_title ^="Price History" - $ layout1_background ^= solidFillStyle (opaque white) - $ layout1_right_axis ^: laxis_override ^= axisGridHide - $ layout1_plots ^= [ Left (toPlot price1_area), Right (toPlot price2_area) - , Left (toPlot price1), Right (toPlot price2) - ] - $ setLayout1Foreground fg - $ defaultLayout1 - -------------------------------------------------------------------------------- --- A quick test of stacked layouts - -test11 :: OutputType -> Renderable () -test11 otype = renderLayout1sStacked [withAnyOrdinate layout1, withAnyOrdinate layout2] - where - vs1 :: [(Int,Int)] - vs1 = [ (2,2), (3,40), (8,400), (12,60) ] - - vs2 :: [(Int,Double)] - vs2 = [ (0,0.7), (3,0.35), (4,0.25), (7, 0.6), (10,0.4) ] - - allx = map fst vs1 ++ map fst vs2 - extendRange = PlotHidden allx [] - - plot1 = plot_points_style ^= filledCircles 5 (opaque red) - $ plot_points_values ^= vs1 - $ defaultPlotPoints - - layout1 = layout1_title ^= "Integer Axis" - $ layout1_plots ^= [Left (toPlot plot1), Left (toPlot extendRange)] - $ defaultLayout1 - - plot2 = plot_lines_values ^= [vs2] - $ defaultPlotLines - - layout2 = layout1_title ^= "Float Axis" - $ layout1_plots ^= [Left (toPlot plot2), Left (toPlot extendRange)] - $ defaultLayout1 - ----------------------------------------------------------------------- --- 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 $ opaque white - fblue = solidFillStyle $ opaque $ sRGB 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 -> Renderable ()) ] -allTests = - [ ("test1", test1) - , ("test1a", test1a) - , ("test2a", test2 prices False) - , ("test2b", test2 (filterPrices (date 1 1 2005) (date 31 12 2005)) False) - , ("test2c", test2 (filterPrices (date 1 5 2005) (date 1 7 2005)) False) - , ("test2d", test2 (filterPrices (date 1 1 2006) (date 10 1 2006)) False) - , ("test2e", test2 (filterPrices (date 1 8 2005) (date 31 8 2005)) True) - , ("test3", test3) - , ("test4a", test4 False False) - , ("test4b", test4 True False) - , ("test4c", test4 False True) - , ("test5", test5) - , ("test6", test6) - , ("test7", test7) - , ("test8", test8) - , ("test9c", test9 BarsCentered) - , ("test9l", test9 BarsLeft) - , ("test9r", test9 BarsRight) - , ("test10", test10 (filterPrices (date 1 1 2005) (date 31 12 2005))) - , ("test11", test11) - , ("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] - -main = do - args <- getArgs - main1 args - -main1 :: [String] -> IO () -main1 ("--png":tests) = showTests tests renderToPNG -main1 ("--pdf":tests) = showTests tests renderToPDF -main1 ("--svg":tests) = showTests tests renderToSVG -main1 ("--ps":tests) = showTests tests renderToPS -main1 tests = showTests tests renderToWindow - -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) = 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")