diff --git a/Chart.cabal b/Chart.cabal --- a/Chart.cabal +++ b/Chart.cabal @@ -1,5 +1,5 @@ Name: Chart -Version: 0.10.3 +Version: 0.11 License: BSD3 License-file: LICENSE Copyright: Tim Docker, 2006-2009 @@ -22,7 +22,7 @@ Build-depends: base >= 3, old-locale, time, mtl, array else Build-depends: base < 3 - Build-depends: gtk >= 0.9.11, cairo >= 0.9.11, time, mtl, array, data-accessor == 0.2.*, data-accessor-template >= 0.2.1.1 && < 0.3 + Build-depends: gtk >= 0.9.11, cairo >= 0.9.11, time, mtl, array, data-accessor == 0.2.*, data-accessor-template >= 0.2.1.1 && < 0.3, colour >= 2.2.1 Exposed-modules: Graphics.Rendering.Chart, diff --git a/Graphics/Rendering/Chart/Axis.hs b/Graphics/Rendering/Chart/Axis.hs --- a/Graphics/Rendering/Chart/Axis.hs +++ b/Graphics/Rendering/Chart/Axis.hs @@ -88,6 +88,8 @@ import Control.Monad import Data.List import Data.Accessor.Template +import Data.Colour (opaque) +import Data.Colour.Names (black, lightgrey) import Graphics.Rendering.Chart.Types import Graphics.Rendering.Chart.Renderable @@ -425,8 +427,8 @@ ---------------------------------------------------------------------- -defaultAxisLineStyle = solidLine 1 black -defaultGridLineStyle = dashedLine 1 [5,5] grey8 +defaultAxisLineStyle = solidLine 1 $ opaque black +defaultGridLineStyle = dashedLine 1 [5,5] $ opaque lightgrey defaultAxisStyle = AxisStyle { axis_line_style_ = defaultAxisLineStyle, diff --git a/Graphics/Rendering/Chart/Layout.hs b/Graphics/Rendering/Chart/Layout.hs --- a/Graphics/Rendering/Chart/Layout.hs +++ b/Graphics/Rendering/Chart/Layout.hs @@ -73,6 +73,8 @@ import Control.Monad.Reader (local) import Data.Accessor.Template import Data.Accessor +import Data.Colour +import Data.Colour.Names (white) -- | A @MAxisFn@ is a function that generates an (optional) axis -- given the points plotted against that axis. @@ -198,15 +200,15 @@ legends = gridToRenderable (besideN [ tval $ mkLegend lefts, weights (1,1) $ tval $ emptyRenderable, tval $ mkLegend rights ]) - lefts = [ p | (Left p) <- (layout1_plots_ l) ] - rights = [ p | (Right p) <- (layout1_plots_ l) ] + lefts = concat [ plot_legend_ p | (Left p) <- (layout1_plots_ l) ] + rights = concat [ plot_legend_ p | (Right p) <- (layout1_plots_ l) ] - mkLegend plots = case (layout1_legend_ l) of + mkLegend vals = case (layout1_legend_ l) of Nothing -> emptyRenderable - (Just ls) -> case plots of + (Just ls) -> case filter ((/="").fst) vals of [] -> emptyRenderable - ps -> addMargins (0,lm,lm,lm) - (mapPickFn L1P_Legend $ legendToRenderable (Legend True ls ps)) + lvs -> addMargins (0,lm,lm,lm) + (mapPickFn L1P_Legend $ legendToRenderable (Legend True ls lvs)) lm = layout1_margin_ l @@ -235,7 +237,11 @@ rPlot1 (Just (AxisT _ xs xrev xaxis)) (Just (AxisT _ ys yrev yaxis)) p = let xrange = if xrev then (w, 0) else (0,w) yrange = if yrev then (0, h) else (h, 0) - pmfn (x,y) = Point (axis_viewport_ xaxis xrange x) (axis_viewport_ yaxis yrange y) + 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 _ f (LValue v) = f v in plot_render_ p pmfn rPlot1 _ _ _ = return () @@ -273,14 +279,14 @@ 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,_) <- plot_all_points_ p] - yvals0 = [ y | (Left p) <- plots, (_,y) <- plot_all_points_ p] - xvals1 = [ x | (Right p) <- plots, (x,_) <- plot_all_points_ p] - yvals1 = [ y | (Right p) <- plots, (_,y) <- plot_all_points_ p] + 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 white, + layout1_background_ = solidFillStyle $ opaque white, layout1_plot_background_ = Nothing, layout1_title_ = "", @@ -325,7 +331,7 @@ (layout1_right_axis .> laxis_style ^: uf) -- | Helper to set the forground color uniformly on a Layout1 -setLayout1Foreground :: Color -> Layout1 x y -> Layout1 x y +setLayout1Foreground :: AlphaColour Double -> Layout1 x y -> Layout1 x y setLayout1Foreground fg = updateAllAxesStyles ( (axis_line_style .> line_color ^= fg). (axis_label_style .> font_color ^= fg) diff --git a/Graphics/Rendering/Chart/Legend.hs b/Graphics/Rendering/Chart/Legend.hs --- a/Graphics/Rendering/Chart/Legend.hs +++ b/Graphics/Rendering/Chart/Legend.hs @@ -35,18 +35,18 @@ legend_plot_size_ :: Double } -data Legend x y = Legend Bool LegendStyle [Plot x y] +data Legend x y = Legend Bool LegendStyle [(String, Rect -> CRender ())] instance ToRenderable (Legend x y) where toRenderable = setPickFn nullPickFn.legendToRenderable legendToRenderable :: Legend x y -> Renderable String -legendToRenderable (Legend _ ls plots) = gridToRenderable grid +legendToRenderable (Legend _ ls lvs) = gridToRenderable grid where grid = besideN $ intersperse ggap1 (map (tval.rf) ps) ps :: [(String, [Rect -> CRender ()])] - ps = join_nub (concatMap plot_legend_ plots) + ps = join_nub lvs rf (title,rfs) = gridToRenderable grid1 where diff --git a/Graphics/Rendering/Chart/Pie.hs b/Graphics/Rendering/Chart/Pie.hs --- a/Graphics/Rendering/Chart/Pie.hs +++ b/Graphics/Rendering/Chart/Pie.hs @@ -56,7 +56,9 @@ import Data.List import Data.Bits import Data.Accessor.Template -import Control.Monad +import Data.Colour +import Data.Colour.Names (black, white) +import Control.Monad import Graphics.Rendering.Chart.Types import Graphics.Rendering.Chart.Legend @@ -73,7 +75,7 @@ data PieChart = PieChart { pie_data_ :: [PieItem], - pie_colors_ :: [Color], + pie_colors_ :: [AlphaColour Double], pie_label_style_ :: CairoFontStyle, pie_label_line_style_ :: CairoLineStyle, pie_start_angle_ :: Double @@ -90,14 +92,14 @@ pie_data_ = [], pie_colors_ = defaultColorSeq, pie_label_style_ = defaultFontStyle, - pie_label_line_style_ = solidLine 1 black, + pie_label_line_style_ = solidLine 1 $ opaque black, pie_start_angle_ = 0 } defaultPieItem = PieItem "" 0 0 defaultPieLayout = PieLayout { - pie_background_ = solidFillStyle white, + pie_background_ = solidFillStyle $ opaque white, pie_title_ = "", pie_title_style_ = defaultFontStyle{font_size_=15, font_weight_=C.FontWeightBold}, pie_plot_ = defaultPieChart, @@ -147,7 +149,7 @@ content = let total = sum (map pitem_value_ (pie_data_ p)) in [ pi{pitem_value_=pitem_value_ pi/total} | pi <- pie_data_ p ] - paint :: Point -> Double -> Double -> (Color,PieItem) -> CRender Double + paint :: 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) @@ -178,8 +180,8 @@ let p2 = p1 `pvadd` (Vector (offset label_rgap) 0) drawText anchor VTA_Bottom p2 name - pieSlice :: Point -> Double -> Double -> Color -> CRender () - pieSlice (Point x y) a1 a2 color = c $ do + 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) C.lineTo x y diff --git a/Graphics/Rendering/Chart/Plot.hs b/Graphics/Rendering/Chart/Plot.hs --- a/Graphics/Rendering/Chart/Plot.hs +++ b/Graphics/Rendering/Chart/Plot.hs @@ -57,7 +57,11 @@ plot_lines_title, plot_lines_style, plot_lines_values, + plot_lines_limit_values, + hlinePlot, + vlinePlot, + plot_render, plot_legend, plot_all_points, @@ -92,6 +96,9 @@ import Control.Monad import Data.List import Data.Accessor.Template +import Data.Colour +import Data.Colour.SRGB (sRGB) +import Data.Colour.Names -- | Interface to control plotting on a 2D area. data Plot x y = Plot { @@ -107,7 +114,7 @@ -- | All of the model space coordinates to be plotted. These are -- used to autoscale the axes where necessary. - plot_all_points_ :: [(x,y)] + plot_all_points_ :: ([x],[y]) } -- | a type class abstracting the conversion of a value to a Plot. @@ -116,12 +123,18 @@ ---------------------------------------------------------------------- +mapXY :: PointMapFn x y -> ((x,y) -> Point) +mapXY f (x,y) = f (LValue x, LValue y) + +---------------------------------------------------------------------- + -- | Value defining a series of (possibly disjointed) lines, -- 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_values_ :: [[(x,y)]], + plot_lines_limit_values_ :: [[(Limit x, Limit y)]] } @@ -129,15 +142,20 @@ toPlot p = Plot { plot_render_ = renderPlotLines p, plot_legend_ = [(plot_lines_title_ p, renderPlotLegendLines p)], - plot_all_points_ = concat (plot_lines_values_ p) + plot_all_points_ = (map fst pts ++ xs , map snd pts ++ ys) } + where + pts = concat (plot_lines_values_ p) + xs = [ x | (LValue x,_) <- concat (plot_lines_limit_values_ p)] + ys = [ y | (_,LValue y) <- concat (plot_lines_limit_values_ p)] renderPlotLines :: PlotLines x y -> PointMapFn x y -> CRender () renderPlotLines p pmap = preserveCState $ do setLineStyle (plot_lines_style_ p) - mapM_ drawLines (plot_lines_values_ p) + mapM_ (drawLines (mapXY pmap)) (plot_lines_values_ p) + mapM_ (drawLines pmap) (plot_lines_limit_values_ p) where - drawLines (p:ps) = do + drawLines pmap (p:ps) = do moveTo (pmap p) mapM_ (\p -> lineTo (pmap p)) ps c $ C.stroke @@ -150,7 +168,7 @@ lineTo (Point (p_x p2) y) c $ C.stroke -defaultPlotLineStyle = (solidLine 1 blue){ +defaultPlotLineStyle = (solidLine 1 $ opaque blue){ line_cap_ = C.LineCapRound, line_join_ = C.LineJoinRound } @@ -158,8 +176,26 @@ defaultPlotLines = PlotLines { plot_lines_title_ = "", plot_lines_style_ = defaultPlotLineStyle, - plot_lines_values_ = [] + plot_lines_values_ = [], + plot_lines_limit_values_ = [] } + +-- | 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)]] + } + +-- | 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)]] + } + ---------------------------------------------------------------------- -- | Value defining a series of datapoints, and a style in @@ -175,13 +211,16 @@ toPlot p = Plot { plot_render_ = renderPlotPoints p, plot_legend_ = [(plot_points_title_ p, renderPlotLegendPoints p)], - plot_all_points_ = plot_points_values_ p + plot_all_points_ = (map fst pts, map snd pts) } + where + pts = plot_points_values_ p renderPlotPoints :: PlotPoints x y -> PointMapFn x y -> CRender () renderPlotPoints p pmap = preserveCState $ do - mapM_ (drawPoint.pmap) (plot_points_values_ p) + mapM_ (drawPoint.pmap') (plot_points_values_ p) where + pmap' = mapXY pmap (CairoPointStyle drawPoint) = (plot_points_style_ p) @@ -229,8 +268,9 @@ lineTo p0 c $ C.fill where - (p0:p1s) = map pmap [ (x,y1) | (x,(y1,y2)) <- vs ] - p2s = map pmap [ (x,y2) | (x,(y1,y2)) <- vs ] + pmap' = mapXY pmap + (p0:p1s) = map pmap' [ (x,y1) | (x,(y1,y2)) <- vs ] + p2s = map pmap' [ (x,y2) | (x,(y1,y2)) <- vs ] renderPlotLegendFill :: PlotFillBetween x y -> Rect -> CRender () renderPlotLegendFill p r = preserveCState $ do @@ -238,15 +278,16 @@ rectPath r c $ C.fill -plotAllPointsFillBetween :: PlotFillBetween x y -> [(x,y)] -plotAllPointsFillBetween p = concat [ [(x, y1), (x, y2)] - | (x,(y1,y2)) <- plot_fillbetween_values_ p] +plotAllPointsFillBetween :: PlotFillBetween x y -> ([x],[y]) +plotAllPointsFillBetween p = ([x|(x,(_,_)) <- pts], concat [[y1,y2]|(_,(y1,y2)) <- pts]) + where + pts = plot_fillbetween_values_ p defaultPlotFillBetween = PlotFillBetween { plot_fillbetween_title_ = "", - plot_fillbetween_style_=solidFillStyle (Color 0.5 0.5 1.0), - plot_fillbetween_values_=[] + plot_fillbetween_style_ = solidFillStyle (opaque $ sRGB 0.5 0.5 1.0), + plot_fillbetween_values_= [] } ---------------------------------------------------------------------- @@ -284,10 +325,11 @@ toPlot p = Plot { plot_render_ = renderPlotErrBars p, plot_legend_ = [(plot_errbars_title_ p,renderPlotLegendErrBars p)], - plot_all_points_ = concat - [[((ev_low x),(ev_low y)), ((ev_high x),(ev_high y))] - | ErrPoint x y <- plot_errbars_values_ p] + 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 renderPlotErrBars :: PlotErrBars x y -> PointMapFn x y -> CRender () renderPlotErrBars p pmap = preserveCState $ do @@ -295,10 +337,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) - (Point xl' yl') = pmap (xl,yl) - (Point xh' yh') = pmap (xh,yh) + 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 drawErrBar0 ps (ErrPoint (ErrValue xl x xh) (ErrValue yl y yh)) = do let tl = plot_errbars_tick_length_ ps @@ -331,7 +374,7 @@ defaultPlotErrBars = PlotErrBars { plot_errbars_title_ = "", - plot_errbars_line_style_ = solidLine 1 blue, + plot_errbars_line_style_ = solidLine 1 $ opaque blue, plot_errbars_tick_length_ = 3, plot_errbars_overhang_ = 0, plot_errbars_values_ = [] @@ -392,7 +435,7 @@ } where istyles = map mkstyle defaultColorSeq - mkstyle c = (solidFillStyle c,Just (solidLine 1.0 black)) + mkstyle c = (solidFillStyle c,Just (solidLine 1.0 $ opaque black)) plotBars :: (BarsPlotValue y) => PlotBars x y -> Plot x y plotBars p = Plot { @@ -432,8 +475,8 @@ c $ C.stroke barPath xos x y0 y1 = do - let (Point x' y') = pmap (x,y1) - let (Point _ y0') = pmap (x,y0) + let (Point x' y') = pmap' (x,y1) + let (Point _ y0') = pmap' (x,y0) rectPath (Rect (Point (x'+xos) y0') (Point (x'+xos+width) y')) yref0 = plot_bars_reference_ p @@ -447,19 +490,22 @@ minXInterval = minimum $ zipWith (-) (tail xs) xs where - xs = nub $ sort $ map (p_x.pmap) (allBarPoints p) + xs = nub $ sort $ map (\x-> p_x (pmap' (x,barsReference))) (fst (allBarPoints p)) nys = maximum [ length ys | (x,ys) <- vals ] + + pmap' = mapXY pmap whenJust :: (Monad m) => Maybe a -> (a -> m ()) -> m () whenJust (Just a) f = f a whenJust _ _ = return () -allBarPoints :: (BarsPlotValue y) => PlotBars x y -> [(x,y)] +allBarPoints :: (BarsPlotValue y) => PlotBars x y -> ([x],[y]) allBarPoints p = case (plot_bars_style_ p) of - BarsClustered -> concat [ (x,y0):[(x,y) | y <- ys ] | (x,ys) <- plot_bars_values_ p ] - BarsStacked -> concat [ (x,y0):[(x,y) | y <- stack ys ] | (x,ys) <- plot_bars_values_ p ] + BarsClustered -> ( [x| (x,_) <- pts], concat [ys| (_,ys) <- pts] ) + BarsStacked -> ( [x| (x,_) <- pts], concat [stack ys | (_,ys) <- pts] ) where + pts = plot_bars_values_ p y0 = plot_bars_reference_ p stack :: (BarsPlotValue y) => [y] -> [y] diff --git a/Graphics/Rendering/Chart/Simple.hs b/Graphics/Rendering/Chart/Simple.hs --- a/Graphics/Rendering/Chart/Simple.hs +++ b/Graphics/Rendering/Chart/Simple.hs @@ -36,15 +36,15 @@ ) where import Data.Maybe ( catMaybes ) +import Data.Colour +import Data.Colour.Names import Graphics.Rendering.Chart import Graphics.Rendering.Chart.Gtk -styleColor :: Int -> Color +styleColor :: Int -> AlphaColour Double styleColor ind = colorSequence !! ind - where colorSequence = cycle [Color 0 0 1,Color 1 0 0,Color 0 1 0, - Color 1 1 0,Color 0 1 1,Color 1 0 1, - Color 0 0 0] + where colorSequence = cycle $ map opaque [blue, red, green, yellow, cyan, magenta, black] styleSymbol :: Int -> PlotKind styleSymbol ind = symbolSequence !! ind diff --git a/Graphics/Rendering/Chart/Types.hs b/Graphics/Rendering/Chart/Types.hs --- a/Graphics/Rendering/Chart/Types.hs +++ b/Graphics/Rendering/Chart/Types.hs @@ -41,6 +41,7 @@ within, RectEdge(..), + Limit(..), PointMapFn, preserveCState, @@ -53,11 +54,8 @@ isValidNumber, maybeM, - black, grey8, white, red, green, blue, defaultColorSeq, - - Color(..), - color, + setSourceColor, CairoLineStyle(..), @@ -113,6 +111,9 @@ import Control.Monad.Reader import Data.Accessor import Data.Accessor.Template +import Data.Colour +import Data.Colour.SRGB +import Data.Colour.Names -- | A point in two dimensions data Point = Point { @@ -125,15 +126,6 @@ v_y :: Double } deriving Show -data Color = Color { - c_r :: Double, - c_g :: Double, - c_b :: Double -} - -color :: Int -> Int -> Int -> Color -color ri gi bi = Color (fromIntegral ri/255) (fromIntegral gi/255) (fromIntegral bi/255) - -- | scale a vector by a constant vscale :: Double -> Vector -> Vector vscale c (Vector x y) = (Vector (x*c) (y*c)) @@ -150,8 +142,11 @@ 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 -type PointMapFn x y = (x,y) -> Point +type PointMapFn x y = (Limit x, Limit y) -> Point -- | A rectangle is defined by two points data Rect = Rect Point Point @@ -210,7 +205,7 @@ -- | Data type for the style of a line data CairoLineStyle = CairoLineStyle { line_width_ :: Double, - line_color_ :: Color, + line_color_ :: AlphaColour Double, line_dashes_ :: [Double], line_cap_ :: C.LineCap, line_join_ :: C.LineJoin @@ -228,20 +223,15 @@ font_size_ :: Double, font_slant_ :: C.FontSlant, font_weight_ :: C.FontWeight, - font_color_ :: Color + font_color_ :: AlphaColour Double } type Range = (Double,Double) type RectSize = (Double,Double) -black = Color 0 0 0 -grey8 = Color 0.8 0.8 0.8 -white = Color 1 1 1 -red = Color 1 0 0 -green = Color 0 1 0 -blue = Color 0 0 1 +defaultColorSeq :: [AlphaColour Double] +defaultColorSeq = cycle $ map opaque [blue, red, green, yellow, cyan, magenta] -defaultColorSeq = cycle [blue,red,green, Color 1 1 0,Color 0 1 1,Color 1 0 1 ] ---------------------------------------------------------------------- -- Assorted helper functions in Cairo Usage @@ -306,8 +296,12 @@ setFillStyle (CairoFillStyle s) = s -setSourceColor (Color r g b) = C.setSourceRGB r g b +colourChannel :: (Floating a, Ord a) => AlphaColour a -> Colour a +colourChannel c = darken (recip (alphaChannel c)) (c `over` black) +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. textSize :: String -> CRender RectSize @@ -351,7 +345,7 @@ filledCircles :: Double -- ^ radius of circle - -> Color -- ^ colour + -> AlphaColour Double -- ^ colour -> CairoPointStyle filledCircles radius cl = CairoPointStyle rf where @@ -365,7 +359,7 @@ hollowCircles :: Double -- ^ radius of circle -> Double -- ^ thickness of line - -> Color + -> AlphaColour Double -> CairoPointStyle hollowCircles radius w cl = CairoPointStyle rf where @@ -382,7 +376,7 @@ -> Double -- ^ thickness of line -> Int -- ^ Number of vertices -> Bool -- ^ Is right-side-up? - -> Color + -> AlphaColour Double -> CairoPointStyle hollowPolygon radius w sides isrot cl = CairoPointStyle rf where rf p = @@ -403,7 +397,7 @@ Double -- ^ radius of circle -> Int -- ^ Number of vertices -> Bool -- ^ Is right-side-up? - -> Color + -> AlphaColour Double -> CairoPointStyle filledPolygon radius sides isrot cl = CairoPointStyle rf where rf p = @@ -422,7 +416,7 @@ plusses :: Double -- ^ radius of circle -> Double -- ^ thickness of line - -> Color + -> AlphaColour Double -> CairoPointStyle plusses radius w cl = CairoPointStyle rf where rf p = do (Point x y ) <- alignp p @@ -438,7 +432,7 @@ exes :: Double -- ^ radius of circle -> Double -- ^ thickness of line - -> Color + -> AlphaColour Double -> CairoPointStyle exes radius w cl = CairoPointStyle rf where rad = radius / sqrt 2 @@ -455,7 +449,7 @@ stars :: Double -- ^ radius of circle -> Double -- ^ thickness of line - -> Color + -> AlphaColour Double -> CairoPointStyle stars radius w cl = CairoPointStyle rf where rad = radius / sqrt 2 @@ -475,31 +469,31 @@ solidLine :: Double -- ^ width of line - -> Color + -> 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 - -> Color + -> AlphaColour Double -> CairoLineStyle dashedLine w ds cl = CairoLineStyle w cl ds C.LineCapButt C.LineJoinMiter solidFillStyle :: - Color + AlphaColour Double -> CairoFillStyle solidFillStyle cl = CairoFillStyle fn where fn = c $ setSourceColor cl -defaultPointStyle = filledCircles 1 white +defaultPointStyle = filledCircles 1 $ opaque white defaultFontStyle = CairoFontStyle { font_name_ = "sans", font_size_ = 10, font_slant_ = C.FontSlantNormal, font_weight_ = C.FontWeightNormal, - font_color_ = black + font_color_ = opaque black } isValidNumber v = not (isNaN v) && not (isInfinite v) diff --git a/tests/test.hs b/tests/test.hs --- a/tests/test.hs +++ b/tests/test.hs @@ -11,9 +11,11 @@ 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 Debug.Trace import Control.Monad import Prices @@ -25,23 +27,23 @@ chooseLineWidth PS = 0.25 chooseLineWidth SVG = 0.25 -green1 = (Color 0.5 1 0.5) -red1 = (Color 0.5 0.5 1) -fwhite = solidFillStyle white -fparchment = solidFillStyle (color 255 250 230) +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*3.14159/45) + 1) / 2 * (sin (x*3.14159/5)) + 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 blue + $ plot_lines_style ^= solidLine lineWidth (opaque blue) $ plot_lines_title ^="am" $ defaultPlotLines - sinusoid2 = plot_points_style ^= filledCircles 2 red + sinusoid2 = plot_points_style ^= filledCircles 2 (opaque red) $ plot_points_values ^= [ (x,(am x)) | x <- [0,7..400]] $ plot_points_title ^="am points" $ defaultPlotPoints @@ -109,35 +111,48 @@ . (laxis_override ^= (axisGridHide.axisTicksHide.axisLabelsHide)) ---------------------------------------------------------------------- -test2 :: [(Int,Int,Int,Double,Double)] -> OutputType -> Renderable () -test2 prices otype = toRenderable layout +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 - price1 = plot_lines_style ^= lineStyle blue + 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 green + 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 - bg = Color 0 0 0.25 - fg = Color 1 1 1 - fg1 = Color 0.0 0.0 0.15 + (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)] + $ layout1_plots ^= ([Left (toPlot price1), Right (toPlot price2)] ++ limits) $ layout1_grid_last ^= False $ setLayout1Foreground fg $ defaultLayout1 @@ -170,7 +185,7 @@ test4 xrev yrev otype = toRenderable layout where - points = plot_points_style ^= filledCircles 3 red + 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 @@ -216,8 +231,8 @@ f True = (1+frac*(1+b)) f False = (1-frac) - s1 = solidLine lineWidth green - s2 = solidLine lineWidth blue + s1 = solidLine lineWidth $ opaque green + s2 = solidLine lineWidth $ opaque blue lineWidth = chooseLineWidth otype @@ -246,7 +261,7 @@ $ plot_errbars_title ^="test" $ defaultPlotErrBars - points = plot_points_style ^= filledCircles 2 red + points = plot_points_style ^= filledCircles 2 (opaque red) $ plot_points_values ^= [(x,y) | (x,y,dx,dy) <- vals] $ plot_points_title ^= "test" $ defaultPlotPoints @@ -327,7 +342,46 @@ $ plot_bars_values ^= addIndexes [[20,45],[45,30],[30,20],[70,25]] $ 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 to display labels with all combinations -- of anchors @@ -338,8 +392,8 @@ s = "Labelling" hs = [HTA_Left, HTA_Centre, HTA_Right] vs = [VTA_Top, VTA_Centre, VTA_Bottom] - fwhite = solidFillStyle white - fblue = solidFillStyle (Color 0.8 0.8 1) + 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, @@ -356,10 +410,11 @@ allTests = [ ("test1", test1) , ("test1a", test1a) - , ("test2a", test2 prices) - , ("test2b", test2 (filterPrices (date 1 1 2005) (date 31 12 2005))) - , ("test2c", test2 (filterPrices (date 1 5 2005) (date 1 7 2005))) - , ("test2d", test2 (filterPrices (date 1 1 2006) (date 10 1 2006))) + , ("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) @@ -369,6 +424,7 @@ , ("test7", test7) , ("test8", test8) , ("test9", test9) + , ("test10", test10 (filterPrices (date 1 1 2005) (date 31 12 2005))) , ("misc1", misc1 0) , ("misc1a", misc1 45) ]