Chart 0.6 → 0.7
raw patch · 11 files changed
+596/−314 lines, 11 filesdep +mtldep ~base
Dependencies added: mtl
Dependency ranges changed: base
Files
- Chart.cabal +3/−3
- Graphics/Rendering/Chart.hs +10/−1
- Graphics/Rendering/Chart/Axis.hs +141/−85
- Graphics/Rendering/Chart/Gtk.hs +2/−1
- Graphics/Rendering/Chart/Layout.hs +7/−6
- Graphics/Rendering/Chart/Plot.hs +95/−32
- Graphics/Rendering/Chart/Renderable.hs +40/−34
- Graphics/Rendering/Chart/Simple.hs +25/−19
- Graphics/Rendering/Chart/Types.hs +167/−118
- tests/Prices.hs +61/−1
- tests/test.hs +45/−14
Chart.cabal view
@@ -1,5 +1,5 @@ Name: Chart-Version: 0.6+Version: 0.7 License: BSD3 License-file: LICENSE Copyright: Tim Docker, 2006@@ -19,10 +19,10 @@ library if flag(splitbase)- Build-depends: base >= 3, old-locale, old-time+ Build-depends: base >= 3, old-locale, old-time, mtl else Build-depends: base < 3- Build-depends: gtk >= 0.9.11, cairo >= 0.9.11+ Build-depends: gtk >= 0.9.11, cairo >= 0.9.11, mtl Exposed-modules: Graphics.Rendering.Chart,
Graphics/Rendering/Chart.hs view
@@ -27,16 +27,20 @@ Plot(..), ToPlot(..), PlotPoints(..),+ PlotErrBars(..), PlotLines(..), PlotFillBetween(..), HAxis(..), VAxis(..), Rect(..), Point(..),+ Color(..),+ ErrPoint(..), defaultAxisLineStyle, defaultPlotLineStyle, defaultAxis, defaultPlotPoints,+ defaultPlotErrBars, defaultPlotLines, defaultPlotFillBetween, defaultLayout1,@@ -54,8 +58,13 @@ linkedAxes', explicitAxis, autoScaledAxis,+ autoScaledAxis', autoScaledLogAxis,- monthsAxis,+ autoScaledLogAxis',+ timeAxis,+ autoTimeAxis,+ formatTime,+ days, months, years, renderableToPNGFile, renderableToPDFFile, renderableToPSFile,
Graphics/Rendering/Chart/Axis.hs view
@@ -8,7 +8,7 @@ import qualified Graphics.Rendering.Cairo as C import System.Time-import System.Locale+import System.Locale (defaultTimeLocale) import Control.Monad import Data.List @@ -70,13 +70,12 @@ render=renderAxis at } -minsizeAxis :: AxisT -> C.Render RectSize+minsizeAxis :: AxisT -> CRender RectSize minsizeAxis (AxisT at a) = do let labels = map snd (axis_labels a)- C.save- setFontStyle (axis_label_style a)- labelSizes <- mapM textSize labels- C.restore+ labelSizes <- preserveCState $ do+ setFontStyle (axis_label_style a)+ mapM textSize labels let (lw,lh) = foldl maxsz (0,0) labelSizes let ag = axis_label_gap a let tsize = maximum [ max 0 (-l) | (v,l) <- axis_ticks a ]@@ -93,13 +92,12 @@ -- | Calculate the amount by which the labels extend beyond -- the ends of the axis-axisOverhang :: AxisT -> C.Render (Double,Double)+axisOverhang :: AxisT -> CRender (Double,Double) axisOverhang (AxisT at a) = do let labels = map snd (sort (axis_labels a))- C.save- setFontStyle (axis_label_style a)- labelSizes <- mapM textSize labels- C.restore+ labelSizes <- preserveCState $ do+ setFontStyle (axis_label_style a)+ mapM textSize labels case labelSizes of [] -> return (0,0) ls -> let l1 = head ls@@ -113,24 +111,22 @@ E_Left -> ohangv E_Right -> ohangh -renderAxis :: AxisT -> Rect -> C.Render ()+renderAxis :: AxisT -> Rect -> CRender () renderAxis at@(AxisT et a) rect = do- C.save- setLineStyle (axis_line_style a)- strokeLines' True [Point sx sy,Point ex ey]- mapM_ drawTick (axis_ticks a)- C.restore- C.save- setFontStyle (axis_label_style a)- mapM_ drawLabel (axis_labels a)- C.restore+ preserveCState $ do+ setLineStyle (axis_line_style a)+ strokeLines [Point sx sy,Point ex ey]+ mapM_ drawTick (axis_ticks a)+ preserveCState $ do+ setFontStyle (axis_label_style a)+ mapM_ drawLabel (axis_labels a) where (sx,sy,ex,ey,tp,axisPoint) = axisMapping at rect drawTick (value,length) = let t1 = axisPoint value t2 = t1 `pvadd` (vscale length tp)- in strokeLines' True [t1,t2]+ in strokeLines [t1,t2] (hta,vta,lp) = let g = axis_label_gap a@@ -158,12 +154,11 @@ mapy :: Range -> Double -> Double -> Point mapy (yr0,yr1) x y = Point x (axis_viewport a (yr1,yr0) y) -renderAxisGrid :: Rect -> AxisT -> C.Render ()+renderAxisGrid :: Rect -> AxisT -> CRender () renderAxisGrid rect@(Rect p1 p2) at@(AxisT re a) = do- C.save- setLineStyle (axis_grid_style a)- mapM_ (drawGridLine re) (axis_grid a)- C.restore+ preserveCState $ do+ setLineStyle (axis_grid_style a)+ mapM_ (drawGridLine re) (axis_grid a) where (sx,sy,ex,ey,tp,axisPoint) = axisMapping at rect @@ -173,21 +168,10 @@ drawGridLine E_Right = hline vline v = let v' = p_x (axisPoint v)- in strokeLines' True [Point v' (p_y p1),Point v' (p_y p2)]+ in strokeLines [Point v' (p_y p1),Point v' (p_y p2)] hline v = let v' = p_y (axisPoint v)- in strokeLines' True [Point (p_x p1) v',Point (p_x p2) v']---- | Same as strokeLines, but with a flag that, when true will--- adjust each point to land on a whole number. This is useful for--- drawing known horizontal and vertical lines so that the occupy--- exactly --strokeLines' :: Bool -> [Point] -> C.Render ()-strokeLines' False ps = strokeLines ps-strokeLines' True ps = strokeLines (map adjfn ps)- where- adjfn (Point x y)= Point (fromIntegral (round x)) (fromIntegral (round y))+ in strokeLines [Point (p_x p1) v',Point (p_x p2) v'] ---------------------------------------------------------------------- @@ -216,7 +200,7 @@ major = steps 5 r minor = steps 50 (fromRational (minimum major),fromRational (maximum major)) -autoAxis transform (rlabelvs, rtickvs) a = Just axis+autoAxis labelf transform (rlabelvs, rtickvs) a = Just axis where axis = a { axis_viewport=newViewport,@@ -226,7 +210,7 @@ } newViewport = transform (min',max') newTicks = [ (v,2) | v <- tickvs ] ++ [ (v,5) | v <- labelvs ] - newLabels = [(v,show v) | v <- labelvs]+ newLabels = [(v,labelf v) | v <- labelvs] labelvs = map fromRational rlabelvs tickvs = map fromRational rtickvs min' = minimum labelvs@@ -241,8 +225,8 @@ -- 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 :: Axis -> AxisFn-autoScaledAxis a ps0 = autoAxis vmap (linearTicks (range ps)) a+autoScaledAxis' :: (Double->String) -> Axis -> AxisFn+autoScaledAxis' labelf a ps0 = autoAxis labelf vmap (linearTicks (range ps)) a where ps = filter isValidNumber ps0 (min,max) = (minimum ps,maximum ps)@@ -250,6 +234,17 @@ range _ | min == max = (min-0.5,min+0.5) | otherwise = (min,max) +-- | Generate a linear axis automatically.+-- Same as autoScaledAxis', but with labels generated with "showD"+-- (showD is show for doubles, but with any trailing ".0" removed)+autoScaledAxis :: Axis -> AxisFn+autoScaledAxis = autoScaledAxis' showD++showD x = case reverse $ show x of+ '0':'.':r -> reverse r+ _ -> show x+ + log10 :: (Floating a) => a -> a log10 = logBase 10 @@ -310,8 +305,8 @@ -- 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 :: Axis -> AxisFn-autoScaledLogAxis a ps0 = autoAxis lmap (logTicks (range ps)) a+autoScaledLogAxis' :: (Double->String) -> Axis -> AxisFn+autoScaledLogAxis' labelf a ps0 = autoAxis labelf lmap (logTicks (range ps)) a where ps = filter isValidNumber ps0 (min, max) = (minimum ps,maximum ps)@@ -319,6 +314,12 @@ range _ | min == max = (min/3,max*3) | otherwise = (min,max) +-- | Generate a log axis automatically.+-- Same as autoScaledLogAxis', but with labels generated with "showD"+-- (showD is show for doubles, but with any trailing ".0" removed)+autoScaledLogAxis :: Axis -> AxisFn+autoScaledLogAxis = autoScaledLogAxis' showD+ -- | Show independent axes on each side of the layout independentAxes :: AxisFn -> AxisFn -> AxesFn independentAxes af1 af2 pts1 pts2 = (af1 pts1, af2 pts2)@@ -339,8 +340,8 @@ ---------------------------------------------------------------------- -defaultAxisLineStyle = solidLine 1 0 0 0-defaultGridLineStyle = dashedLine 1 [5,5] 0.8 0.8 0.8+defaultAxisLineStyle = solidLine 1 black+defaultGridLineStyle = dashedLine 1 [5,5] grey8 defaultAxis = Axis { axis_viewport = vmap (0,1),@@ -358,7 +359,7 @@ ---------------------------------------------------------------------- refClockTime = toClockTime CalendarTime {- ctYear=1970,+ ctYear=2000, ctMonth=toEnum 0, ctDay=1, ctHour=0,@@ -366,7 +367,7 @@ ctSec=0, ctPicosec=0, ctTZ=0,- ctWDay=Monday,+ ctWDay=Saturday, ctYDay=0, ctTZName="", ctIsDST=False@@ -390,48 +391,103 @@ tdPicosec = 0 } --- | An axis that plots dates, with ticks and labels corresponding to--- calendar months. The values to be plotted against this axis can--- be created with 'doubleFromClockTime'-monthsAxis :: Axis -> AxisFn-monthsAxis a pts = Just axis+-- | 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.+type TimeSeq = ClockTime-> ([ClockTime],[ClockTime])++coverTS tseq min max = min' ++ enumerateTS tseq min max ++ max' where+ 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+ where+ (ts1,ts2) = tseq min++elemTS t tseq = case tseq t of+ (_,(t0:_)) | t == t0 -> True+ _ -> False++-- | How to display a time+type TimeLabelFn = ClockTime -> String++-- | Use an strftime() formatted string to display a time+formatTime :: String -> TimeLabelFn+formatTime s t = formatCalendarTime defaultTimeLocale s (toUTCTime t)++-- | 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 clocktimes for labels.+-- The values to be plotted against this axis can be created with 'doubleFromClockTime'+timeAxis :: TimeSeq -> TimeSeq -> TimeLabelFn -> Axis -> AxisFn+timeAxis tseq lseq labelf a pts = Just axis+ where axis = a {- axis_viewport=newViewport,- axis_ticks=newTicks,- axis_labels=newLabels,- axis_grid=newGrid+ axis_viewport=vmap (dfct min', dfct max'),+ axis_ticks=[ (dfct t,2) | t <- times] ++ [ (t,5) | t <- ltimes', visible t],+ axis_labels=[ (t,l) | (t,l) <- labels, visible t],+ axis_grid=[ t | t <- ltimes', visible t] } (min,max) = case pts of- [] -> (refClockTime, nextMonthStart refClockTime)+ [] -> (refClockTime,refClockTime) ps -> let min = minimum ps max = maximum ps in- (clockTimeFromDouble min,clockTimeFromDouble max)- min' = thisMonthStart min- max' = nextMonthStart max+ (ctfd min,ctfd max) - newViewport = vmap (doubleFromClockTime min', doubleFromClockTime max')- months = takeWhile (<=max') (iterate nextMonthStart min')- newTicks = [ (doubleFromClockTime ct,5) | ct <- months ]- newLabels = [ (mlabelv m1 m2, mlabelt m1) | (m1,m2) <- zip months (tail months) ]- newGrid = case axis_grid a of - [] -> []- _ -> [v | (v,_) <- newTicks]+ times = coverTS tseq min max+ ltimes = coverTS lseq min max+ ltimes' = map dfct ltimes+ min' = minimum times+ max' = maximum times+ visible t = dfct min' <= t && t <= dfct max'+ labels = [ ((dfct m2 + dfct m1) / 2, labelf m1) | (m1,m2) <- zip ltimes (tail ltimes) ]+ dfct = doubleFromClockTime+ ctfd = clockTimeFromDouble - mlabelt m = formatCalendarTime defaultTimeLocale "%b-%y" (toUTCTime m)- mlabelv m1 m2 = (doubleFromClockTime m2 + doubleFromClockTime m1) / 2+-- | A 'TimeSeq' for calendar days+days :: TimeSeq+days t = (iterate rev t1, tail (iterate fwd t1))+ where t0 = (toClockTime.zeroTime.toUTCTime) t+ t1 = if t0 < t then t0 else (rev t0)+ rev = addToClockTime noTimeDiff{tdDay=(-1)}+ fwd = addToClockTime noTimeDiff{tdDay=1} -thisMonthStart ct = - let calt = (toUTCTime ct) {- ctDay=1,- ctHour=0,- ctMin=0,- ctSec=0,- ctPicosec=0- } in- toClockTime calt+-- | A 'TimeSeq' for calendar months+months :: TimeSeq+months t = (iterate rev t1, tail (iterate fwd t1))+ where t0 = (toClockTime.(\t -> t{ctDay=1}).zeroTime.toUTCTime) t+ t1 = if t0 < t then t0 else (rev t0)+ rev = addToClockTime noTimeDiff{tdMonth=(-1)}+ fwd = addToClockTime noTimeDiff{tdMonth=1} -nextMonthStart ct =- let month1 = noTimeDiff{tdMonth=1} in- addToClockTime month1 (thisMonthStart ct)- +-- | A 'TimeSeq' for calendar years+years :: TimeSeq+years t = (iterate rev t1, tail (iterate fwd t1))+ where t0 = (toClockTime.(\t -> t{ctMonth=January,ctDay=1}).zeroTime.toUTCTime) t+ t1 = if t0 < t then t0 else (rev t0)+ rev = addToClockTime noTimeDiff{tdMonth=(-12)}+ fwd = addToClockTime noTimeDiff{tdMonth=12}++zeroTime t = t{ctHour=0,ctMin=0,ctSec=0,ctPicosec=0}++-- | 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 'doubleFromClockTime'+autoTimeAxis :: Axis -> AxisFn+autoTimeAxis a pts =+ if tdiff < (normalizeTimeDiff noTimeDiff{tdDay=15})+ then timeAxis days days (formatTime "%d-%b") a pts+ else if tdiff < (normalizeTimeDiff noTimeDiff{tdMonth=3})+ then timeAxis days months (formatTime "%b-%y") a pts+ else if tdiff < (normalizeTimeDiff noTimeDiff{tdMonth=15})+ then timeAxis months months (formatTime "%b-%y") a pts+ else if tdiff < (normalizeTimeDiff noTimeDiff{tdMonth=60})+ then timeAxis months years (formatTime "%Y") a pts+ else timeAxis years years (formatTime "%Y") a pts+ where+ tdiff = normalizeTimeDiff (t1 `diffClockTimes` t0)+ t1 = clockTimeFromDouble (maximum pts)+ t0 = clockTimeFromDouble (minimum pts)+
Graphics/Rendering/Chart/Gtk.hs view
@@ -12,6 +12,7 @@ import qualified Graphics.Rendering.Cairo as C import Graphics.Rendering.Chart import Graphics.Rendering.Chart.Renderable+import Graphics.Rendering.Chart.Types renderableToWindow :: Renderable -> Int -> Int -> IO () renderableToWindow chart windowWidth windowHeight = do@@ -35,7 +36,7 @@ win <- G.widgetGetDrawWindow canvas (width, height) <- G.widgetGetSize canvas let rect = Rect (Point 0 0) (Point (fromIntegral width) (fromIntegral height))- G.renderWithDrawable win (rfn rect)+ G.renderWithDrawable win $ runCRender (rfn rect) bitmapEnv return True where rfn rect = do
Graphics/Rendering/Chart/Layout.hs view
@@ -14,7 +14,10 @@ import Graphics.Rendering.Chart.Renderable import Control.Monad +-- | The side of an horizontal axis data HAxis = HA_Top | HA_Bottom deriving (Eq)++-- | The side of a vertical axis data VAxis = VA_Left | VA_Right deriving (Eq) -- | A Layout1 value is a single plot area, with optional: axes on@@ -84,12 +87,10 @@ er = (0,emptyRenderable) -renderPlots l r@(Rect p1 p2) = do+renderPlots l r@(Rect p1 p2) = preserveCState $ do -- render the plots- C.save setClipRegion p1 p2 mapM_ (rPlot r) (layout1_plots l)- C.restore -- render the axes grids maybeM () (renderAxisGrid r) tAxis@@ -100,7 +101,7 @@ where (bAxis,lAxis,tAxis,rAxis) = getAxes l - rPlot :: Rect -> (String,HAxis,VAxis,Plot) -> C.Render ()+ rPlot :: Rect -> (String,HAxis,VAxis,Plot) -> CRender () rPlot rect (_,ha,va,p) = let mxaxis = case ha of HA_Bottom -> bAxis HA_Top -> tAxis@@ -108,7 +109,7 @@ VA_Right -> rAxis in rPlot1 rect mxaxis myaxis p - rPlot1 :: Rect -> Maybe AxisT -> Maybe AxisT -> Plot -> C.Render ()+ rPlot1 :: Rect -> Maybe AxisT -> Maybe AxisT -> Plot -> CRender () rPlot1 (Rect dc1 dc2) (Just (AxisT _ xaxis)) (Just (AxisT _ yaxis)) p = let xrange = (p_x dc1, p_x dc2) yrange = (p_y dc2, p_y dc1)@@ -145,7 +146,7 @@ defaultLayout1 = Layout1 {- layout1_background = solidFillStyle 1 1 1,+ layout1_background = solidFillStyle white, layout1_title = "", layout1_title_style = fontStyle "sans" 15 C.FontSlantNormal C.FontWeightBold, layout1_horizontal_axes = linkedAxes (autoScaledAxis defaultAxis),
Graphics/Rendering/Chart/Plot.hs view
@@ -8,11 +8,14 @@ Plot(..), ToPlot(..), PlotPoints(..),+ PlotErrBars(..), PlotLines(..), PlotFillBetween(..),+ ErrPoint(..), defaultPlotLineStyle, defaultPlotPoints,+ defaultPlotErrBars, defaultPlotFillBetween, defaultPlotLines @@ -27,11 +30,11 @@ -- | Given the mapping between model space coordinates and device coordinates, -- render this plot into a chart.- plot_render :: PointMapFn -> C.Render (),+ plot_render :: PointMapFn -> CRender (), -- | Render a small sample of this plot into the given rectangle. -- This is for used to generate a the legend a chart.- plot_render_legend :: Rect -> C.Render (),+ plot_render_legend :: Rect -> CRender (), -- | All of the model space coordinates to be plotted. These are -- used to autoscale the axes where necessary.@@ -58,29 +61,25 @@ plot_all_points = concat (plot_lines_values p) } -renderPlotLines :: PlotLines -> PointMapFn -> C.Render ()-renderPlotLines p pmap = do- C.save+renderPlotLines :: PlotLines -> PointMapFn -> CRender ()+renderPlotLines p pmap = preserveCState $ do setLineStyle (plot_lines_style p) mapM_ drawLines (plot_lines_values p)- C.restore where drawLines (p:ps) = do moveTo (pmap p) mapM_ (\p -> lineTo (pmap p)) ps- C.stroke+ c $ C.stroke -renderPlotLegendLines :: PlotLines -> Rect -> C.Render ()-renderPlotLegendLines p r@(Rect p1 p2) = do- C.save+renderPlotLegendLines :: PlotLines -> 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.stroke- C.restore+ c $ C.stroke -defaultPlotLineStyle = solidLine 1 0 0 1+defaultPlotLineStyle = solidLine 1 blue defaultPlotLines = PlotLines { plot_lines_style = defaultPlotLineStyle,@@ -102,22 +101,18 @@ plot_all_points = plot_points_values p } -renderPlotPoints :: PlotPoints -> PointMapFn -> C.Render ()-renderPlotPoints p pmap = do- C.save+renderPlotPoints :: PlotPoints -> PointMapFn -> CRender ()+renderPlotPoints p pmap = preserveCState $ do mapM_ (drawPoint.pmap) (plot_points_values p)- C.restore where (CairoPointStyle drawPoint) = (plot_points_style p) -renderPlotLegendPoints :: PlotPoints -> Rect -> C.Render ()-renderPlotLegendPoints p r@(Rect p1 p2) = do- C.save+renderPlotLegendPoints :: PlotPoints -> Rect -> CRender ()+renderPlotLegendPoints p r@(Rect p1 p2) = preserveCState $ do drawPoint (Point (p_x p1) ((p_y p1 + p_y p2)/2)) drawPoint (Point ((p_x p1 + p_x p2)/2) ((p_y p1 + p_y p2)/2)) drawPoint (Point (p_x p2) ((p_y p1 + p_y p2)/2))- C.restore where (CairoPointStyle drawPoint) = (plot_points_style p)@@ -142,30 +137,26 @@ plot_all_points = plotAllPointsFillBetween p } -renderPlotFillBetween :: PlotFillBetween -> PointMapFn -> C.Render ()+renderPlotFillBetween :: PlotFillBetween -> PointMapFn -> CRender () renderPlotFillBetween p pmap = renderPlotFillBetween' p (plot_fillbetween_values p) pmap renderPlotFillBetween' p [] _ = return ()-renderPlotFillBetween' p vs pmap = do- C.save+renderPlotFillBetween' p vs pmap = preserveCState $ do setFillStyle (plot_fillbetween_style p) moveTo p0 mapM_ lineTo p1s mapM_ lineTo (reverse p2s) lineTo p0- C.fill- C.restore+ c $ C.fill where (p0:p1s) = map pmap [ Point x y1 | (x,(y1,y2)) <- vs ] p2s = map pmap [ Point x y2 | (x,(y1,y2)) <- vs ] -renderPlotLegendFill :: PlotFillBetween -> Rect -> C.Render ()-renderPlotLegendFill p r = do- C.save+renderPlotLegendFill :: PlotFillBetween -> Rect -> CRender ()+renderPlotLegendFill p r = preserveCState $ do setFillStyle (plot_fillbetween_style p) rectPath r- C.fill- C.restore+ c $ C.fill plotAllPointsFillBetween :: PlotFillBetween -> [Point] plotAllPointsFillBetween p = concat [ [Point x y1, Point x y2]@@ -173,6 +164,78 @@ defaultPlotFillBetween = PlotFillBetween {- plot_fillbetween_style=solidFillStyle 0.5 0.5 1.0,+ plot_fillbetween_style=solidFillStyle (Color 0.5 0.5 1.0), plot_fillbetween_values=[]+}++----------------------------------------------------------------------++-- | Value for holding a point with associated error bounds for+-- each axis.+data ErrPoint = ErrPoint {+ ep_x :: Double,+ ep_y :: Double,+ ep_dx :: Double,+ ep_dy :: Double+} deriving Show++-- | Value defining a series of error intervals, and a style in+-- which to render them+data PlotErrBars = PlotErrBars {+ plot_errbars_line_style :: CairoLineStyle,+ plot_errbars_tick_length :: Double,+ plot_errbars_overhang :: Double,+ plot_errbars_values :: [ErrPoint]+}++instance ToPlot PlotErrBars where+ toPlot p = Plot {+ plot_render = renderPlotErrBars p,+ plot_render_legend = renderPlotLegendErrBars p,+ plot_all_points = map (\(ErrPoint x y _ _) -> Point x y ) $ plot_errbars_values p+ }++renderPlotErrBars :: PlotErrBars -> PointMapFn -> CRender ()+renderPlotErrBars p pmap = preserveCState $ do+ mapM_ (drawErrBar.epmap) (plot_errbars_values p)+ where+ epmap (ErrPoint x y dx dy) = ErrPoint x' y' (abs $ x''-x') (abs $ y''-y')+ where (Point x' y') = pmap (Point x y)+ (Point x'' y'') = pmap (Point (x+dx) (y+dy))+ drawErrBar = drawErrBar0 p++drawErrBar0 ps (ErrPoint x y dx dy) = do+ let tl = plot_errbars_tick_length ps+ let oh = plot_errbars_overhang ps+ setLineStyle (plot_errbars_line_style ps)+ c $ C.newPath+ c $ C.moveTo (x-dx-oh) y+ c $ C.lineTo (x+dx+oh) y+ c $ C.moveTo x (y-dy-oh)+ c $ C.lineTo x (y+dy+oh)+ c $ C.moveTo (x-dx) (y-tl)+ c $ C.lineTo (x-dx) (y+tl)+ c $ C.moveTo (x-tl) (y-dy)+ c $ C.lineTo (x+tl) (y-dy)+ c $ C.moveTo (x+dx) (y-tl)+ c $ C.lineTo (x+dx) (y+tl)+ c $ C.moveTo (x-tl) (y+dy)+ c $ C.lineTo (x+tl) (y+dy)+ c $ C.stroke++renderPlotLegendErrBars :: PlotErrBars -> Rect -> CRender ()+renderPlotLegendErrBars p r@(Rect p1 p2) = preserveCState $ do+ drawErrBar (ErrPoint (p_x p1) ((p_y p1 + p_y p2)/2) dx dx ) + drawErrBar (ErrPoint ((p_x p1 + p_x p2)/2) ((p_y p1 + p_y p2)/2) dx dx)+ drawErrBar (ErrPoint (p_x p2) ((p_y p1 + p_y p2)/2) dx dx)++ where+ drawErrBar = drawErrBar0 p+ dx = min ((p_x p2 - p_x p1)/6) ((p_y p2 - p_y p1)/2)++defaultPlotErrBars = PlotErrBars {+ plot_errbars_line_style = solidLine 1 blue,+ plot_errbars_tick_length = 3,+ plot_errbars_overhang = 0,+ plot_errbars_values = [] }
Graphics/Rendering/Chart/Renderable.hs view
@@ -18,10 +18,10 @@ data Renderable = Renderable { -- | a Cairo action to calculate a minimum size,- minsize :: C.Render RectSize,+ minsize :: CRender RectSize, -- | a Cairo action for drawing it within a specified rectangle.- render :: Rect -> C.Render ()+ render :: Rect -> CRender () } -- | A type class abtracting the conversion of a value to a@@ -51,11 +51,10 @@ fillBackground fs r = Renderable { minsize = minsize r, render = rf } where rf rect@(Rect p1 p2) = do- C.save- setClipRegion p1 p2- setFillStyle fs- C.paint- C.restore+ preserveCState $ do+ setClipRegion p1 p2+ setFillStyle fs+ c $ C.paint render r rect vertical, horizontal :: [(Double,Renderable)] -> Renderable @@ -102,10 +101,12 @@ total = sum ws extras = [ extra * v / total | v <- ws ] +-- | Output the given renderable to a PNG file of the specifed size+-- (in pixels), to the specified file. renderableToPNGFile :: Renderable -> Int -> Int -> FilePath -> IO () renderableToPNGFile chart width height path = C.withImageSurface C.FormatARGB32 width height $ \result -> do- C.renderWith result $ rfn+ C.renderWith result $ runCRender rfn bitmapEnv C.surfaceWriteToPNG result path where rfn = do@@ -114,37 +115,47 @@ rect = Rect (Point 0 0) (Point (fromIntegral width) (fromIntegral height)) +-- | Output the given renderable to a PDF file of the specifed size+-- (in points), to the specified file. renderableToPDFFile :: Renderable -> Int -> Int -> FilePath -> IO () renderableToPDFFile chart width height path = C.withPDFSurface path (fromIntegral width) (fromIntegral height) $ \result -> do- C.renderWith result $ rfn+ C.renderWith result $ runCRender rfn vectorEnv C.surfaceFinish result where rfn = do render chart rect- C.showPage+ c $ C.showPage rect = Rect (Point 0 0) (Point (fromIntegral width) (fromIntegral height)) +-- | Output the given renderable to a postscript file of the specifed size+-- (in points), to the specified file. renderableToPSFile :: Renderable -> Int -> Int -> FilePath -> IO () renderableToPSFile chart width height path = C.withPSSurface path (fromIntegral width) (fromIntegral height) $ \result -> do- C.renderWith result $ rfn+ C.renderWith result $ runCRender rfn vectorEnv C.surfaceFinish result where rfn = do render chart rect- C.showPage+ c $ C.showPage rect = Rect (Point 0 0) (Point (fromIntegral width) (fromIntegral height)) -alignPixels :: C.Render ()+bitmapEnv = CEnv adjfn+ where+ adjfn (Point x y)= Point (fromIntegral (round x)) (fromIntegral (round y))++vectorEnv = CEnv id++alignPixels :: CRender () alignPixels = do -- move to centre of pixels so that stroke width of 1 is -- exactly one pixel - C.translate 0.5 0.5+ c $ C.translate 0.5 0.5 -embedRenderable :: C.Render Renderable -> Renderable+embedRenderable :: CRender Renderable -> Renderable embedRenderable ca = Renderable { minsize = do { a <- ca; minsize a }, render = \ r -> do { a <- ca; render a r }@@ -168,7 +179,7 @@ render=renderLegend l } -minsizeLegend :: Legend -> C.Render RectSize+minsizeLegend :: Legend -> CRender RectSize minsizeLegend (Legend _ ls plots) = do let labels = nub $ map fst plots lsizes <- mapM textSize labels@@ -180,14 +191,14 @@ let w = sum [w + lgap | (w,h) <- lsizes] + pw * (n+1) + lm * (n-1) return (w,h) -renderLegend :: Legend -> Rect -> C.Render ()+renderLegend :: Legend -> Rect -> CRender () renderLegend (Legend _ ls plots) (Rect rp1 rp2) = do foldM_ rf rp1 $ join_nub plots where lm = legend_margin ls lps = legend_plot_size ls - rf :: Point -> (String,[Plot]) -> C.Render Point+ rf :: Point -> (String,[Plot]) -> CRender Point rf p1 (label,theseplots) = do (w,h) <- textSize label lgap <- legendSpacer@@ -221,22 +232,17 @@ rlabel :: CairoFontStyle -> HTextAnchor -> VTextAnchor -> Double -> String -> Renderable rlabel fs hta vta rot s = Renderable { minsize = mf, render = rf } where- mf = do- C.save+ mf = preserveCState $ do setFontStyle fs (w,h) <- textSize s- C.restore- let sz' = (w*acr+h*asr,w*asr+h*acr)- return sz'- rf (Rect p1 p2) = do- C.save+ return (w*acr+h*asr,w*asr+h*acr)+ rf (Rect p1 p2) = preserveCState $ do setFontStyle fs sz@(w,h) <- textSize s- C.translate (xadj sz hta (p_x p1) (p_x p2)) (yadj sz vta (p_y p1) (p_y p2))- C.rotate rot'- C.moveTo (-w/2) (h/2)- C.showText s- C.restore+ c $ C.translate (xadj sz hta (p_x p1) (p_x p2)) (yadj sz vta (p_y p1) (p_y p2))+ c $ C.rotate rot'+ c $ C.moveTo (-w/2) (h/2)+ c $ C.showText s 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@@ -252,13 +258,13 @@ -- of anchors labelTest rot = renderableToPNGFile r 800 800 "labels.png" where- r = fillBackground white $ grid [1,1,1] [1,1,1] ls- ls = [ [(0,addMargins (20,20,20,20) $ fillBackground blue $ crossHairs $ rlabel fs h v rot s) | h <- hs] | v <- vs ]+ r = fillBackground fwhite $ grid [1,1,1] [1,1,1] ls+ ls = [ [(0,addMargins (20,20,20,20) $ fillBackground fblue $ crossHairs $ rlabel fs h v rot s) | h <- hs] | v <- vs ] s = "Labels" hs = [HTA_Left, HTA_Centre, HTA_Right] vs = [VTA_Top, VTA_Centre, VTA_Bottom]- white = solidFillStyle 1 1 1- blue = solidFillStyle 0.8 0.8 1+ fwhite = solidFillStyle white+ fblue = solidFillStyle (Color 0.8 0.8 1) fs = fontStyle "sans" 30 C.FontSlantNormal C.FontWeightBold crossHairs r =Renderable { minsize = minsize r,
Graphics/Rendering/Chart/Simple.hs view
@@ -39,14 +39,16 @@ import Graphics.Rendering.Chart import Graphics.Rendering.Chart.Gtk -styleColor :: (Double -> Double -> Double -> a) -> Int -> a-styleColor f ind = case colorSequence !! ind of (r,g,b) -> f r g b- where colorSequence = cycle [(0,0,1),(1,0,0),(0,1,0),(1,1,0),(0,1,1),(1,0,1),(0,0,0)]+styleColor :: Int -> Color+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] styleSymbol :: Int -> PlotKind styleSymbol ind = symbolSequence !! ind- where symbolSequence = cycle [ Ex, HollowCircle, Triangle, DownTriangle, Square,- Diamond, Plus, Star, FilledCircle ]+ where symbolSequence = cycle [ Ex, HollowCircle, Square, Diamond,+ Triangle, DownTriangle, Plus, Star, FilledCircle ] iplot :: [InternalPlot] -> Layout1 iplot foobar = defaultLayout1 {@@ -64,44 +66,44 @@ plots = case catMaybes $ map plotas yks of [] -> [toPlot $ defaultPlotLines { plot_lines_values = [vs],- plot_lines_style = solidLine 1 `styleColor` ind }]+ plot_lines_style = solidLine 1 (styleColor ind) }] xs -> xs plotas Solid = Just $ toPlot $ defaultPlotLines { plot_lines_values = [vs],- plot_lines_style = solidLine 1 `styleColor` ind }+ plot_lines_style = solidLine 1 (styleColor ind) } plotas Dashed = Just $ toPlot $ defaultPlotLines { plot_lines_values = [vs],- plot_lines_style = dashedLine 1 [10,10] `styleColor` ind }+ plot_lines_style = dashedLine 1 [10,10] (styleColor ind) } plotas Dotted = Just $ toPlot $ defaultPlotLines { plot_lines_values = [vs],- plot_lines_style = dashedLine 1 [1,11] `styleColor` ind }+ plot_lines_style = dashedLine 1 [1,11] (styleColor ind) } plotas FilledCircle = Just $ toPlot $ defaultPlotPoints { plot_points_values = vs,- plot_points_style=filledCircles 4 `styleColor` ind }+ plot_points_style=filledCircles 4 (styleColor ind) } plotas HollowCircle = Just $ toPlot $ defaultPlotPoints { plot_points_values = vs,- plot_points_style=hollowCircles 5 1 `styleColor` ind }+ plot_points_style=hollowCircles 5 1 (styleColor ind) } plotas Triangle = Just $ toPlot $ defaultPlotPoints { plot_points_values = vs,- plot_points_style=hollowPolygon 7 1 3 False `styleColor` ind }+ plot_points_style=hollowPolygon 7 1 3 False (styleColor ind) } plotas DownTriangle = Just $ toPlot $ defaultPlotPoints { plot_points_values = vs,- plot_points_style=hollowPolygon 7 1 3 True `styleColor` ind }+ plot_points_style=hollowPolygon 7 1 3 True (styleColor ind) } plotas Square = Just $ toPlot $ defaultPlotPoints { plot_points_values = vs,- plot_points_style=hollowPolygon 7 1 4 False `styleColor` ind }+ plot_points_style=hollowPolygon 7 1 4 False (styleColor ind) } plotas Diamond = Just $ toPlot $ defaultPlotPoints { plot_points_values = vs,- plot_points_style=hollowPolygon 7 1 4 True `styleColor` ind }+ plot_points_style=hollowPolygon 7 1 4 True (styleColor ind) } plotas Plus = Just $ toPlot $ defaultPlotPoints { plot_points_values = vs,- plot_points_style=plusses 7 1 `styleColor` ind }+ plot_points_style=plusses 7 1 (styleColor ind) } plotas Ex = Just $ toPlot $ defaultPlotPoints { plot_points_values = vs,- plot_points_style=exes 7 1 `styleColor` ind }+ plot_points_style=exes 7 1 (styleColor ind) } plotas Star = Just $ toPlot $ defaultPlotPoints { plot_points_values = vs,- plot_points_style=stars 7 1 `styleColor` ind }+ plot_points_style=stars 7 1 (styleColor ind) } plotas Symbols = plotas (styleSymbol ind) plotas _ = Nothing isOkay (_,n) = not (isNaN n || isInfinite n)@@ -233,7 +235,11 @@ toUPlot = toUPlot' instance (Real a, Real b, Fractional a, Fractional b) => PlotArg (a -> b) where- toUPlot f = [UFunction (realToFrac . f . realToFrac)]+ toUPlot x = [UFunction (realToFrac . x . realToFrac)]++instance (Real a, Real b, Fractional a, Fractional b) => IsPlot (a -> b) where+ toUPlot' = reverse . concatMap f+ where f x = [UFunction (realToFrac . x . realToFrac)] instance PlotArg UPlot where toUPlot = (:[])
Graphics/Rendering/Chart/Types.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-} ----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Chart.Types@@ -7,6 +8,7 @@ module Graphics.Rendering.Chart.Types where import qualified Graphics.Rendering.Cairo as C+import Control.Monad.Reader -- | A point in two dimensions data Point = Point {@@ -19,6 +21,12 @@ v_y :: Double } deriving Show +data Color = Color {+ c_r :: Double,+ c_g :: Double,+ c_b :: Double+}+ -- | scale a vector by a constant vscale :: Double -> Vector -> Vector vscale c (Vector x y) = (Vector (x*c) (y*c))@@ -51,60 +59,103 @@ -- | A linear mapping of points in one range to another vmap :: Range -> Range -> Double -> Double vmap (v1,v2) (v3,v4) v = v3 + (v-v1) * (v4-v3) / (v2-v1)++----------------------------------------------------------------------++-- | The environment present in the CRender Monad.+data CEnv = CEnv {+ -- | A transform applied immediately prior to values+ -- 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.+ cenv_point_alignfn :: Point -> Point+}++newtype CRender a = DR (ReaderT CEnv C.Render a)+ deriving (Functor, Monad, MonadReader CEnv)++runCRender :: CRender a -> CEnv -> C.Render a+runCRender (DR m) e = runReaderT m e++c :: C.Render a -> CRender a+c = DR . lift +----------------------------------------------------------------------+ -- | 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.-newtype CairoPointStyle = CairoPointStyle (Point -> C.Render ())+newtype CairoPointStyle = CairoPointStyle (Point -> CRender ()) -- | Abstract data type for the style of a line -- -- The contained Cairo action sets the required line -- in the Cairo rendering state.-newtype CairoLineStyle = CairoLineStyle (C.Render ())+newtype CairoLineStyle = CairoLineStyle (CRender ()) -- | Abstract data type for a fill style -- -- The contained Cairo action sets the required fill -- style in the Cairo rendering state.-newtype CairoFillStyle = CairoFillStyle (C.Render ())+newtype CairoFillStyle = CairoFillStyle (CRender ()) -- | Abstract data type for a font. -- -- The contained Cairo action sets the required font -- in the Cairo rendering state.-newtype CairoFontStyle = CairoFontStyle (C.Render ())+newtype CairoFontStyle = CairoFontStyle (CRender ()) 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+ ---------------------------------------------------------------------- -- Assorted helper functions in Cairo Usage -moveTo, lineTo :: Point -> C.Render ()-moveTo (Point px py) = C.moveTo px py-lineTo (Point px py) = C.lineTo px py+moveTo, lineTo :: Point -> CRender ()+moveTo p = do+ p' <- alignp p+ c $ C.moveTo (p_x p') (p_y p') +alignp :: Point -> CRender Point+alignp p = do + alignfn <- fmap cenv_point_alignfn ask+ return (alignfn p)++lineTo p = do+ p' <- alignp p+ c $ C.lineTo (p_x p') (p_y p')+ setClipRegion p2 p3 = do - C.moveTo (p_x p2) (p_y p2)- C.lineTo (p_x p2) (p_y p3)- C.lineTo (p_x p3) (p_y p3)- C.lineTo (p_x p3) (p_y p2)- C.lineTo (p_x p2) (p_y p2)- C.clip+ c $ C.moveTo (p_x p2) (p_y p2)+ c $ C.lineTo (p_x p2) (p_y p3)+ c $ C.lineTo (p_x p3) (p_y p3)+ c $ C.lineTo (p_x p3) (p_y p2)+ 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.newPath+ c $ C.newPath moveTo p1 mapM_ lineTo ps- C.stroke+ c $ C.stroke strokeLines _ = return () -- | make a path from a rectable-rectPath :: Rect -> C.Render ()-rectPath (Rect (Point x1 y1) (Point x2 y2)) = do+rectPath :: Rect -> CRender ()+rectPath (Rect (Point x1 y1) (Point x2 y2)) = c $ do C.newPath C.moveTo x1 y1 C.lineTo x2 y1@@ -116,8 +167,10 @@ setLineStyle (CairoLineStyle s) = s setFillStyle (CairoFillStyle s) = s -textSize :: String -> C.Render RectSize-textSize s = do+setSourceColor (Color r g b) = C.setSourceRGB r g b++textSize :: String -> CRender RectSize+textSize s = c $ do te <- C.textExtents s fe <- C.fontExtents return (C.textExtentsWidth te, C.fontExtentsHeight fe)@@ -127,8 +180,8 @@ -- | Function to draw a textual label anchored by one of it's corners -- or edges.-drawText :: HTextAnchor -> VTextAnchor -> Point -> String -> C.Render ()-drawText hta vta (Point x y) s = do+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)@@ -144,52 +197,58 @@ 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)+preserveCState :: CRender a -> CRender a+preserveCState a = do + c $ C.save+ v <- a+ c $ C.restore+ return v+ ---------------------------------------------------------------------- filledCircles :: Double -- ^ radius of circle- -> Double -- ^ red component of colour- -> Double -- ^ green component of colour- -> Double -- ^ blue component of colour+ -> Color -- ^ colour -> CairoPointStyle-filledCircles radius r g b = CairoPointStyle rf+filledCircles radius cl = CairoPointStyle rf where- rf (Point x y) = do- C.setSourceRGB r g b- C.newPath- C.arc x y radius 0 360- C.fill+ rf p = do+ (Point x y) <- alignp p+ c $ setSourceColor cl+ c $ C.newPath+ c $ C.arc x y radius 0 (2*pi)+ c $ C.fill hollowCircles :: Double -- ^ radius of circle -> Double -- ^ thickness of line- -> Double -- ^ red component of colour- -> Double -- ^ green component of colour- -> Double -- ^ blue component of colour+ -> Color -> CairoPointStyle-hollowCircles radius w r g b = CairoPointStyle rf+hollowCircles radius w cl = CairoPointStyle rf where- rf (Point x y) = do- C.setLineWidth w- C.setSourceRGB r g b- C.newPath- C.arc x y radius 0 360- C.stroke+ rf p = do+ (Point x y) <- alignp p+ c $ C.setLineWidth w+ c $ setSourceColor cl+ c $ C.newPath+ c $ C.arc x y radius 0 (2*pi)+ c $ C.stroke hollowPolygon :: Double -- ^ radius of circle -> Double -- ^ thickness of line -> Int -- ^ Number of vertices -> Bool -- ^ Is right-side-up?- -> Double -- ^ red component of colour- -> Double -- ^ green component of colour- -> Double -- ^ blue component of colour+ -> Color -> CairoPointStyle-hollowPolygon radius w sides isrot r g b = CairoPointStyle rf- where rf (Point x y) =- do C.setLineWidth w- C.setSourceRGB r g b- C.newPath+hollowPolygon radius w sides isrot cl = CairoPointStyle rf+ where rf p =+ do (Point x y ) <- alignp p+ 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@@ -197,20 +256,19 @@ (p:ps) = map (\a -> Point (x + radius * sin a) (y + radius * cos a)) angles moveTo p mapM_ lineTo (ps++[p])- C.stroke+ c $ C.stroke filledPolygon :: Double -- ^ radius of circle -> Int -- ^ Number of vertices -> Bool -- ^ Is right-side-up?- -> Double -- ^ red component of colour- -> Double -- ^ green component of colour- -> Double -- ^ blue component of colour+ -> Color -> CairoPointStyle-filledPolygon radius sides isrot r g b = CairoPointStyle rf- where rf (Point x y) =- do C.setSourceRGB r g b- C.newPath+filledPolygon radius sides isrot cl = CairoPointStyle rf+ where rf p =+ 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@@ -218,87 +276,80 @@ (p:ps) = map (\a -> Point (x + radius * sin a) (y + radius * cos a)) angles moveTo p mapM_ lineTo (ps++[p])- C.fill+ c $ C.fill plusses :: Double -- ^ radius of circle -> Double -- ^ thickness of line- -> Double -- ^ red component of colour- -> Double -- ^ green component of colour- -> Double -- ^ blue component of colour+ -> Color -> CairoPointStyle-plusses radius w r g b = CairoPointStyle rf- where rf (Point x y) = do C.setLineWidth w- C.setSourceRGB r g b- C.newPath- C.moveTo (x+radius) y- C.lineTo (x-radius) y- C.moveTo x (y-radius)- C.lineTo x (y+radius)- C.stroke+plusses radius w cl = CairoPointStyle rf+ where rf p = do (Point x y ) <- alignp p+ c $ C.setLineWidth w+ c $ setSourceColor cl+ c $ C.newPath+ c $ C.moveTo (x+radius) y+ c $ C.lineTo (x-radius) y+ c $ C.moveTo x (y-radius)+ c $ C.lineTo x (y+radius)+ c $ C.stroke exes :: Double -- ^ radius of circle -> Double -- ^ thickness of line- -> Double -- ^ red component of colour- -> Double -- ^ green component of colour- -> Double -- ^ blue component of colour+ -> Color -> CairoPointStyle-exes radius w r g b = CairoPointStyle rf+exes radius w cl = CairoPointStyle rf where rad = radius / sqrt 2- rf (Point x y) = do C.setLineWidth w- C.setSourceRGB r g b- C.newPath- C.moveTo (x+rad) (y+rad)- C.lineTo (x-rad) (y-rad)- C.moveTo (x+rad) (y-rad)- C.lineTo (x-rad) (y+rad)- C.stroke+ rf p = do (Point x y ) <- alignp p+ c $ C.setLineWidth w+ c $ setSourceColor cl+ c $ C.newPath+ c $ C.moveTo (x+rad) (y+rad)+ c $ C.lineTo (x-rad) (y-rad)+ c $ C.moveTo (x+rad) (y-rad)+ c $ C.lineTo (x-rad) (y+rad)+ c $ C.stroke stars :: Double -- ^ radius of circle -> Double -- ^ thickness of line- -> Double -- ^ red component of colour- -> Double -- ^ green component of colour- -> Double -- ^ blue component of colour+ -> Color -> CairoPointStyle-stars radius w r g b = CairoPointStyle rf+stars radius w cl = CairoPointStyle rf where rad = radius / sqrt 2- rf (Point x y) = do C.setLineWidth w- C.setSourceRGB r g b- C.newPath- C.moveTo (x+radius) y- C.lineTo (x-radius) y- C.moveTo x (y-radius)- C.lineTo x (y+radius)- C.moveTo (x+rad) (y+rad)- C.lineTo (x-rad) (y-rad)- C.moveTo (x+rad) (y-rad)- C.lineTo (x-rad) (y+rad)- C.stroke+ rf p = do (Point x y ) <- alignp p+ c $ C.setLineWidth w+ c $ setSourceColor cl+ c $ C.newPath+ c $ C.moveTo (x+radius) y+ c $ C.lineTo (x-radius) y+ c $ C.moveTo x (y-radius)+ c $ C.lineTo x (y+radius)+ c $ C.moveTo (x+rad) (y+rad)+ c $ C.lineTo (x-rad) (y-rad)+ c $ C.moveTo (x+rad) (y-rad)+ c $ C.lineTo (x-rad) (y+rad)+ c $ C.stroke solidLine :: Double -- ^ width of line- -> Double -- ^ red component of colour- -> Double -- ^ green component of colour- -> Double -- ^ blue component of colour+ -> Color -> CairoLineStyle-solidLine w r g b = CairoLineStyle (do- C.setLineWidth w- C.setSourceRGB r g b+solidLine w cl = CairoLineStyle (do+ c $ C.setLineWidth w+ c $ setSourceColor cl ) dashedLine :: Double -- ^ width of line -> [Double] -- ^ the dash pattern in device coordinates- -> Double -- ^ red component of colour- -> Double -- ^ green component of colour- -> Double -- ^ blue component of colour+ -> Color -> CairoLineStyle-dashedLine w dashes r g b = CairoLineStyle (do- C.setDash dashes 0- C.setLineWidth w- C.setSourceRGB r g b+dashedLine w dashes cl = CairoLineStyle (do+ c $ C.setDash dashes 0+ c $ C.setLineWidth w+ c $ setSourceColor cl ) fontStyle ::@@ -310,18 +361,16 @@ fontStyle name size slant weight = CairoFontStyle fn where fn = do- C.selectFontFace name slant weight- C.setFontSize size+ c $ C.selectFontFace name slant weight+ c $ C.setFontSize size solidFillStyle ::- Double -- ^ red component of colour- -> Double -- ^ green component of colour- -> Double -- ^ blue component of colour+ Color -> CairoFillStyle-solidFillStyle r g b = CairoFillStyle fn- where fn = C.setSourceRGB r g b+solidFillStyle cl = CairoFillStyle fn+ where fn = c $ setSourceColor cl -defaultPointStyle = filledCircles 1 1 1 1+defaultPointStyle = filledCircles 1 white defaultFontStyle = CairoFontStyle (return ()) isValidNumber v = not (isNaN v) && not (isInfinite v)
tests/Prices.hs view
@@ -232,5 +232,65 @@ (27,03,2006, 26.78, 77.05), (28,03,2006, 26.85, 77.13), (30,03,2006, 27.60, 77.96),- (31,03,2006, 28.00, 78.85)+ (31,03,2006, 28.00, 78.85),+ (03,01,2007, 23.18, 69.90),+ (04,01,2007, 23.85, 71.06),+ (05,01,2007, 23.60, 69.80),+ (06,01,2007, 23.35, 68.80),+ (09,01,2007, 24.06, 70.18),+ (10,01,2007, 23.85, 69.15),+ (11,01,2007, 23.88, 69.35),+ (12,01,2007, 23.80, 70.19),+ (13,01,2007, 23.73, 70.50),+ (16,01,2007, 23.74, 71.05),+ (17,01,2007, 23.96, 71.94),+ (18,01,2007, 23.73, 70.25),+ (19,01,2007, 24.45, 72.50),+ (20,01,2007, 24.66, 74.00),+ (23,01,2007, 24.47, 73.25),+ (24,01,2007, 24.84, 74.25),+ (25,01,2007, 25.08, 73.96),+ (27,01,2007, 26.05, 76.10),+ (30,01,2007, 26.58, 78.45),+ (31,01,2007, 25.80, 75.82),+ (01,02,2007, 25.99, 75.21),+ (02,02,2007, 25.50, 74.98),+ (03,02,2007, 25.53, 74.75),+ (06,02,2007, 25.85, 75.57),+ (07,02,2007, 25.70, 75.06),+ (08,02,2007, 24.37, 72.75),+ (09,02,2007, 24.68, 72.77),+ (13,02,2007, 23.88, 70.95),+ (14,02,2007, 24.16, 72.37),+ (15,02,2007, 24.35, 71.84),+ (16,02,2007, 24.29, 71.89),+ (17,02,2007, 23.88, 71.65),+ (20,02,2007, 24.54, 74.90),+ (21,02,2007, 24.98, 75.50),+ (22,02,2007, 24.90, 73.24),+ (23,02,2007, 25.28, 74.69),+ (24,02,2007, 24.55, 72.20),+ (27,02,2007, 24.66, 73.00),+ (28,02,2007, 24.25, 71.20),+ (01,03,2007, 24.03, 70.25),+ (02,03,2007, 24.45, 70.50),+ (03,03,2007, 24.34, 70.35),+ (06,03,2007, 24.51, 70.85),+ (08,03,2007, 23.60, 67.95),+ (09,03,2007, 23.70, 68.65),+ (10,03,2007, 23.37, 67.50),+ (13,03,2007, 23.93, 70.36),+ (14,03,2007, 23.64, 69.45),+ (15,03,2007, 23.90, 69.40),+ (16,03,2007, 24.46, 70.90),+ (17,03,2007, 24.70, 71.25),+ (20,03,2007, 25.24, 72.85),+ (21,03,2007, 25.32, 73.08),+ (22,03,2007, 25.18, 72.99),+ (23,03,2007, 25.57, 74.34),+ (24,03,2007, 25.92, 75.23),+ (27,03,2007, 26.78, 77.05),+ (28,03,2007, 26.85, 77.13),+ (30,03,2007, 27.60, 77.96),+ (31,03,2007, 28.00, 78.85) ]
tests/test.hs view
@@ -14,6 +14,12 @@ chooseLineWidth PDF = 0.25 chooseLineWidth PS = 0.25 +blue = (Color 0 0 1)+green = (Color 0 1 0)+green1 = (Color 0.5 1 0.5)+red = (Color 1 0 0)+red1 = (Color 0.5 0.5 1)+ ---------------------------------------------------------------------- test1 :: OutputType -> IO Layout1 test1 otype = return layout @@ -23,11 +29,11 @@ sinusoid1 = defaultPlotLines { plot_lines_values = [[ (Point x (am x)) | x <- [0,(0.5)..400]]],- plot_lines_style = solidLine lineWidth 0 0 1+ plot_lines_style = solidLine lineWidth blue } sinusoid2 = defaultPlotPoints {- plot_points_style=filledCircles 2 1 0 0,+ plot_points_style=filledCircles 2 red, plot_points_values = [ (Point x (am x)) | x <- [0,7..400]] } @@ -42,17 +48,17 @@ lineWidth = chooseLineWidth otype -----------------------------------------------------------------------test2 :: OutputType -> IO Layout1-test2 otype = return layout +test2 :: OutputType -> [(Int,Int,Int,Double,Double)] -> IO Layout1+test2 otype prices = return layout where price1 = defaultPlotLines {- plot_lines_style = solidLine lineWidth 0 0 1,+ plot_lines_style = solidLine lineWidth blue, plot_lines_values = [[ Point (date d m y) v | (d,m,y,v,_) <- prices]] } price2 = defaultPlotLines {- plot_lines_style = solidLine lineWidth 0 1 0,+ plot_lines_style = solidLine lineWidth green, plot_lines_values = [[ Point (date d m y) v | (d,m,y,_,v) <- prices]] } @@ -61,7 +67,7 @@ layout = defaultLayout1 { layout1_title="Price History", - layout1_horizontal_axes=linkedAxes' (monthsAxis gridlessAxis),+ layout1_horizontal_axes=linkedAxes' (autoTimeAxis gridlessAxis), layout1_vertical_axes=independentAxes vaxis vaxis, layout1_plots = [("price 1", HA_Bottom,VA_Left,(toPlot price1)), ("price 2", HA_Bottom,VA_Right,(toPlot price2))]@@ -92,18 +98,18 @@ where price1 = defaultPlotFillBetween {- plot_fillbetween_style = solidFillStyle 0.5 1 0.5,+ plot_fillbetween_style = solidFillStyle green1, plot_fillbetween_values = [ (date d m y,(0,v2)) | (d,m,y,v1,v2) <- prices] } price2 = defaultPlotFillBetween {- plot_fillbetween_style = solidFillStyle 0.5 0.5 1,+ plot_fillbetween_style = solidFillStyle red1, plot_fillbetween_values = [ (date d m y,(0,v1)) | (d,m,y,v1,v2) <- prices] } layout = defaultLayout1 { layout1_title="Price History", - layout1_horizontal_axes=linkedAxes' (monthsAxis defaultAxis),+ layout1_horizontal_axes=linkedAxes' (autoTimeAxis defaultAxis), layout1_vertical_axes=linkedAxes' (autoScaledAxis defaultAxis), layout1_plots = [("price 1", HA_Bottom,VA_Left,(toPlot price1)), ("price 2", HA_Bottom,VA_Left,(toPlot price2))]@@ -115,7 +121,7 @@ where points = defaultPlotPoints {- plot_points_style=filledCircles 3 1 0 0,+ plot_points_style=filledCircles 3 red, plot_points_values = [ Point x (10**x) | x <- [0.5,1,1.5,2,2.5] ] } @@ -163,8 +169,8 @@ f True = (1+frac*(1+b)) f False = (1-frac) - s1 = solidLine lineWidth 0 1 0- s2 = solidLine lineWidth 0 0 1+ s1 = solidLine lineWidth green+ s2 = solidLine lineWidth blue lineWidth = chooseLineWidth otype @@ -182,15 +188,40 @@ (const 0.5) [0.1,0.7,0.5::Double] "+" xs = [0,0.3..3] :: [Double]+----------------------------------------------------------------------+test7 :: OutputType -> IO Layout1+test7 otype = return layout + where+ vals = [ (x,sin (exp x),sin x/2,cos x/10) | x <- [1..20]]+ bars = defaultPlotErrBars {+ plot_errbars_values = [ErrPoint x y dx dy | (x,y,dx,dy) <- vals]+ }+ points = defaultPlotPoints {+ plot_points_style=filledCircles 2 red,+ plot_points_values = [Point x y | (x,y,dx,dy) <- vals]+ }++ layout = defaultLayout1 {+ layout1_title= "errorbars example",+ layout1_plots = [("test",HA_Bottom,VA_Left,(toPlot bars)),+ ("test",HA_Bottom,VA_Left,(toPlot points))]+ }+ ---------------------------------------------------------------------- allTests = [ ("test1",test1)- , ("test2",test2)+ , ("test2a",\ot -> test2 ot prices)+ , ("test2b",\ot -> test2 ot (filterPrices (date 1 1 2005) (date 31 12 2005)))+ , ("test2c",\ot -> test2 ot (filterPrices (date 1 5 2005) (date 1 7 2005)))+ , ("test2d",\ot -> test2 ot (filterPrices (date 1 1 2006) (date 10 1 2006))) , ("test3",test3) , ("test4",test4) , ("test5",test5) , ("test6",test6)+ , ("test7",test7) ]++filterPrices t1 t2 = [ v | v@(d,m,y,_,_) <- prices, let t = date d m y in t >= t1 && t <= t2] main = do args <- getArgs