Chart 0.12 → 0.13
raw patch · 27 files changed
+2323/−1548 lines, 27 files
Files
- Chart.cabal +17/−2
- Graphics/Rendering/Chart.hs +5/−3
- Graphics/Rendering/Chart/AreaSpots.hs +107/−0
- Graphics/Rendering/Chart/Axis.hs +330/−292
- Graphics/Rendering/Chart/Grid.hs +105/−86
- Graphics/Rendering/Chart/Layout.hs +155/−139
- Graphics/Rendering/Chart/Legend.hs +45/−21
- Graphics/Rendering/Chart/Pie.hs +53/−44
- Graphics/Rendering/Chart/Plot.hs +259/−171
- Graphics/Rendering/Chart/Renderable.hs +69/−71
- Graphics/Rendering/Chart/Simple.hs +147/−124
- Graphics/Rendering/Chart/Types.hs +145/−100
- tests/Prices.hs +18/−2
- tests/Test1.hs +41/−0
- tests/Test14.hs +48/−0
- tests/Test15.hs +45/−0
- tests/Test2.hs +64/−0
- tests/Test3.hs +40/−0
- tests/Test4.hs +39/−0
- tests/Test5.hs +50/−0
- tests/Test6.hs +24/−0
- tests/Test7.hs +36/−0
- tests/Test8.hs +26/−0
- tests/Test9.hs +40/−0
- tests/TestParametric.hs +30/−0
- tests/all_tests.hs +385/−0
- tests/test.hs +0/−493
Chart.cabal view
@@ -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
Graphics/Rendering/Chart.hs view
@@ -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
+ Graphics/Rendering/Chart/AreaSpots.hs view
@@ -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 )
Graphics/Rendering/Chart/Axis.hs view
@@ -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 (<b) [a,a+size..] ++ [b] where- a = (floor (min / fromIntegral size)) * size+ a = (floor (min / fromIntegral size)) * size b = (ceiling (max / fromIntegral size)) * size -steps :: Double -> 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 )
Graphics/Rendering/Chart/Grid.hs view
@@ -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))
Graphics/Rendering/Chart/Layout.hs view
@@ -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)
Graphics/Rendering/Chart/Legend.hs view
@@ -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 )
Graphics/Rendering/Chart/Pie.hs view
@@ -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 ) -
Graphics/Rendering/Chart/Plot.hs view
@@ -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 )
Graphics/Rendering/Chart/Renderable.hs view
@@ -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)
Graphics/Rendering/Chart/Simple.hs view
@@ -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]
Graphics/Rendering/Chart/Types.hs view
@@ -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 )
tests/Prices.hs view
@@ -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)++
+ tests/Test1.hs view
@@ -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++
+ tests/Test14.hs view
@@ -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
+ tests/Test15.hs view
@@ -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++
+ tests/Test2.hs view
@@ -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
+ tests/Test3.hs view
@@ -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
+ tests/Test4.hs view
@@ -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++
+ tests/Test5.hs view
@@ -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++
+ tests/Test6.hs view
@@ -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
+ tests/Test7.hs view
@@ -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++
+ tests/Test8.hs view
@@ -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++
+ tests/Test9.hs view
@@ -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++
+ tests/TestParametric.hs view
@@ -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
+ tests/all_tests.hs view
@@ -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")
− tests/test.hs
@@ -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")