diff --git a/Chart.cabal b/Chart.cabal new file mode 100644 --- /dev/null +++ b/Chart.cabal @@ -0,0 +1,34 @@ +Name: Chart +Version: 0.5 +License: BSD4 +License-file: LICENSE +Copyright: Tim Docker, 2006 +Author: Tim Docker +Maintainer: Tim Docker +Homepage: http://www.dockerz.net/software/chart.html +Synopsis: A library for generating 2D Charts and Plots +Description: A library for generating 2D Charts and Plots, based upon the cairo graphics library. +Category: Graphics +Cabal-Version: >= 1.2 + +Extra-Source-Files: tests/test.hs, tests/Prices.hs + +flag splitbase + description: Choose the new smaller, split-up base package. + +library + if flag(splitbase) + Build-depends: base >= 3, old-locale, old-time + else + Build-depends: base < 3 + Build-depends: gtk >= 0.9.11, cairo >= 0.9.11 + + Exposed-modules: + Graphics.Rendering.Chart, + Graphics.Rendering.Chart.Gtk, + Graphics.Rendering.Chart.Types, + Graphics.Rendering.Chart.Renderable, + Graphics.Rendering.Chart.Axis, + Graphics.Rendering.Chart.Layout, + Graphics.Rendering.Chart.Plot + diff --git a/Graphics/Rendering/Chart.hs b/Graphics/Rendering/Chart.hs new file mode 100644 --- /dev/null +++ b/Graphics/Rendering/Chart.hs @@ -0,0 +1,66 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Chart +-- Copyright : (c) Tim Docker 2006 +-- License : BSD-style (see chart/COPYRIGHT) +-- +-- A Simple framework for creating 2D charts in Haskell. +-- +-- The basic model is that you define a value of type 'Renderable', +-- typically by applying 'toRenderable' to some other value. This +-- 'Renderable' is then actually displayed or output by calling either +-- 'renderableToPNGFile', or 'Graphics.Rendering.Chart.Gtk.renderableToWindow'. +-- +-- Currently, the only useful 'Renderable' for displaying charts +-- is created by applying 'toRenderable' to a value of type +-- 'Graphics.Rendering.Chart.Layout.Layout1' +----------------------------------------------------------------------------- + +module Graphics.Rendering.Chart( + Renderable(..), + ToRenderable(..), + Layout1(..), + Axis(..), + Plot(..), + ToPlot(..), + PlotPoints(..), + PlotLines(..), + PlotFillBetween(..), + HAxis(..), + VAxis(..), + Rect(..), + Point(..), + defaultAxisLineStyle, + defaultPlotLineStyle, + defaultAxis, + defaultPlotPoints, + defaultPlotLines, + defaultPlotFillBetween, + defaultLayout1, + filledCircles, + solidLine, + dashedLine, + solidFillStyle, + fontStyle, + independentAxes, + linkedAxes, + linkedAxes', + explicitAxis, + autoScaledAxis, + autoScaledLogAxis, + monthsAxis, + renderableToPNGFile, + renderableToPDFFile, + renderableToPSFile, + doubleFromClockTime, + clockTimeFromDouble, + CairoLineStyle(..), + CairoFillStyle(..), + CairoFontStyle(..) +) where + +import Graphics.Rendering.Chart.Types +import Graphics.Rendering.Chart.Renderable +import Graphics.Rendering.Chart.Layout +import Graphics.Rendering.Chart.Axis +import Graphics.Rendering.Chart.Plot diff --git a/Graphics/Rendering/Chart/Axis.hs b/Graphics/Rendering/Chart/Axis.hs new file mode 100644 --- /dev/null +++ b/Graphics/Rendering/Chart/Axis.hs @@ -0,0 +1,430 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Chart.Axis +-- Copyright : (c) Tim Docker 2006 +-- License : BSD-style (see chart/COPYRIGHT) + +module Graphics.Rendering.Chart.Axis where + +import qualified Graphics.Rendering.Cairo as C +import System.Time +import System.Locale +import Control.Monad +import Data.List + +import Graphics.Rendering.Chart.Types +import Graphics.Rendering.Chart.Renderable + +-- | The concrete data type for an axis +data Axis = Axis { + + -- | The axis_viewport function maps values into device + -- cordinates. + axis_viewport :: Range -> Double -> Double, + + -- | The 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 :: [(Double,Double)], + + -- | The labels on an axis as pairs. The first element + -- is the position on the axis (in viewport units) and + -- the second is the label text string. + axis_labels :: [ (Double, String) ], + + -- | The positions on the axis (in viewport units) where + -- we want to show grid lines. + axis_grid :: [ Double ], + + -- | How far the labels are to be drawn from the axis. + axis_label_gap :: Double, + + axis_line_style :: CairoLineStyle, + axis_label_style :: CairoFontStyle, + axis_grid_style :: CairoLineStyle + +} + +-- | Function type to generate an optional axis given a set +-- of points to be plotted against that axis. +type AxisFn = [Double] -> Maybe Axis + +-- | Function type to generate a pair of axes (either top +-- and bottom, or left and right), given the set of points to +-- be plotted against each of them. +type AxesFn = [Double] -> [Double] -> (Maybe Axis,Maybe Axis) + +data AxisT = AxisT RectEdge Axis + +instance ToRenderable AxisT where + toRenderable at = Renderable { + minsize=minsizeAxis at, + render=renderAxis at + } + +minsizeAxis :: AxisT -> C.Render 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 + let (lw,lh) = foldl maxsz (0,0) labelSizes + let ag = axis_label_gap a + let tsize = maximum [ max 0 (-l) | (v,l) <- axis_ticks a ] + let sz = case at of + E_Top -> (lw,max (lh + ag) tsize) + E_Bottom -> (lw,max (lh + ag) tsize) + E_Left -> (max (lw + ag) tsize, lh) + E_Right -> (max (lw + ag) tsize, lh) + return sz + + where + maxsz (w1,h1) (w2,h2) = (max w1 w2, max h1 h2) + + +-- | Calculate the amount by which the labels extend beyond +-- the ends of the axis +axisOverhang :: AxisT -> C.Render (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 + case labelSizes of + [] -> 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_Bottom -> ohangh + E_Left -> ohangv + E_Right -> ohangh + +renderAxis :: AxisT -> Rect -> C.Render () +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 + 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] + + (hta,vta,lp) = + let g = axis_label_gap a + 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)) + + drawLabel (value,s) = do + drawText hta vta (axisPoint value `pvadd` lp) s + +axisMapping :: AxisT -> Rect -> (Double,Double,Double,Double,Vector,Double->Point) +axisMapping (AxisT et a) rect = case et of + E_Top -> (x1,y2,x2,y2, (Vector 0 1), mapx (x1,x2) y2) + E_Bottom -> (x1,y1,x2,y1, (Vector 0 (-1)), mapx (x1,x2) y1) + E_Left -> (x2,y2,x2,y1, (Vector (1) 0), mapy (y1,y2) x2) + E_Right -> (x1,y2,x1,y1, (Vector (-1) 0), mapy (y1,y2) x1) + where + (Rect (Point x1 y1) (Point x2 y2)) = rect + + mapx :: Range -> Double -> Double -> Point + mapx xr y x = Point (axis_viewport a xr x) y + + mapy :: Range -> Double -> Double -> Point + mapy (yr0,yr1) x y = Point x (axis_viewport a (yr1,yr0) y) + +renderAxisGrid :: AxisT -> Rect -> C.Render () +renderAxisGrid at@(AxisT re a) rect@(Rect p1 p2) = do + C.save + setLineStyle (axis_grid_style a) + mapM_ (drawGridLine re) (axis_grid a) + C.restore + where + (sx,sy,ex,ey,tp,axisPoint) = axisMapping at rect + + drawGridLine E_Top = vline + drawGridLine E_Bottom = vline + drawGridLine E_Left = hline + 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)] + + 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)) + +---------------------------------------------------------------------- + +steps:: Double -> Range -> [Rational] +steps nSteps (min,max) = [ (fromIntegral (min' + i)) * s | i <- [0..n] ] + where + min' = floor (min / fromRational s) + max' = ceiling (max / fromRational s) + n = (max' - min') + s = chooseStep nSteps (min,max) + +chooseStep :: Double -> Range -> Rational +chooseStep nsteps (min,max) = s + 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') + +-- | Explicitly specify an axis +explicitAxis :: Maybe Axis -> AxisFn +explicitAxis ma _ = ma + +linearTicks r = (major, minor) + where + major = steps 5 r + minor = steps 50 (fromRational (minimum major),fromRational (maximum major)) + +autoAxis transform (rlabelvs, rtickvs) a = Just axis + where + axis = a { + axis_viewport=newViewport, + axis_ticks=newTicks, + axis_grid=gridvs, + axis_labels=newLabels + } + newViewport = transform (min',max') + newTicks = [ (v,2) | v <- tickvs ] ++ [ (v,5) | v <- labelvs ] + newLabels = [(v,show v) | v <- labelvs] + labelvs = map fromRational rlabelvs + tickvs = map fromRational rtickvs + min' = minimum labelvs + max' = maximum labelvs + + gridvs = case (axis_grid a) of + [] -> [] + _ -> labelvs + +-- | 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 :: Axis -> AxisFn +autoScaledAxis a ps0 = autoAxis vmap (linearTicks (range ps)) a + where + ps = filter isValidNumber ps0 + (min,max) = (minimum ps,maximum ps) + range [] = (0,1) + range _ | min == max = (min-0.5,min+0.5) + | otherwise = (min,max) + +log10 :: (Floating a) => a -> a +log10 = logBase 10 + +frac x | 0 <= b = (a,b) + | otherwise = (a-1,b+1) + where + (a,b) = properFraction x + +lmap (x1,x2) r x = vmap (log x1, log x2) r (log x) + +{- + Rules: Do no subdivide between powers of 10 until all powers of 10 + get a major ticks. + Do not subdivide between powers of ten as [1,2,4,6,8,10] when + 5 gets a major ticks + (ie the major ticks need to be a subset of the minor tick) +-} +logTicks :: Range -> ([Rational],[Rational]) +logTicks (low,high) = (major,minor) + 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 + 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) + (dl',dh') = (fromRational l', fromRational h') + 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') + +-- | 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 :: Axis -> AxisFn +autoScaledLogAxis a ps0 = autoAxis lmap (logTicks (range ps)) a + where + ps = filter isValidNumber ps0 + (min, max) = (minimum ps,maximum ps) + range [] = (3,30) + range _ | min == max = (min/3,max*3) + | otherwise = (min,max) + +-- | Show independent axes on each side of the layout +independentAxes :: AxisFn -> AxisFn -> AxesFn +independentAxes af1 af2 pts1 pts2 = (af1 pts1, af2 pts2) + +-- | Show the same axis on both sides of the layout +linkedAxes :: AxisFn -> AxesFn +linkedAxes af pts1 pts2 = (a,a) + where + a = af (pts1++pts2) + +-- | Show the same axis on both sides of the layout, but with labels +-- only on the primary side +linkedAxes' :: AxisFn -> AxesFn +linkedAxes' af pts1 pts2 = (a,removeLabels a) + where + a = af (pts1++pts2) + removeLabels = liftM (\a -> a{axis_labels = []}) + +---------------------------------------------------------------------- + +defaultAxisLineStyle = solidLine 1 0 0 0 +defaultGridLineStyle = dashedLine 1 [5,5] 0.8 0.8 0.8 + +defaultAxis = Axis { + axis_viewport = vmap (0,1), + axis_ticks = [(0,10),(1,10)], + axis_labels = [], + axis_grid = [0.0,0.5,1.0], + axis_label_gap =10, + axis_line_style = defaultAxisLineStyle, + axis_label_style = defaultFontStyle, + axis_grid_style = defaultGridLineStyle +} + +---------------------------------------------------------------------- + +refClockTime = toClockTime CalendarTime { + ctYear=1970, + ctMonth=toEnum 0, + ctDay=1, + ctHour=0, + ctMin=0, + ctSec=0, + ctPicosec=0, + ctTZ=0, + ctWDay=Monday, + ctYDay=0, + ctTZName="", + ctIsDST=False + } + +-- | Map a clocktime value to a plot cordinate +doubleFromClockTime :: ClockTime -> Double +doubleFromClockTime ct = fromIntegral (tdSec (diffClockTimes ct refClockTime)) + +-- | Map a plot cordinate to a clocktime +clockTimeFromDouble :: Double -> ClockTime +clockTimeFromDouble v = (addToClockTime tdiff refClockTime) + where + tdiff = TimeDiff { + tdYear = 0, + tdMonth = 0, + tdDay = 0, + tdHour = 0, + tdMin = 0, + tdSec = floor v, + 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 + where + axis = a { + axis_viewport=newViewport, + axis_ticks=newTicks, + axis_labels=newLabels, + axis_grid=newGrid + } + (min,max) = case pts of + [] -> (refClockTime, nextMonthStart refClockTime) + ps -> let min = minimum ps + max = maximum ps in + (clockTimeFromDouble min,clockTimeFromDouble max) + min' = thisMonthStart min + max' = nextMonthStart 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] + + mlabelt m = formatCalendarTime defaultTimeLocale "%b-%y" (toUTCTime m) + mlabelv m1 m2 = (doubleFromClockTime m2 + doubleFromClockTime m1) / 2 + +thisMonthStart ct = + let calt = (toUTCTime ct) { + ctDay=1, + ctHour=0, + ctMin=0, + ctSec=0, + ctPicosec=0 + } in + toClockTime calt + +nextMonthStart ct = + let month1 = noTimeDiff{tdMonth=1} in + addToClockTime month1 (thisMonthStart ct) + diff --git a/Graphics/Rendering/Chart/Gtk.hs b/Graphics/Rendering/Chart/Gtk.hs new file mode 100644 --- /dev/null +++ b/Graphics/Rendering/Chart/Gtk.hs @@ -0,0 +1,42 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Chart.Gtk +-- Copyright : (c) Tim Docker 2006 +-- License : BSD-style (see chart/COPYRIGHT) + +module Graphics.Rendering.Chart.Gtk( + renderableToWindow + ) where + +import qualified Graphics.UI.Gtk as G +import qualified Graphics.Rendering.Cairo as C +import Graphics.Rendering.Chart +import Graphics.Rendering.Chart.Renderable + +renderableToWindow :: Renderable -> Int -> Int -> IO () +renderableToWindow chart windowWidth windowHeight = do + G.initGUI + window <- G.windowNew + canvas <- G.drawingAreaNew + -- fix size + -- G.windowSetResizable window False + G.widgetSetSizeRequest window windowWidth windowHeight + -- press any key to quit + G.onKeyPress window $ const (do G.widgetDestroy window; return True) + G.onDestroy window G.mainQuit + G.onExpose canvas $ const (updateCanvas chart canvas) + G.set window [G.containerChild G.:= canvas] + G.widgetShowAll window + G.mainGUI + +updateCanvas :: Renderable -> G.DrawingArea -> IO Bool +updateCanvas chart canvas = do + win <- G.widgetGetDrawWindow canvas + (width, height) <- G.widgetGetSize canvas + let rect = Rect (Point 0 0) (Point (fromIntegral width) (fromIntegral height)) + G.renderWithDrawable win (rfn rect) + return True + where + rfn rect = do + alignPixels + render chart rect diff --git a/Graphics/Rendering/Chart/Layout.hs b/Graphics/Rendering/Chart/Layout.hs new file mode 100644 --- /dev/null +++ b/Graphics/Rendering/Chart/Layout.hs @@ -0,0 +1,175 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Chart.Layout +-- Copyright : (c) Tim Docker 2006 +-- License : BSD-style (see chart/COPYRIGHT) + +module Graphics.Rendering.Chart.Layout where + +import qualified Graphics.Rendering.Cairo as C + +import Graphics.Rendering.Chart.Axis +import Graphics.Rendering.Chart.Types +import Graphics.Rendering.Chart.Plot +import Graphics.Rendering.Chart.Renderable + +data HAxis = HA_Top | HA_Bottom deriving (Eq) +data VAxis = VA_Left | VA_Right deriving (Eq) + +-- | A Layout1 value is a single plot area, with optional: axes on +-- each of the 4 sides; title at the top; legend at the bottom. +data Layout1 = Layout1 { + layout1_background :: CairoFillStyle, + layout1_title :: String, + layout1_title_style :: CairoFontStyle, + layout1_horizontal_axes :: AxesFn, + layout1_vertical_axes :: AxesFn, + layout1_margin :: Double, + layout1_plots :: [(String,HAxis,VAxis,Plot)], + layout1_legend :: Maybe(LegendStyle) +} + +instance ToRenderable Layout1 where + toRenderable = layout1ToRenderable + +layout1ToRenderable l = + fillBackground (layout1_background l) ( + vertical [ + (0, addMargins (lm/2,0,0,0) (mkTitle l)), + (1, addMargins (lm/2,lm,lm,lm) (plotArea l)), + (0, horizontal [ (0, mkLegend VA_Left l), (1,emptyRenderable), (0, mkLegend VA_Right l) ] ) + ] + ) + where + lm = layout1_margin l + + mkTitle l = label (layout1_title_style l) HTA_Centre VTA_Centre (layout1_title l) + + mkLegend va l = case (layout1_legend l) of + Nothing -> emptyRenderable + (Just ls) -> case [(s,p) | (s,_,va',p) <- layout1_plots l, va' == va, not (null s)] of + [] -> emptyRenderable + ps -> addMargins (0,lm,lm,0) (toRenderable (Legend True ls ps)) + + plotArea l = Renderable { + minsize=minsizePlotArea l, + render=renderPlotArea l + } + +minsizePlotArea l = do + (w1,h1,w2,h2) <- axisSizes l + return (w1+w2,h1+h2) + +renderPlotArea l (Rect p1 p5) = do + let margin = (layout1_margin l) + + (w1,h1,w2,h2) <- axisSizes l + + let p2 = p1 `pvadd` (Vector w1 h1) + let p4 = p5 + let p3 = p4 `pvsub` (Vector w2 h2) + let plotRect = (Rect p2 p3) + + -- render the plots + C.save + setClipRegion p2 p3 + mapM_ (rPlot plotRect) (layout1_plots l) + C.restore + + -- render the axes grids + rMAxisG tAxis plotRect + rMAxisG bAxis plotRect + rMAxisG lAxis plotRect + rMAxisG rAxis plotRect + + -- render the axes + rMAxis tAxis (mkrect p2 p1 p3 p2) + rMAxis bAxis (mkrect p2 p3 p3 p4) + rMAxis lAxis (mkrect p1 p2 p2 p3) + rMAxis rAxis (mkrect p3 p2 p4 p3) + + where + (bAxis,lAxis,tAxis,rAxis) = getAxes l + + rMAxisG :: Maybe AxisT -> Rect -> C.Render () + rMAxisG (Just at) rect = renderAxisGrid at rect + rMAxisG Nothing _ = return () + + rMAxis :: Maybe AxisT -> Rect -> C.Render () + rMAxis (Just at) rect = render (toRenderable at) rect + rMAxis Nothing _ = return () + + rPlot :: Rect -> (String,HAxis,VAxis,Plot) -> C.Render () + rPlot rect (_,ha,va,p) = + let mxaxis = case ha of HA_Bottom -> bAxis + HA_Top -> tAxis + myaxis = case va of VA_Left -> lAxis + VA_Right -> rAxis + in rPlot1 rect mxaxis myaxis p + + rPlot1 :: Rect -> Maybe AxisT -> Maybe AxisT -> Plot -> C.Render () + rPlot1 (Rect dc1 dc2) (Just (AxisT _ xaxis)) (Just (AxisT _ yaxis)) p = + let xrange = (p_x dc1, p_x dc2) + yrange = (p_y dc2, p_y dc1) + pmfn (Point x y) = Point (axis_viewport xaxis xrange x) (axis_viewport yaxis yrange y) + in plot_render p pmfn + rPlot1 _ _ _ _ = return () + +axisSizes l = do + w1a <- asize fst lAxis + h1a <- asize snd tAxis + w2a <- asize fst rAxis + h2a <- asize snd bAxis + (h1b,h2b) <- aohang lAxis + (w1b,w2b) <- aohang tAxis + (h1c,h2c) <- aohang rAxis + (w1c,w2c) <- aohang bAxis + + return (maximum [w1a,w1b,w1c], + maximum [h1a,h1b,h1c], + maximum [w2a,w2b,w2c], + maximum [h2a,h2b,h2c] ) + where + (bAxis,lAxis,tAxis,rAxis) = getAxes l + + asize xyfn Nothing = return 0 + asize xyfn (Just at) = do + sz <- minsize (toRenderable at) + return (xyfn sz) + + aohang Nothing = return (0,0) + aohang (Just a) = axisOverhang a + + +getAxes :: Layout1 -> (Maybe AxisT, Maybe AxisT, Maybe AxisT, Maybe AxisT) +getAxes l = (mk E_Bottom bAxis, mk E_Left lAxis, + mk E_Top tAxis, mk E_Right rAxis) + where + (xvals0,xvals1,yvals0,yvals1) = allPlottedValues (layout1_plots l) + (bAxis,tAxis) = layout1_horizontal_axes l xvals0 xvals1 + (lAxis,rAxis) = layout1_vertical_axes l yvals0 yvals1 + mk _ Nothing = Nothing + mk at (Just a) = Just (AxisT at a) + + +allPlottedValues :: [(String,HAxis,VAxis,Plot)] -> ( [Double], [Double], [Double], [Double] ) +allPlottedValues plots = (xvals0,xvals1,yvals0,yvals1) + where + pts = concat [ [ (ha,va,pt)| pt <- plot_all_points p] | (_,ha,va,p) <- plots ] + xvals0 = [ (p_x pt) | (HA_Bottom,_,pt) <- pts ] + xvals1 = [ (p_x pt) | (HA_Top,_,pt) <- pts ] + yvals0 = [ (p_y pt) | (_,VA_Left,pt) <- pts ] + yvals1 = [ (p_y pt) | (_,VA_Right,pt) <- pts ] + + +defaultLayout1 = Layout1 { + layout1_background = solidFillStyle 1 1 1, + layout1_title = "", + layout1_title_style = fontStyle "sans" 15 C.FontSlantNormal C.FontWeightBold, + layout1_horizontal_axes = linkedAxes (autoScaledAxis defaultAxis), + layout1_vertical_axes = linkedAxes (autoScaledAxis defaultAxis), + layout1_margin = 10, + layout1_plots = [], + layout1_legend = Just defaultLegendStyle +} + diff --git a/Graphics/Rendering/Chart/Plot.hs b/Graphics/Rendering/Chart/Plot.hs new file mode 100644 --- /dev/null +++ b/Graphics/Rendering/Chart/Plot.hs @@ -0,0 +1,178 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Chart.Plot +-- Copyright : (c) Tim Docker 2006 +-- License : BSD-style (see chart/COPYRIGHT) + +module Graphics.Rendering.Chart.Plot( + Plot(..), + ToPlot(..), + PlotPoints(..), + PlotLines(..), + PlotFillBetween(..), + + defaultPlotLineStyle, + defaultPlotPoints, + defaultPlotFillBetween, + defaultPlotLines + + ) where + +import qualified Graphics.Rendering.Cairo as C +import Graphics.Rendering.Chart.Types +import Control.Monad + +-- | Interface to control plotting on a 2D area. +data Plot = Plot { + + -- | Given the mapping between model space coordinates and device coordinates, + -- render this plot into a chart. + plot_render :: PointMapFn -> C.Render (), + + -- | 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 (), + + -- | All of the model space coordinates to be plotted. These are + -- used to autoscale the axes where necessary. + plot_all_points :: [Point] +}; + +-- | a type class abstracting the conversion of a value to a Plot. +class ToPlot a where + toPlot :: a -> Plot + +---------------------------------------------------------------------- + +-- | Value defining a series of (possibly disjointed) lines, +-- and a style in which to render them +data PlotLines = PlotLines { + plot_lines_style :: CairoLineStyle, + plot_lines_values :: [[Point]] +} + +instance ToPlot PlotLines where + toPlot p = Plot { + plot_render = renderPlotLines p, + plot_render_legend = renderPlotLegendLines p, + plot_all_points = concat (plot_lines_values p) + } + +renderPlotLines :: PlotLines -> PointMapFn -> C.Render () +renderPlotLines p pmap = do + C.save + 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 + +renderPlotLegendLines :: PlotLines -> Rect -> C.Render () +renderPlotLegendLines p r@(Rect p1 p2) = do + C.save + 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 + +defaultPlotLineStyle = solidLine 1 0 0 1 + +defaultPlotLines = PlotLines { + plot_lines_style = defaultPlotLineStyle, + plot_lines_values = [] +} +---------------------------------------------------------------------- + +-- | Value defining a series of datapoints, and a style in +-- which to render them +data PlotPoints = PlotPoints { + plot_points_style :: CairoPointStyle, + plot_points_values :: [Point] +} + +instance ToPlot PlotPoints where + toPlot p = Plot { + plot_render = renderPlotPoints p, + plot_render_legend = renderPlotLegendPoints p, + plot_all_points = plot_points_values p + } + +renderPlotPoints :: PlotPoints -> PointMapFn -> C.Render () +renderPlotPoints p pmap = do + C.save + 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 + 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) + +defaultPlotPoints = PlotPoints { + plot_points_style =defaultPointStyle, + plot_points_values = [] +} +---------------------------------------------------------------------- +-- | Value specifying a plot filling the area between two sets of Y +-- coordinates, given common X coordinates. + +data PlotFillBetween = PlotFillBetween { + plot_fillbetween_style :: CairoFillStyle, + plot_fillbetween_values :: [ (Double, (Double,Double))] +} + +instance ToPlot PlotFillBetween where + toPlot p = Plot { + plot_render = renderPlotFillBetween p, + plot_render_legend = renderPlotLegendFill p, + plot_all_points = plotAllPointsFillBetween p + } + +renderPlotFillBetween :: PlotFillBetween -> PointMapFn -> C.Render () +renderPlotFillBetween p pmap = renderPlotFillBetween' p (plot_fillbetween_values p) pmap + +renderPlotFillBetween' p [] _ = return () +renderPlotFillBetween' p vs pmap = do + C.save + setFillStyle (plot_fillbetween_style p) + moveTo p0 + mapM_ lineTo p1s + mapM_ lineTo (reverse p2s) + lineTo p0 + C.fill + C.restore + 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 + setFillStyle (plot_fillbetween_style p) + rectPath r + C.fill + C.restore + +plotAllPointsFillBetween :: PlotFillBetween -> [Point] +plotAllPointsFillBetween p = concat [ [Point x y1, Point x y2] + | (x,(y1,y2)) <- plot_fillbetween_values p] + + +defaultPlotFillBetween = PlotFillBetween { + plot_fillbetween_style=solidFillStyle 0.5 0.5 1.0, + plot_fillbetween_values=[] +} diff --git a/Graphics/Rendering/Chart/Renderable.hs b/Graphics/Rendering/Chart/Renderable.hs new file mode 100644 --- /dev/null +++ b/Graphics/Rendering/Chart/Renderable.hs @@ -0,0 +1,234 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Chart.Renderable +-- Copyright : (c) Tim Docker 2006 +-- License : BSD-style (see chart/COPYRIGHT) + +module Graphics.Rendering.Chart.Renderable where + +import qualified Graphics.Rendering.Cairo as C +import Control.Monad + +import Graphics.Rendering.Chart.Types +import Graphics.Rendering.Chart.Plot + +-- | A Renderable is a record of functions required to layout a +-- graphic element. +data Renderable = Renderable { + + -- | a Cairo action to calculate a minimum size, + minsize :: C.Render RectSize, + + -- | a Cairo action for drawing it within a specified rectangle. + render :: Rect -> C.Render () +} + +-- | A type class abtracting the conversion of a value to a +-- Renderable. + +class ToRenderable a where + toRenderable :: a -> Renderable + +emptyRenderable = Renderable { + minsize = return (0,0), + render = \_ -> return () +} + +addMargins :: (Double,Double,Double,Double) -> Renderable -> Renderable +addMargins (t,b,l,r) rd = Renderable { minsize = mf, render = rf } + where + mf = do + (w,h) <- minsize rd + return (w+l+r,h+t+b) + + rf r1@(Rect p1 p2) = do + render rd (Rect (p1 `pvadd` (Vector l t)) (p2 `pvsub` (Vector r b))) + +fillBackground :: CairoFillStyle -> Renderable -> Renderable +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 + render r rect + +vertical, horizontal :: [(Double,Renderable)] -> Renderable +vertical rs = Renderable { minsize = mf, render = rf } + where + mf = do + (_,wmin,hmin) <- calcSizes + return (wmin, hmin) + + rf (Rect p1 p2) = do + (sizes,wmin,hmin) <- calcSizes + let wactual = p_x p2 - p_x p1 + let hextra = p_y p2 - p_y p1 - hmin + let etotal = sum (map fst rs) + let rs' = [ (wactual,h + hextra * e / etotal,r) + | ((e,r),(w,h)) <- zip rs sizes ] + foldM_ render1 p1 rs' + + calcSizes = do + sizes <- mapM minsize [ r | (_,r) <- rs] + let wmin = maximum [ w | (w,h) <- sizes ] + let hmin = sum [ h | (w,h) <- sizes ] + return (sizes,wmin,hmin) + + render1 :: Point -> (Double,Double,Renderable) -> C.Render Point + render1 p (w,h,r) = do + render r (Rect p (p `pvadd` Vector w h)) + return (p `pvadd` Vector 0 h) + +horizontal rs = Renderable { minsize = mf, render = rf } + where + mf = do + (_,wmin,hmin) <- calcSizes + return (wmin, hmin) + + rf (Rect p1 p2) = do + (sizes,wmin,hmin) <- calcSizes + let hactual = p_y p2 - p_y p1 + let wextra = p_x p2 - p_x p1 - wmin + let etotal = sum (map fst rs) + let rs' = [ (w + wextra * e / etotal,hactual,r) + | ((e,r),(w,h)) <- zip rs sizes ] + foldM_ render1 p1 rs' + + calcSizes = do + sizes <- mapM minsize [ r | (_,r) <- rs] + let hmin = maximum [ h | (w,h) <- sizes ] + let wmin = sum [ w | (w,h) <- sizes ] + return (sizes,wmin,hmin) + + render1 :: Point -> (Double,Double,Renderable) -> C.Render Point + render1 p (w,h,r) = do + render r (Rect p (p `pvadd` Vector w h)) + return (p `pvadd` Vector w 0) + +renderableToPNGFile :: Renderable -> Int -> Int -> FilePath -> IO () +renderableToPNGFile chart width height path = + C.withImageSurface C.FormatARGB32 width height $ \result -> do + C.renderWith result $ rfn + C.surfaceWriteToPNG result path + where + rfn = do + alignPixels + render chart rect + + rect = Rect (Point 0 0) (Point (fromIntegral width) (fromIntegral height)) + +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.surfaceFinish result + where + rfn = do + render chart rect + C.showPage + + rect = Rect (Point 0 0) (Point (fromIntegral width) (fromIntegral height)) + +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.surfaceFinish result + where + rfn = do + render chart rect + C.showPage + + rect = Rect (Point 0 0) (Point (fromIntegral width) (fromIntegral height)) + +alignPixels :: C.Render () +alignPixels = do + -- move to centre of pixels so that stroke width of 1 is + -- exactly one pixel + C.translate 0.5 0.5 + +---------------------------------------------------------------------- +-- Legend + +data LegendStyle = LegendStyle { + legend_label_style :: CairoFontStyle, + legend_margin :: Double, + legend_plot_size :: Double +} + +data Legend = Legend Bool LegendStyle [(String,Plot)] + +instance ToRenderable Legend where + toRenderable l = Renderable { + minsize=minsizeLegend l, + render=renderLegend l + } + +minsizeLegend :: Legend -> C.Render RectSize +minsizeLegend (Legend _ ls plots) = do + let labels = map fst plots + lsizes <- mapM textSize labels + lgap <- legendSpacer + let lm = legend_margin ls + let pw = legend_plot_size ls + let h = maximum [h | (w,h) <- lsizes] + let n = fromIntegral (length lsizes) + let w = sum [w + lgap | (w,h) <- lsizes] + pw * (n+1) + lm * (n-1) + return (w,h) + +renderLegend :: Legend -> Rect -> C.Render () +renderLegend (Legend _ ls plots) (Rect rp1 rp2) = do + foldM_ rf rp1 plots + where + lm = legend_margin ls + lps = legend_plot_size ls + + rf :: Point -> (String,Plot) -> C.Render Point + rf p1 (label,plot) = do + (w,h) <- textSize label + lgap <- legendSpacer + let p2 = (p1 `pvadd` Vector lps 0) + plot_render_legend plot (mkrect p1 rp1 p2 rp2) + let p3 = Point (p_x p2 + lgap) (p_y rp1) + drawText HTA_Left VTA_Top p3 label + return (p3 `pvadd` Vector (w+lm) 0) + +legendSpacer = do + (lgap,_) <- textSize "X" + return lgap + +defaultLegendStyle = LegendStyle { + legend_label_style=defaultFontStyle, + legend_margin=20, + legend_plot_size=20 +} + + +---------------------------------------------------------------------- +-- Labels + +label :: CairoFontStyle -> HTextAnchor -> VTextAnchor -> String -> Renderable +label fs hta vta s = Renderable { minsize = mf, render = rf } + where + mf = do + C.save + setFontStyle fs + sz <- textSize s + C.restore + return sz + rf (Rect p1 p2) = do + C.save + setFontStyle fs + let p = Point (xp hta (p_x p1) (p_x p2)) (yp vta (p_y p1) (p_y p2)) + drawText hta vta p s + C.restore + xp HTA_Left x1 x2 = x1 + xp HTA_Centre x1 x2 = (x1+x2)/2 + xp HTA_Right x1 x2 = x2 + yp VTA_Top y1 y2 = y2 + yp VTA_Centre y1 y2 = (y1+y2)/2 + yp VTA_Bottom y1 y2 = y1 + diff --git a/Graphics/Rendering/Chart/Types.hs b/Graphics/Rendering/Chart/Types.hs new file mode 100644 --- /dev/null +++ b/Graphics/Rendering/Chart/Types.hs @@ -0,0 +1,210 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Chart.Types +-- Copyright : (c) Tim Docker 2006 +-- License : BSD-style (see chart/COPYRIGHT) + +module Graphics.Rendering.Chart.Types where + +import qualified Graphics.Rendering.Cairo as C + +-- | A point in two dimensions +data Point = Point { + p_x :: Double, + p_y :: Double +} deriving Show + +data Vector = Vector { + v_x :: Double, + v_y :: Double +} deriving Show + +-- | 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 +pvadd :: Point -> Vector -> Point +pvadd (Point x1 y1) (Vector x2 y2) = (Point (x1+x2) (y1+y2)) + +-- | 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 +psub :: Point -> Point -> Vector +psub (Point x1 y1) (Point x2 y2) = (Vector (x1-x2) (y1-y2)) + +-- | a function mapping between points +type PointMapFn = Point -> Point + +-- | 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 +mkrect (Point x1 _) (Point _ y2) (Point x3 _) (Point _ y4) = + Rect (Point x1 y2) (Point x3 y4) + +-- | A linear mapping of points in one range to another +vmap :: Range -> Range -> Double -> Double +vmap (v1,v2) (v3,v4) v = v3 + (v-v1) * (v4-v3) / (v2-v1) + +-- | 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 ()) + +-- | 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 ()) + +-- | 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 ()) + +-- | Abstract data type for a font. +-- +-- The contained Cairo action sets the required font +-- in the Cairo rendering state. +newtype CairoFontStyle = CairoFontStyle (C.Render ()) + +type Range = (Double,Double) +type RectSize = (Double,Double) + +---------------------------------------------------------------------- +-- 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 + +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 + +-- | stroke the lines between successive points +strokeLines (p1:ps) = do + C.newPath + moveTo p1 + mapM_ lineTo ps + C.stroke +strokeLines _ = return () + +-- | make a path from a rectable +rectPath :: Rect -> C.Render () +rectPath (Rect (Point x1 y1) (Point x2 y2)) = do + C.newPath + C.moveTo x1 y1 + C.lineTo x2 y1 + C.lineTo x2 y2 + C.lineTo x1 y2 + C.lineTo x1 y1 + +setFontStyle (CairoFontStyle s) = s +setLineStyle (CairoLineStyle s) = s +setFillStyle (CairoFillStyle s) = s + +textSize :: String -> C.Render RectSize +textSize s = do + te <- C.textExtents s + fe <- C.fontExtents + return (C.textExtentsWidth te, C.fontExtentsHeight fe) + +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. +drawText :: HTextAnchor -> VTextAnchor -> Point -> String -> C.Render () +drawText hta vta (Point x y) s = 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) + +---------------------------------------------------------------------- + +filledCircles :: + Double -- ^ radius of circle + -> Double -- ^ red component of colour + -> Double -- ^ green component of colour + -> Double -- ^ blue component of colour + -> CairoPointStyle +filledCircles radius r g b = CairoPointStyle rf + where + rf (Point x y) = do + C.setSourceRGB r g b + C.newPath + C.arc x y radius 0 360 + C.fill + +solidLine :: + Double -- ^ width of line + -> Double -- ^ red component of colour + -> Double -- ^ green component of colour + -> Double -- ^ blue component of colour + -> CairoLineStyle +solidLine w r g b = CairoLineStyle (do + C.setLineWidth w + C.setSourceRGB r g b + ) + +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 + -> CairoLineStyle +dashedLine w dashes r g b = CairoLineStyle (do + C.setDash dashes 0 + C.setLineWidth w + C.setSourceRGB r g b + ) + +fontStyle :: + String -- ^ the font name + -> Double -- ^ the font size + -> C.FontSlant -- ^ the font slant + -> C.FontWeight -- ^ the font weight + -> CairoFontStyle +fontStyle name size slant weight = CairoFontStyle fn + where + fn = do + C.selectFontFace name slant weight + C.setFontSize size + +solidFillStyle :: + Double -- ^ red component of colour + -> Double -- ^ green component of colour + -> Double -- ^ blue component of colour + -> CairoFillStyle +solidFillStyle r g b = CairoFillStyle fn + where fn = C.setSourceRGB r g b + +defaultPointStyle = filledCircles 1 1 1 1 +defaultFontStyle = CairoFontStyle (return ()) + +isValidNumber v = not (isNaN v) && not (isInfinite v) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ +Copyright (c) 2006, Tim Docker + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * The names of contributors may not be used to endorse or promote + products derived from this software without specific prior + written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,8 @@ +#!/usr/bin/env runghc + +module Main where + +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/tests/Prices.hs b/tests/Prices.hs new file mode 100644 --- /dev/null +++ b/tests/Prices.hs @@ -0,0 +1,236 @@ +module Prices where + +prices :: [(Int,Int,Int,Double,Double)] +prices = [ + (03,05,2005, 16.18, 42.02), + (04,05,2005, 16.25, 42.31), + (05,05,2005, 16.50, 42.95), + (06,05,2005, 16.52, 43.50), + (09,05,2005, 16.84, 44.91), + (10,05,2005, 16.70, 44.55), + (11,05,2005, 16.43, 43.63), + (12,05,2005, 16.29, 43.18), + (13,05,2005, 15.95, 42.40), + (16,05,2005, 15.55, 41.65), + (17,05,2005, 15.71, 42.17), + (18,05,2005, 15.93, 42.37), + (19,05,2005, 16.20, 42.85), + (20,05,2005, 15.88, 42.30), + (23,05,2005, 15.92, 42.53), + (24,05,2005, 16.25, 42.81), + (25,05,2005, 16.20, 42.67), + (26,05,2005, 16.05, 42.35), + (27,05,2005, 16.45, 43.12), + (30,05,2005, 16.85, 43.24), + (31,05,2005, 16.68, 42.57), + (01,06,2005, 16.85, 43.22), + (02,06,2005, 17.17, 43.85), + (03,06,2005, 17.42, 44.15), + (06,06,2005, 17.50, 44.07), + (07,06,2005, 17.37, 43.76), + (08,06,2005, 17.15, 43.21), + (09,06,2005, 17.12, 43.42), + (10,06,2005, 17.15, 43.27), + (14,06,2005, 17.34, 43.30), + (15,06,2005, 17.46, 43.90), + (16,06,2005, 17.71, 44.43), + (17,06,2005, 18.25, 45.45), + (20,06,2005, 18.23, 45.16), + (21,06,2005, 18.26, 45.54), + (22,06,2005, 18.11, 45.06), + (23,06,2005, 17.79, 44.65), + (24,06,2005, 17.76, 44.43), + (27,06,2005, 17.63, 44.22), + (28,06,2005, 18.08, 44.94), + (29,06,2005, 18.13, 44.80), + (30,06,2005, 18.15, 44.82), + (01,07,2005, 18.09, 45.12), + (04,07,2005, 18.20, 45.20), + (05,07,2005, 18.45, 45.85), + (06,07,2005, 18.40, 45.91), + (07,07,2005, 18.60, 46.35), + (08,07,2005, 18.38, 45.76), + (11,07,2005, 18.80, 46.41), + (12,07,2005, 18.60, 45.86), + (13,07,2005, 18.73, 46.00), + (14,07,2005, 18.70, 46.44), + (15,07,2005, 18.67, 46.25), + (18,07,2005, 18.54, 45.77), + (19,07,2005, 18.20, 45.21), + (20,07,2005, 18.65, 46.13), + (21,07,2005, 19.00, 46.87), + (22,07,2005, 19.09, 47.32), + (25,07,2005, 19.22, 47.36), + (26,07,2005, 19.19, 47.66), + (27,07,2005, 19.17, 47.64), + (28,07,2005, 19.15, 47.98), + (29,07,2005, 19.36, 49.12), + (01,08,2005, 19.40, 49.30), + (02,08,2005, 19.30, 49.17), + (03,08,2005, 19.52, 49.91), + (04,08,2005, 19.80, 50.60), + (05,08,2005, 19.60, 50.40), + (08,08,2005, 19.92, 50.94), + (09,08,2005, 20.34, 52.09), + (10,08,2005, 20.45, 51.42), + (11,08,2005, 20.74, 52.30), + (12,08,2005, 21.05, 53.01), + (15,08,2005, 21.16, 53.02), + (16,08,2005, 20.90, 52.74), + (17,08,2005, 20.55, 51.93), + (18,08,2005, 20.28, 51.42), + (19,08,2005, 20.68, 52.20), + (22,08,2005, 21.22, 53.10), + (23,08,2005, 21.07, 53.01), + (24,08,2005, 20.56, 52.72), + (25,08,2005, 19.90, 50.45), + (26,08,2005, 20.60, 51.42), + (29,08,2005, 20.03, 50.10), + (30,08,2005, 20.47, 50.74), + (31,08,2005, 20.46, 50.31), + (01,09,2005, 20.93, 51.80), + (02,09,2005, 20.83, 51.60), + (05,09,2005, 20.46, 51.56), + (06,09,2005, 20.25, 50.60), + (07,09,2005, 20.55, 51.54), + (08,09,2005, 20.03, 50.55), + (09,09,2005, 20.19, 50.90), + (12,09,2005, 20.20, 51.27), + (13,09,2005, 20.47, 51.91), + (14,09,2005, 20.59, 51.59), + (15,09,2005, 20.70, 52.44), + (16,09,2005, 20.99, 53.77), + (19,09,2005, 21.39, 55.45), + (20,09,2005, 21.53, 55.88), + (21,09,2005, 20.89, 54.63), + (22,09,2005, 21.41, 55.50), + (23,09,2005, 21.30, 55.56), + (26,09,2005, 21.86, 57.55), + (27,09,2005, 22.01, 58.56), + (28,09,2005, 21.81, 58.26), + (29,09,2005, 22.48, 60.01), + (30,09,2005, 22.25, 59.14), + (03,10,2005, 22.30, 58.93), + (04,10,2005, 22.20, 58.61), + (05,10,2005, 21.45, 57.10), + (06,10,2005, 20.76, 56.30), + (07,10,2005, 20.47, 56.50), + (10,10,2005, 20.72, 57.25), + (11,10,2005, 20.33, 57.00), + (12,10,2005, 20.83, 57.48), + (13,10,2005, 20.47, 56.69), + (14,10,2005, 19.98, 55.21), + (17,10,2005, 20.05, 55.95), + (18,10,2005, 20.75, 57.90), + (19,10,2005, 20.05, 56.19), + (20,10,2005, 20.01, 56.30), + (21,10,2005, 20.03, 55.82), + (24,10,2005, 19.77, 54.27), + (25,10,2005, 20.09, 54.82), + (26,10,2005, 20.42, 55.58), + (27,10,2005, 20.49, 55.80), + (28,10,2005, 20.10, 54.94), + (31,10,2005, 20.75, 56.31), + (01,11,2005, 20.89, 57.00), + (02,11,2005, 20.70, 57.11), + (03,11,2005, 21.28, 58.39), + (04,11,2005, 21.35, 58.60), + (07,11,2005, 21.09, 58.18), + (08,11,2005, 21.35, 59.80), + (09,11,2005, 21.03, 59.25), + (10,11,2005, 21.11, 59.21), + (11,11,2005, 21.12, 59.71), + (14,11,2005, 21.60, 61.24), + (15,11,2005, 21.53, 60.96), + (16,11,2005, 21.42, 60.60), + (17,11,2005, 21.40, 60.79), + (18,11,2005, 21.85, 62.45), + (21,11,2005, 21.71, 62.60), + (22,11,2005, 21.67, 61.70), + (23,11,2005, 21.55, 60.70), + (24,11,2005, 21.86, 61.89), + (25,11,2005, 22.02, 62.21), + (28,11,2005, 22.22, 62.09), + (29,11,2005, 21.83, 61.35), + (30,11,2005, 21.87, 61.76), + (01,12,2005, 21.50, 60.40), + (02,12,2005, 21.95, 61.92), + (05,12,2005, 22.03, 63.33), + (06,12,2005, 21.83, 62.99), + (07,12,2005, 21.85, 63.84), + (08,12,2005, 21.56, 63.10), + (09,12,2005, 21.80, 63.55), + (12,12,2005, 21.92, 63.60), + (13,12,2005, 21.65, 63.35), + (14,12,2005, 21.72, 63.15), + (15,12,2005, 21.69, 63.16), + (16,12,2005, 21.60, 62.63), + (19,12,2005, 21.87, 63.81), + (20,12,2005, 22.10, 65.50), + (21,12,2005, 22.50, 67.18), + (22,12,2005, 22.49, 67.75), + (23,12,2005, 22.58, 68.50), + (28,12,2005, 22.59, 68.25), + (29,12,2005, 22.93, 69.10), + (30,12,2005, 22.75, 69.00), + (03,01,2006, 23.18, 69.90), + (04,01,2006, 23.85, 71.06), + (05,01,2006, 23.60, 69.80), + (06,01,2006, 23.35, 68.80), + (09,01,2006, 24.06, 70.18), + (10,01,2006, 23.85, 69.15), + (11,01,2006, 23.88, 69.35), + (12,01,2006, 23.80, 70.19), + (13,01,2006, 23.73, 70.50), + (16,01,2006, 23.74, 71.05), + (17,01,2006, 23.96, 71.94), + (18,01,2006, 23.73, 70.25), + (19,01,2006, 24.45, 72.50), + (20,01,2006, 24.66, 74.00), + (23,01,2006, 24.47, 73.25), + (24,01,2006, 24.84, 74.25), + (25,01,2006, 25.08, 73.96), + (27,01,2006, 26.05, 76.10), + (30,01,2006, 26.58, 78.45), + (31,01,2006, 25.80, 75.82), + (01,02,2006, 25.99, 75.21), + (02,02,2006, 25.50, 74.98), + (03,02,2006, 25.53, 74.75), + (06,02,2006, 25.85, 75.57), + (07,02,2006, 25.70, 75.06), + (08,02,2006, 24.37, 72.75), + (09,02,2006, 24.68, 72.77), + (13,02,2006, 23.88, 70.95), + (14,02,2006, 24.16, 72.37), + (15,02,2006, 24.35, 71.84), + (16,02,2006, 24.29, 71.89), + (17,02,2006, 23.88, 71.65), + (20,02,2006, 24.54, 74.90), + (21,02,2006, 24.98, 75.50), + (22,02,2006, 24.90, 73.24), + (23,02,2006, 25.28, 74.69), + (24,02,2006, 24.55, 72.20), + (27,02,2006, 24.66, 73.00), + (28,02,2006, 24.25, 71.20), + (01,03,2006, 24.03, 70.25), + (02,03,2006, 24.45, 70.50), + (03,03,2006, 24.34, 70.35), + (06,03,2006, 24.51, 70.85), + (08,03,2006, 23.60, 67.95), + (09,03,2006, 23.70, 68.65), + (10,03,2006, 23.37, 67.50), + (13,03,2006, 23.93, 70.36), + (14,03,2006, 23.64, 69.45), + (15,03,2006, 23.90, 69.40), + (16,03,2006, 24.46, 70.90), + (17,03,2006, 24.70, 71.25), + (20,03,2006, 25.24, 72.85), + (21,03,2006, 25.32, 73.08), + (22,03,2006, 25.18, 72.99), + (23,03,2006, 25.57, 74.34), + (24,03,2006, 25.92, 75.23), + (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) + ] diff --git a/tests/test.hs b/tests/test.hs new file mode 100644 --- /dev/null +++ b/tests/test.hs @@ -0,0 +1,196 @@ +import qualified Graphics.Rendering.Cairo as C +import Graphics.Rendering.Chart +import Graphics.Rendering.Chart.Gtk +import System.Environment(getArgs) +import System.Time +import System.Random +import Prices + +data OutputType = Window | PNG | PS | PDF + +chooseLineWidth Window = 1.0 +chooseLineWidth PNG = 1.0 +chooseLineWidth PDF = 0.25 +chooseLineWidth PS = 0.25 + +---------------------------------------------------------------------- +test1 :: OutputType -> IO Layout1 +test1 otype = return layout + where + am :: Double -> Double + am x = (sin (x*3.14159/45) + 1) / 2 * (sin (x*3.14159/5)) + + sinusoid1 = defaultPlotLines { + plot_lines_values = [[ (Point x (am x)) | x <- [0,(0.5)..400]]], + plot_lines_style = solidLine lineWidth 0 0 1 + } + + sinusoid2 = defaultPlotPoints { + plot_points_style=filledCircles 2 1 0 0, + plot_points_values = [ (Point x (am x)) | x <- [0,7..400]] + } + + layout = defaultLayout1 { + layout1_title="Amplitude Modulation", + layout1_horizontal_axes=linkedAxes (autoScaledAxis defaultAxis), + layout1_vertical_axes=linkedAxes (autoScaledAxis defaultAxis), + layout1_plots = [("am",HA_Bottom,VA_Left,(toPlot sinusoid1)), + ("am points", HA_Bottom,VA_Left,(toPlot sinusoid2))] + } + + lineWidth = chooseLineWidth otype + +---------------------------------------------------------------------- +test2 :: OutputType -> IO Layout1 +test2 otype = return layout + where + + price1 = defaultPlotLines { + plot_lines_style = solidLine lineWidth 0 0 1, + 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_values = [[ Point (date d m y) v | (d,m,y,_,v) <- prices]] + } + + gridlessAxis = defaultAxis{axis_grid=[]} + vaxis = autoScaledAxis gridlessAxis + + layout = defaultLayout1 { + layout1_title="Price History", + layout1_horizontal_axes=linkedAxes' (monthsAxis 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))] + } + + lineWidth = chooseLineWidth otype + +date dd mm yyyy = doubleFromClockTime ct + where + ct = toClockTime CalendarTime { + ctYear=yyyy, + ctMonth=toEnum (mm-1), + ctDay=dd, + ctHour=0, + ctMin=0, + ctSec=0, + ctPicosec=0, + ctTZ=0, + ctWDay=Monday, + ctYDay=0, + ctTZName="", + ctIsDST=False + } + +---------------------------------------------------------------------- +test3 :: OutputType -> IO Layout1 +test3 otype = return layout + where + + price1 = defaultPlotFillBetween { + plot_fillbetween_style = solidFillStyle 0.5 1 0.5, + 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_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_vertical_axes=linkedAxes' (autoScaledAxis defaultAxis), + layout1_plots = [("price 1", HA_Bottom,VA_Left,(toPlot price1)), + ("price 2", HA_Bottom,VA_Left,(toPlot price2))] + } + +---------------------------------------------------------------------- +test4 :: OutputType -> IO Layout1 +test4 otype = return layout + where + + points = defaultPlotPoints { + plot_points_style=filledCircles 3 1 0 0, + plot_points_values = [ Point x (10**x) | x <- [0.5,1,1.5,2,2.5] ] + } + + lines = defaultPlotLines { + plot_lines_values = [ [Point x (10**x) | x <- [0,3]] ] + } + + layout = defaultLayout1 { + layout1_title="Log/Linear Example", + layout1_horizontal_axes=linkedAxes (autoScaledAxis defaultAxis), + layout1_vertical_axes=linkedAxes (autoScaledLogAxis defaultAxis), + layout1_plots = [("values",HA_Bottom,VA_Left,(toPlot points)), + ("values",HA_Bottom,VA_Left,(toPlot lines)) ] + } + + +---------------------------------------------------------------------- +-- Example thanks to Russell O'Connor + +test5 :: OutputType -> IO Layout1 +test5 otype = do + bits <- fmap randoms getStdGen + return (layout 1001 (trial bits)) + where + layout n t = defaultLayout1 { + layout1_title="Simulation of betting on a biased coin", + layout1_horizontal_axes=linkedAxes (autoScaledAxis defaultAxis), + layout1_vertical_axes=linkedAxes (autoScaledLogAxis defaultAxis), + layout1_plots = [ + ("f=0.05",HA_Bottom,VA_Left,(toPlot (plot s1 n 0 (t 0.05)))), + ("f=0.1",HA_Bottom,VA_Left,(toPlot (plot s2 n 0 (t 0.1))))] + } + + plot s n m t = defaultPlotLines { + plot_lines_style = s, + plot_lines_values = + [[Point (fromIntegral x) y | (x,y) <- + filter (\(x,_)->x `mod` (m+1)==0) $ take n $ zip [0..] t]] + } + + 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 0 1 0 + s2 = solidLine lineWidth 0 0 1 + + lineWidth = chooseLineWidth otype + +---------------------------------------------------------------------- +allTests = + [ ("test1",test1) + , ("test2",test2) + , ("test3",test3) + , ("test4",test4) + , ("test5",test5) + ] + +main = do + args <- getArgs + main1 args + +main1 ("--png":tests) = showTests tests renderToPNG +main1 ("--pdf":tests) = showTests tests renderToPDF +main1 ("--ps":tests) = showTests tests renderToPS +main1 tests = showTests tests renderToWindow + +showTests tests outputfn = mapM_ outputfn (filter (match tests) allTests) + +match [] t = True +match ts t = (fst t) `elem` ts + +renderToWindow (n,t) = t Window >>= \l -> renderableToWindow (toRenderable l) 640 480 +renderToPNG (n,t) = t PNG >>= \l -> renderableToPNGFile (toRenderable l) 640 480 (n ++ ".png") +renderToPS (n,t) = t PS >>= \l -> renderableToPSFile (toRenderable l) 640 480 (n ++ ".png") +renderToPDF (n,t) = t PDF >>= \l -> renderableToPDFFile (toRenderable l) 640 480 (n ++ ".pdf")