packages feed

Chart 0.6 → 1.9.5

raw patch · 43 files changed

Files

Chart.cabal view
@@ -1,36 +1,78 @@ Name: Chart-Version: 0.6+Version: 1.9.5 License: BSD3 License-file: LICENSE-Copyright: Tim Docker, 2006+Copyright: Tim Docker, 2006-2014 Author: Tim Docker <tim@dockerz.net> Maintainer: Tim Docker <tim@dockerz.net>-Homepage: http://www.dockerz.net/software/chart.html+Homepage: https://github.com/timbod7/haskell-chart/wiki Synopsis: A library for generating 2D Charts and Plots-Description: A library for generating 2D Charts and Plots, based upon the cairo graphics library.+Description: A library for generating 2D Charts and Plots, with backends provided by+             Cairo (<http://hackage.haskell.org/package/Chart-cairo>)+             and+             Diagrams (<http://hackage.haskell.org/package/Chart-diagrams>).++             Documentation: https://github.com/timbod7/haskell-chart/wiki. Category: Graphics-Cabal-Version: >= 1.2+Cabal-Version: 1.18 Build-Type: Simple -Extra-Source-Files: tests/test.hs, tests/Prices.hs+library+  default-language: Haskell98+  Build-depends: base >= 3 && < 5+               , old-locale+               , time, array+               , lens >= 3.9 && < 5.3+               , colour >= 2.2.1 && < 2.4+               , data-default-class < 0.2+               , mtl >= 2.0 && < 2.4+               , operational >= 0.2.2 && < 0.3+               , vector >=0.9 && <0.14 -flag splitbase-  description: Choose the new smaller, split-up base package.+  if !impl(ghc >= 8.0)+    build-depends: semigroups >= 0.18.4 && <0.19 -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 +  Ghc-options: -Wall -fno-warn-orphans+   Exposed-modules:         Graphics.Rendering.Chart,-        Graphics.Rendering.Chart.Gtk,-        Graphics.Rendering.Chart.Types,+        Graphics.Rendering.Chart.Drawing,+        Graphics.Rendering.Chart.Geometry,+        Graphics.Rendering.Chart.Utils,         Graphics.Rendering.Chart.Renderable,         Graphics.Rendering.Chart.Axis,+        Graphics.Rendering.Chart.Axis.Floating,+        Graphics.Rendering.Chart.Axis.Indexed,+        Graphics.Rendering.Chart.Axis.Int,+        Graphics.Rendering.Chart.Axis.Time,+        Graphics.Rendering.Chart.Axis.LocalTime,+        Graphics.Rendering.Chart.Axis.Types,+        Graphics.Rendering.Chart.Axis.Unit,         Graphics.Rendering.Chart.Layout,-        Graphics.Rendering.Chart.Plot-        Graphics.Rendering.Chart.Simple-+        Graphics.Rendering.Chart.Legend,+        Graphics.Rendering.Chart.Grid,+        Graphics.Rendering.Chart.Plot,+        Graphics.Rendering.Chart.Plot.Types,+        Graphics.Rendering.Chart.Plot.Annotation,+        Graphics.Rendering.Chart.Plot.AreaSpots,+        Graphics.Rendering.Chart.Plot.Bars,+        Graphics.Rendering.Chart.Plot.Candle,+        Graphics.Rendering.Chart.Plot.ErrBars,+        Graphics.Rendering.Chart.Plot.FillBetween,+        Graphics.Rendering.Chart.Plot.Hidden,+        Graphics.Rendering.Chart.Plot.Lines,+        Graphics.Rendering.Chart.Plot.Vectors,+        Graphics.Rendering.Chart.Plot.Pie,+        Graphics.Rendering.Chart.Plot.Points,+        Graphics.Rendering.Chart.Plot.Histogram+        Graphics.Rendering.Chart.SparkLine+        Graphics.Rendering.Chart.Backend+        Graphics.Rendering.Chart.Backend.Impl+        Graphics.Rendering.Chart.Backend.Types+        Graphics.Rendering.Chart.Easy+        Graphics.Rendering.Chart.State+        Numeric.Histogram+source-repository head+  type:     git+  location: https://github.com/timbod7/haskell-chart
Graphics/Rendering/Chart.hs view
@@ -1,73 +1,61 @@------------------------------------------------------------------------------+---------------------------------------------------------------------------- -- | -- Module      :  Graphics.Rendering.Chart--- Copyright   :  (c) Tim Docker 2006+-- Copyright   :  (c) Tim Docker 2006-2013 -- License     :  BSD-style (see chart/COPYRIGHT) -- -- A 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'.+-- For the simplest API, see the "Graphics.Rendering.Chart.Easy"+-- module. ----- Currently, the only useful 'Renderable' for displaying charts--- is created by applying 'toRenderable' to a value of type--- 'Graphics.Rendering.Chart.Layout.Layout1'+-- When more control is required, understanding the various data types+-- is necessary. The basic model is that you define a value+-- representing a chart to be displayed (eg. a `Layout`), and then+-- convert it to a 'Renderable' by applying 'toRenderable'. This+-- 'Renderable' is then actually output by calling a function in an+-- appropriate graphics backend, eg 'renderableToFile'. ----- For a simpler though less flexible API, see "Graphics.Rendering.Chart.Simple".+-- Currently, there are three types of charts: --+--     * 'Layout' is a standard XY chart+-- +--     * 'LayoutLR' is an XY chart with independent left+--       and right axes+--+--     *  'PieLayout' is a pie chart+--+-- 'Layout' and 'LayoutLR' charts can be stacked vertically using+-- the 'StackedLayouts' type.+-- +-- 'Renderable's can be composed in arbitrary ways using the+-- "Graphics.Rendering.Chart.Grid" module.+--+-- Many of the record structure involved in the API have a large+-- number of fields. 'Lens'es are provided to access each field. Also,+-- for each record type, there is generally a default value, which can+-- be accessed through the 'def' value of the 'Default' typeclass.+-- -----------------------------------------------------------------------------  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,-    hollowCircles,-    exes, plusses, stars,-    filledPolygon,-    hollowPolygon,-    solidLine,-    dashedLine,-    solidFillStyle,-    fontStyle,-    independentAxes,-    linkedAxes,-    linkedAxes',-    explicitAxis,-    autoScaledAxis,-    autoScaledLogAxis,-    monthsAxis,-    renderableToPNGFile,-    renderableToPDFFile,-    renderableToPSFile,-    doubleFromClockTime,-    clockTimeFromDouble,-    CairoLineStyle(..),-    CairoFillStyle(..),-    CairoFontStyle(..)++    module Graphics.Rendering.Chart.Geometry,+    module Graphics.Rendering.Chart.Drawing,+    module Graphics.Rendering.Chart.Renderable,+    module Graphics.Rendering.Chart.Layout,+    module Graphics.Rendering.Chart.Axis,+    module Graphics.Rendering.Chart.Plot,+    module Graphics.Rendering.Chart.Legend,+    module Graphics.Rendering.Chart.Backend.Types+ ) where -import Graphics.Rendering.Chart.Types+import Graphics.Rendering.Chart.Geometry+import Graphics.Rendering.Chart.Drawing import Graphics.Rendering.Chart.Renderable import Graphics.Rendering.Chart.Layout import Graphics.Rendering.Chart.Axis import Graphics.Rendering.Chart.Plot+import Graphics.Rendering.Chart.Legend+import Graphics.Rendering.Chart.Backend.Types
Graphics/Rendering/Chart/Axis.hs view
@@ -3,435 +3,22 @@ -- 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 title string to be displayed on the axis. An-    -- empty string means no title.-    axis_title :: String,--    -- | 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_title_style :: CairoFontStyle,-    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 :: Rect -> AxisT -> C.Render ()-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-  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_title="",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_title = "",-    axis_ticks = [(0,10),(1,10)],-    axis_labels = [],-    axis_grid = [0.0,0.5,1.0],-    axis_label_gap = 10,-    axis_title_style = defaultFontStyle,-    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+--+-- Code to calculate and render axes.+-- -thisMonthStart ct = -    let calt = (toUTCTime ct) {-            ctDay=1,-	    ctHour=0,-	    ctMin=0,-	    ctSec=0,-	    ctPicosec=0-        } in-        toClockTime calt+module Graphics.Rendering.Chart.Axis(+    module Graphics.Rendering.Chart.Axis.Types,+    module Graphics.Rendering.Chart.Axis.Floating,+    module Graphics.Rendering.Chart.Axis.Int,+    module Graphics.Rendering.Chart.Axis.Time,+    module Graphics.Rendering.Chart.Axis.Unit,+    module Graphics.Rendering.Chart.Axis.Indexed,+) where -nextMonthStart ct =-    let month1 = noTimeDiff{tdMonth=1} in-	addToClockTime month1 (thisMonthStart ct)- +import Graphics.Rendering.Chart.Axis.Types+import Graphics.Rendering.Chart.Axis.Floating+import Graphics.Rendering.Chart.Axis.Int+import Graphics.Rendering.Chart.Axis.Time+import Graphics.Rendering.Chart.Axis.Unit+import Graphics.Rendering.Chart.Axis.Indexed
+ Graphics/Rendering/Chart/Axis/Floating.hs view
@@ -0,0 +1,340 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Graphics.Rendering.Chart.Axis.Floating+-- Copyright   :  (c) Tim Docker 2010, 2014+-- License     :  BSD-style (see chart/COPYRIGHT)+--+-- Calculate and render floating value axes+-- including doubles with linear, log, and percentage scaling.+--++{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Graphics.Rendering.Chart.Axis.Floating(+    Percent(..),+    LinearAxisParams(..),+    LogValue(..),+    LogAxisParams(..),+    scaledAxis,+    autoScaledAxis,+    autoScaledLogAxis,+    autoSteps,++    la_labelf,+    la_nLabels,+    la_nTicks,++    loga_labelf+) where++import Data.List(minimumBy, nub)+import Data.Ord (comparing)+import Data.Default.Class+import Numeric (showEFloat, showFFloat)++import Control.Lens+import Graphics.Rendering.Chart.Geometry+import Graphics.Rendering.Chart.Utils+import Graphics.Rendering.Chart.Axis.Types++-- Note: the following code uses explicit Integer types+-- to avoid -Wall 'defaulting to Integer' messages.++instance PlotValue Double where+    toValue  = id+    fromValue= id+    autoAxis = autoScaledAxis def++instance PlotValue Float where+    toValue  = realToFrac+    fromValue= realToFrac+    autoAxis = autoScaledAxis def++-- | A wrapper class for doubles used to indicate they are to+-- be plotted against a percentage axis.+newtype Percent = Percent {unPercent :: Double}+    deriving (Eq,Ord,Num,Real,Fractional,RealFrac,Floating,RealFloat)++instance Show Percent where+    show (Percent d) = showD (d*100) ++ "%"++instance PlotValue Percent where+    toValue  = unPercent+    fromValue= Percent+    autoAxis = autoScaledAxis def {-_la_labelf=-}++-- | A wrapper class for doubles used to indicate they are to+-- be plotted against a log axis.+newtype LogValue = LogValue {unLogValue :: Double}+    deriving (Eq, Ord, Num, Real, Fractional, RealFrac, Floating, RealFloat)++instance Show LogValue where+    show (LogValue x) = show x++instance PlotValue LogValue where+    toValue (LogValue x) = log x+    fromValue d          = LogValue (exp d)+    autoAxis             = autoScaledLogAxis def++-- | Show a list of axis labels.+-- If some are too big or all are too small, switch to scientific notation for all.+-- If the range is much smaller than the mean, use an offset.+-- TODO: show this offset only once, not on every label.+-- When thinking about improving this function,+-- https://github.com/matplotlib/matplotlib/blob/master/lib/matplotlib/ticker.py+-- is a good read.+--+-- >>> showDs [0, 1, 2 :: Double]+-- ["0","1","2"]+--+-- >>> showDs [0, 1000000, 2000000 :: Double]+-- ["0.0e0","1.0e6","2.0e6"]+--+-- >>> showDs [0, 0.001, 0.002 :: Double]+-- ["0","0.001","0.002"]+--+-- >>> showDs [-10000000, -1000000, 9000000 :: Double]+-- ["-1.0e7","-1.0e6","9.0e6"]+--+-- >>> showDs [10, 11, 12 :: Double]+-- ["10","11","12"]+--+-- >>> showDs [100, 101, 102 :: Double]+-- ["100","101","102"]+--+-- >>> showDs [100000, 100001, 100002 :: Double]+-- ["100000","100001","100002"]+--+-- >>> showDs [1000000, 1000001, 1000002 :: Double]+-- ["1.0e6 + 0","1.0e6 + 1","1.0e6 + 2"]+--+-- >>> showDs [10000000, 10000001, 10000002 :: Double]+-- ["1.0e7 + 0","1.0e7 + 1","1.0e7 + 2"]+--+-- >>> showDs [-10000000, -10000001, -10000002 :: Double]+-- ["-1.0e7 + 2","-1.0e7 + 1","-1.0e7 + 0"]+--+-- prop> let [s0, s1] = showDs [x, x + 1.0 :: Double] in s0 /= s1+showDs :: forall d . (RealFloat d) => [d] -> [String]+showDs xs = case showWithoutOffset xs of+  (s0:others)+    | anyEqualNeighbor s0 others -> map addShownOffset $ showWithoutOffset (map (\x -> x - offset) xs)+  s -> s+  where+    anyEqualNeighbor z0 (z1:others)+      | z0 == z1 = True+      | otherwise = anyEqualNeighbor z1 others+    anyEqualNeighbor _ [] = False++    -- Use the min for offset. Another good choice could be the mean.+    offset :: d+    offset = minimum xs+    shownOffset = case showWithoutOffset [offset] of+      [r] -> r+      rs -> error $ "showDs: shownOffset expected 1 element, got " ++ show (length rs)++    addShownOffset :: String -> String+    addShownOffset ('-':x) = shownOffset ++ " - " ++ x+    addShownOffset x = shownOffset ++ " + " ++ x++showWithoutOffset :: RealFloat d => [d] -> [String]+showWithoutOffset xs+  | useScientificNotation = map (showEFloat' (Just 1)) xs+  | otherwise = map showD xs+  where+    -- use scientific notation if max value is too big or too small+    useScientificNotation = maxAbs >= 1e6 || maxAbs <= 1e-6+    maxAbs = maximum (map abs xs)+++-- | Changes the behavior of showEFloat to drop more than one trailings 0.+-- Instead of 1.000e4 you get 1.0e4+showEFloat' :: forall d . RealFloat d => Maybe Int -> d -> String+showEFloat' mdigits x = reverse $ cleanup0 (reverse shown0)+  where+    shown0 = showEFloat mdigits x ""++    -- wait until we get the "e"+    cleanup0 :: String -> String+    cleanup0 (e@'e':ys) = e:cleanup1 ys+    cleanup0 (y:ys) = y : cleanup0 ys+    cleanup0 [] = reverse shown0 -- something went wrong, just return the original++    -- get rid of redundant 0s before the '.'+    cleanup1 :: String -> String+    cleanup1 ('0':ys@('0':_)) = cleanup1 ys+    cleanup1 y = y+++showD :: (RealFloat d) => d -> String+showD x = case reverse $ showFFloat Nothing x "" of+            '0':'.':r -> reverse r+            r         -> reverse r++data LinearAxisParams a = LinearAxisParams {+    -- | The function used to show the axes labels.+    _la_labelf  :: [a] -> [String],++    -- | The target number of labels to be shown.+    _la_nLabels :: Int,++    -- | The target number of ticks to be shown.+    _la_nTicks  :: Int+}++instance (Show a, RealFloat a) => Default (LinearAxisParams a) where+  def = LinearAxisParams+    { _la_labelf    = showDs+    , _la_nLabels   = 5+    , _la_nTicks    = 50+    }++-- | Generate a linear axis with the specified bounds+scaledAxis :: RealFloat a => LinearAxisParams a -> (a,a) -> AxisFn a+scaledAxis lap rs@(minV,maxV) ps0 = makeAxis' realToFrac realToFrac+                                         (_la_labelf lap) (labelvs,tickvs,gridvs)+  where+    ps        = filter isValidNumber ps0+    range []  = (0,1)+    range _   | minV == maxV = if minV==0 then (-1,1) else+                               let d = abs (minV * 0.01) in (minV-d,maxV+d)+              | otherwise    = rs+    labelvs   = map fromRational $ steps (fromIntegral (_la_nLabels lap)) r+    tickvs    = map fromRational $ steps (fromIntegral (_la_nTicks lap))+                                         (minimum labelvs,maximum labelvs)+    gridvs    = labelvs+    r         = range ps++-- | Generate a linear axis automatically, scaled appropriately for the+-- input data.+autoScaledAxis :: RealFloat a => LinearAxisParams a -> AxisFn a+autoScaledAxis lap ps0 = scaledAxis lap rs ps+  where+    ps = filter isValidNumber ps0+    rs = (minimum ps,maximum ps)++steps :: RealFloat a => a -> (a,a) -> [Rational]+steps nSteps rs@(minV,maxV) = map ((s*) . fromIntegral) [min' .. max']+  where+    s    = chooseStep nSteps rs+    min' :: Integer+    min' = floor   $ realToFrac minV / s+    max' = ceiling $ realToFrac maxV / s++chooseStep :: RealFloat a => a -> (a,a) -> Rational+chooseStep nsteps (x1,x2) = minimumBy (comparing proximity) stepVals+  where+    delta = x2 - x1+    mult  | delta == 0 = 1  -- Otherwise the case below will use all of memory+          | otherwise  = 10 ^^ ((floor $ log10 $ delta / nsteps)::Integer)+    stepVals = map (mult*) [0.1,0.2,0.25,0.5,1.0,2.0,2.5,5.0,10,20,25,50]+    proximity x = abs $ delta / realToFrac x - nsteps++-- | Given a target number of values, and a list of input points,+--   find evenly spaced values from the set {1*X, 2*X, 2.5*X, 5*X} (where+--   X is some power of ten) that evenly cover the input points.+autoSteps :: Int -> [Double] -> [Double]+autoSteps nSteps vs = map fromRational $ steps (fromIntegral nSteps) r+  where+    range []  = (0,1)+    range _   | minV == maxV = (minV-0.5,minV+0.5)+              | otherwise    = rs+    rs@(minV,maxV) = (minimum ps,maximum ps)+    ps        = filter isValidNumber vs+    r         = range ps++----------------------------------------------------------------------++instance (Show a, RealFloat a) => Default (LogAxisParams a) where+  def = LogAxisParams+    { _loga_labelf = showDs+    }++-- | Generate a log axis automatically, scaled appropriately for the+-- input data.+autoScaledLogAxis :: RealFloat a => LogAxisParams a -> AxisFn a+autoScaledLogAxis lap ps0 =+    makeAxis' (realToFrac . log) (realToFrac . exp)+              (_loga_labelf lap) (wrap rlabelvs, wrap rtickvs, wrap rlabelvs)+        where+          ps        = filter (\x -> isValidNumber x && 0 < x) ps0+          (minV,maxV) = (minimum ps,maximum ps)+          wrap      = map fromRational+          range []  = (3,30)+          range _   | minV == maxV = (realToFrac $ minV/3, realToFrac $ maxV*3)+                    | otherwise    = (realToFrac $ minV,   realToFrac $ maxV)+          (rlabelvs, rtickvs) = logTicks (range ps)+++data LogAxisParams a = LogAxisParams {+    -- | The function used to show the axes labels.+    _loga_labelf :: [a] -> [String]+}++{-+ Rules: Do not subdivide between powers of 10 until all powers of 10+          get major ticks.+        Do not subdivide between powers of ten as [1,2,4,6,8,10] when+          5 gets a major tick+          (i.e. the major ticks need to be a subset of the minor ticks)+-}+logTicks :: Range -> ([Rational],[Rational])+logTicks (low,high) = (nub major,nub minor)+ where+  pf :: RealFrac a => a -> (Integer, a)+  pf = properFraction++  -- frac :: (RealFrac a, Integral b) => a -> (b, a)+  frac :: (RealFrac a) => a -> (Integer, a)+  frac x | 0 <= b    = (a,b)+         | otherwise = (a-1,b+1)+    where+      (a,b) = properFraction x++  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) = pf (log10 a) in+               minimum (10:filter (\x -> r <= log10 (fromRational x)) l)*10^^i++  powers           :: (Double,Double) -> [Rational] -> [Rational]+  powers (x,y) l    = [ a*10^^p | p <- [(floor (log10 x))..(ceiling (log10 y))] :: [Integer]+                                , a <- l ]+  midselection r l  = filter (inRange r l) (powers r l)+  inRange (a,b) l x = (lower a l <= x) && (x <= upper b l)++  logRange = (log10 low, log10 high)++  roundPow x = 10^^(round x :: Integer)++  major | 17.5 < log10 ratio = map roundPow $+                               steps (min 5 (log10 ratio)) logRange+        | 12 < log10 ratio   = map roundPow $+                               steps (log10 ratio / 5) logRange+        | 6 < log10 ratio    = map roundPow $+                               steps (log10 ratio / 2) logRange+        | 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' :: Double+  ratio' = fromRational (h'/l')+  filterX = filter (\x -> l'<=x && x <=h') . powers (dl',dh')++  minor | 50 < log10 ratio' = map roundPow $+                              steps 50 (log10 dl', log10 dh')+        | 6 < log10 ratio'  = filterX [1,10]+        | 4 < log10 ratio'  = filterX [1,5,10]+        | 6 < ratio'        = filterX [1..10]+        | 3 < ratio'        = filterX [1,1.2..10]+        | otherwise         = steps 50 (dl', dh')++$( makeLenses ''LinearAxisParams )+$( makeLenses ''LogAxisParams )
+ Graphics/Rendering/Chart/Axis/Indexed.hs view
@@ -0,0 +1,57 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Graphics.Rendering.Chart.Axis.Unit+-- Copyright   :  (c) Tim Docker 2010, 2014+-- License     :  BSD-style (see chart/COPYRIGHT)+--+-- Calculate and render indexed axes++{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TupleSections #-}++module Graphics.Rendering.Chart.Axis.Indexed(+    PlotIndex(..),+    autoIndexAxis',+    autoIndexAxis,+    addIndexes,+) where++import Data.Default.Class++import Graphics.Rendering.Chart.Axis.Types++-- | Type for capturing values plotted by index number+--   (ie position in a list) rather than a numerical value.+newtype PlotIndex = PlotIndex { plotindex_i :: Int }+  deriving (Eq,Ord,Enum,Num,Real,Integral,Show)++instance PlotValue PlotIndex where+    toValue (PlotIndex i) = fromIntegral i+    fromValue             = PlotIndex . round+    autoAxis              = autoIndexAxis []++-- | Augment a list of values with index numbers for plotting.+addIndexes :: [a] -> [(PlotIndex,a)]+addIndexes = zipWith (\n x -> (PlotIndex n, x)) [0..]++-- | Create an axis for values indexed by position. The+--   list of strings are the labels to be used.+autoIndexAxis' :: Integral i => Bool -> [String] -> AxisFn i+autoIndexAxis' tks labels vs = AxisData {+    _axis_visibility = def { _axis_show_ticks = False },+    _axis_viewport = vport,+    _axis_tropweiv = invport,+    _axis_ticks    = if tks then map (, 5) $ take (length labels) [0..] else [],+    _axis_labels   = [filter (\(i,_) -> i >= imin && i <= imax)+                             (zip [0..] labels)],+    _axis_grid     = []+    }+  where+    vport r i = linMap id ( fromIntegral imin - 0.5+                          , fromIntegral imax + 0.5) r (fromIntegral i)+    invport = invLinMap round fromIntegral (imin, imax)+    imin = minimum vs+    imax = maximum vs++autoIndexAxis :: Integral i => [String] -> AxisFn i+autoIndexAxis = autoIndexAxis' False
+ Graphics/Rendering/Chart/Axis/Int.hs view
@@ -0,0 +1,133 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Graphics.Rendering.Chart.Axis.Int+-- Copyright   :  (c) Tim Docker 2010, 2014+-- License     :  BSD-style (see chart/COPYRIGHT)+--+-- Calculate and render integer indexed axes+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Graphics.Rendering.Chart.Axis.Int(+    defaultIntAxis,+    scaledIntAxis,+    autoScaledIntAxis+) where++import Data.List(genericLength)+import Data.Int (Int8, Int16, Int32, Int64)+import Data.Word (Word8, Word16, Word32, Word64)+import Graphics.Rendering.Chart.Geometry+import Graphics.Rendering.Chart.Axis.Types+import Graphics.Rendering.Chart.Axis.Floating++instance PlotValue Int where+    toValue    = fromIntegral+    fromValue  = round+    autoAxis   = autoScaledIntAxis defaultIntAxis++instance PlotValue Int8 where+    toValue    = fromIntegral+    fromValue  = round+    autoAxis   = autoScaledIntAxis defaultIntAxis++instance PlotValue Int16 where+    toValue    = fromIntegral+    fromValue  = round+    autoAxis   = autoScaledIntAxis defaultIntAxis++instance PlotValue Int32 where+    toValue    = fromIntegral+    fromValue  = round+    autoAxis   = autoScaledIntAxis defaultIntAxis++instance PlotValue Int64 where+    toValue    = fromIntegral+    fromValue  = round+    autoAxis   = autoScaledIntAxis defaultIntAxis++instance PlotValue Word where+    toValue    = fromIntegral+    fromValue  = round+    autoAxis   = autoScaledIntAxis defaultIntAxis++instance PlotValue Word8 where+    toValue    = fromIntegral+    fromValue  = round+    autoAxis   = autoScaledIntAxis defaultIntAxis++instance PlotValue Word16 where+    toValue    = fromIntegral+    fromValue  = round+    autoAxis   = autoScaledIntAxis defaultIntAxis++instance PlotValue Word32 where+    toValue    = fromIntegral+    fromValue  = round+    autoAxis   = autoScaledIntAxis defaultIntAxis++instance PlotValue Word64 where+    toValue    = fromIntegral+    fromValue  = round+    autoAxis   = autoScaledIntAxis defaultIntAxis++instance PlotValue Integer where+    toValue    = fromIntegral+    fromValue  = round+    autoAxis   = autoScaledIntAxis defaultIntAxis++defaultIntAxis :: (Show a) => LinearAxisParams a+defaultIntAxis  = LinearAxisParams {+    _la_labelf  = map show,+    _la_nLabels = 5,+    _la_nTicks  = 10+}++autoScaledIntAxis :: (Integral i, PlotValue i) =>+                     LinearAxisParams i -> AxisFn i+autoScaledIntAxis lap ps = scaledIntAxis lap rs ps+  where+    rs = (minimum ps,maximum ps)++scaledIntAxis :: (Integral i, PlotValue i) =>+                 LinearAxisParams i -> (i,i) -> AxisFn i+scaledIntAxis lap (minI,maxI) ps =+    makeAxis (_la_labelf lap) (labelvs,tickvs,gridvs)+  where+    range []  = (0,1)+    range _   | minI == maxI = (fromIntegral $ minI-1, fromIntegral $ minI+1)+              | otherwise    = (fromIntegral   minI,   fromIntegral   maxI)+--  labelvs  :: [i]+    labelvs   = stepsInt (fromIntegral $ _la_nLabels lap) r+    tickvs    = stepsInt (fromIntegral $ _la_nTicks lap)+                                  ( fromIntegral $ minimum labelvs+                                  , fromIntegral $ maximum labelvs )+    gridvs    = labelvs+    r         = range ps++stepsInt :: Integral a => a -> Range -> [a]+stepsInt nSteps range = bestSize (goodness alt0) alt0 alts+  where+    bestSize n a (a':as) = let n' = goodness a' in+                           if n' < n then bestSize n' a' as else a+    bestSize _ _ []      = []++    goodness vs          = abs (genericLength vs - nSteps)++    (alt0:alts)          = map (\n -> steps n range) sampleSteps'++    -- throw away sampleSteps that are definitely too small as+    -- they takes a long time to process                           +    sampleSteps'         = let rangeMag = ceiling (snd range - fst range)+                               +                               (s1,s2) = span (< (rangeMag `div` nSteps)) sampleSteps+                           in ((reverse . take 5 . reverse) s1) ++ s2++    -- generate all possible step sizes+    sampleSteps          = [1,2,5] ++ sampleSteps1+    sampleSteps1         = [10,20,25,50] ++ map (*10) sampleSteps1++    steps size (minV,maxV) = takeWhile (<b) [a,a+size..] ++ [b]+      where+        a = (floor   (minV / fromIntegral size)) * size+        b = (ceiling (maxV / fromIntegral size)) * size+
+ Graphics/Rendering/Chart/Axis/LocalTime.hs view
@@ -0,0 +1,286 @@+{-# LANGUAGE CPP #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Graphics.Rendering.Chart.Axis.LocalTime+-- Copyright   :  (c) Tim Docker 2010, 2014+-- License     :  BSD-style (see chart/COPYRIGHT)+--+-- Calculate and render time axes++module Graphics.Rendering.Chart.Axis.LocalTime+    {-# DEPRECATED "Use Graphics.Rendering.Chart.Axis.Time module" #-}+    (+    TimeSeq,+    TimeLabelFn,+    TimeLabelAlignment(..),++    timeAxis,+    autoTimeAxis,++    days, months, years,++    -- * Utilities+    doubleFromLocalTime++    )+    where++import Data.Default.Class+#if MIN_VERSION_time(1,5,0)+import Data.Time hiding (months)+#else+import Data.Time+import System.Locale (defaultTimeLocale)+#endif+import Data.Fixed+import Control.Lens++import Graphics.Rendering.Chart.Axis.Types+import Graphics.Rendering.Chart.Axis.Time ()++----------------------------------------------------------------------++-- | Map a LocalTime value to a plot coordinate.+doubleFromLocalTime :: LocalTime -> Double+doubleFromLocalTime lt = fromIntegral (toModifiedJulianDay (localDay lt))+              + fromRational (timeOfDayToDayFraction (localTimeOfDay lt))++-- | Map a plot coordinate to a LocalTime.+localTimeFromDouble :: Double -> LocalTime+localTimeFromDouble v =+  LocalTime (ModifiedJulianDay i) (dayFractionToTimeOfDay (toRational d))+ where+   (i,d) = properFraction v++-- | TimeSeq is a (potentially infinite) set of times. When passed+--   a reference time, the function returns a a pair of lists. The first+--   contains all times in the set less than the reference time in+--   decreasing order. The second contains all times in the set greater+--   than or equal to the reference time, in increasing order.+type TimeSeq = LocalTime-> ([LocalTime],[LocalTime])++coverTS :: TimeSeq -> LocalTime -> LocalTime -> [LocalTime]+coverTS tseq minT maxT = min' ++ enumerateTS tseq minT maxT ++ max'+  where+    min' =  if elemTS minT tseq then [] else take 1 (fst (tseq minT))+    max' =  if elemTS maxT tseq then [] else take 1 (snd (tseq maxT))++enumerateTS :: TimeSeq -> LocalTime -> LocalTime -> [LocalTime]+enumerateTS tseq minT maxT =+    reverse (takeWhile (>=minT) ts1)  ++ takeWhile (<=maxT) ts2+  where+    (ts1,ts2) = tseq minT++elemTS :: LocalTime -> TimeSeq -> Bool+elemTS t tseq = case tseq t of+    (_,t0:_) | t == t0 -> True+    _                  -> False++-- | How to display a time+type TimeLabelFn = LocalTime -> String++data TimeLabelAlignment = UnderTicks+                        | BetweenTicks+                        deriving (Show)++-- | Create an 'AxisFn' to for a time axis.+--+--   The values to be plotted against this axis can be created with+--   'doubleFromLocalTime'.+timeAxis ::+  TimeSeq+  -- ^ Set the minor ticks, and the final range will be aligned to its+  --   elements.+  -> TimeSeq+  -- ^ Set the labels and grid.+  -> TimeLabelFn+  -> TimeLabelAlignment+  -> TimeSeq+  -- ^ Set the second line of labels.+  -> TimeLabelFn+  -- ^ Format `LocalTime` for labels.+  -> TimeLabelAlignment+  -> AxisFn LocalTime+timeAxis tseq lseq labelf lal cseq contextf clal pts = AxisData {+    _axis_visibility = def,+    _axis_viewport = vmap(min', max'),+    _axis_tropweiv = invmap(min', max'),+    _axis_ticks    = [ (t,2) | t <- times] ++ [ (t,5) | t <- ltimes, visible t],+    _axis_labels   = [ [ (t,l) | (t,l) <- labels labelf   ltimes lal, visible t]+                     , [ (t,l) | (t,l) <- labels contextf ctimes clal, visible t]+                     ],+    _axis_grid     = [ t     | t <- ltimes, visible t]+    }+  where+    (minT,maxT)  = case pts of+                       [] -> (refLocalTime,refLocalTime)+                       ps -> (minimum ps, maximum ps)+    refLocalTime = LocalTime (ModifiedJulianDay 0) midnight+    times        = coverTS tseq minT maxT+    ltimes       = coverTS lseq minT maxT+    ctimes       = coverTS cseq minT maxT+    min'         = minimum times+    max'         = maximum times+    visible t    = min' <= t && t <= max'+    labels f ts lal' =+        [ (align lal' m1' m2', f m1)+          | (m1,m2) <- zip ts (tail ts)+          , let m1' = if m1<min' then min' else m1+          , let m2' = if m2>max' then max' else m2 ]++    align BetweenTicks m1 m2 = avg m1 m2+    align UnderTicks   m1 _  = m1++    avg m1 m2    = localTimeFromDouble $ m1' + (m2' - m1')/2+     where+      m1' = doubleFromLocalTime m1+      m2' = doubleFromLocalTime m2++normalizeTimeOfDay :: LocalTime -> LocalTime+normalizeTimeOfDay t@(LocalTime day (TimeOfDay h m s))+  | s <  0    = normalizeTimeOfDay (LocalTime day (TimeOfDay h (m-1) (s+60)))+  | m <  0    = normalizeTimeOfDay (LocalTime day (TimeOfDay (h-1) (m+60) s))+  | h <  0    = normalizeTimeOfDay (LocalTime (addDays (-1) day) (TimeOfDay (h+24) m s))+  | s >= 60   = normalizeTimeOfDay (LocalTime day (TimeOfDay h (m+s`div'`60)+                                                               (s`mod'`60)))+  | m >= 60   = normalizeTimeOfDay (LocalTime day (TimeOfDay (h+m`div`60)+                                                             (m`mod`60) s))+  | h >= 24   = LocalTime (addDays (fromIntegral (h`div`24)) day)+                          (TimeOfDay (h`mod`24) m s)+  | otherwise = t++addTod :: Int -> Int -> Pico -> LocalTime -> LocalTime+addTod dh dm ds (LocalTime day (TimeOfDay h m s)) = normalizeTimeOfDay t'+  where t' = LocalTime day (TimeOfDay (h+dh) (m+dm) (s+ds))++truncateTo :: (HasResolution a) => Fixed a -> Fixed a -> Fixed a+truncateTo t step = t - t `mod'` step++secondSeq :: Pico -> TimeSeq+secondSeq step t = (iterate rev t1, tail (iterate fwd t1))+  where h0       = todHour (localTimeOfDay t)+        m0       = todMin  (localTimeOfDay t)+        s0       = todSec  (localTimeOfDay t) `truncateTo` (1 / 1000)+        t0       = LocalTime (localDay t) (TimeOfDay h0 m0 s0)+        t1       = if t0 < t then t0 else rev t0+        rev      = addTod 0 0 (negate step)+        fwd      = addTod 0 0 step++millis1, millis10, millis100, seconds, fiveSeconds  :: TimeSeq+millis1 = secondSeq (1 / 1000)+millis10 = secondSeq (1 / 100)+millis100 = secondSeq (1 / 10)+seconds = secondSeq 1+fiveSeconds = secondSeq 5++minuteSeq :: Int -> TimeSeq+minuteSeq step t = (iterate rev t1, tail (iterate fwd t1))+  where h0       = todHour (localTimeOfDay t)+        m0       = todMin  (localTimeOfDay t)+        t0       = LocalTime (localDay t) (TimeOfDay h0 m0 0)+        t1       = if t0 < t then t0 else rev t0+        rev      = addTod 0 (negate step) 0+        fwd      = addTod 0 step 0++minutes, fiveMinutes :: TimeSeq+minutes = minuteSeq 1+fiveMinutes = minuteSeq 5++-- | A 'TimeSeq' for hours.+hours :: TimeSeq+hours t = (iterate rev t1, tail (iterate fwd t1))+  where h0       = todHour (localTimeOfDay t)+        t0       = LocalTime (localDay t) (TimeOfDay h0 0 0)+        t1       = if t0 < t then t0 else rev t0+        rev      = addTod (-1) 0 0+        fwd      = addTod 1    0 0++-- | A 'TimeSeq' for calendar days.+days :: TimeSeq+days t = (map toTime $ iterate rev t1, map toTime $ tail (iterate fwd t1))+  where t0       = localDay t+        t1       = if toTime t0 < t then t0 else rev t0+        rev      = pred+        fwd      = succ+        toTime d = LocalTime d midnight++-- | A 'TimeSeq' for calendar months.+months :: TimeSeq+months t = (map toTime $ iterate rev t1, map toTime $ tail (iterate fwd t1))+  where t0       = let (y,m,_) = toGregorian $ localDay t in fromGregorian y m 1+        t1       = if toTime t0 < t then t0 else rev t0+        rev      = addGregorianMonthsClip (-1)+        fwd      = addGregorianMonthsClip 1+        toTime d = LocalTime d midnight++-- | A 'TimeSeq' for calendar years.+years :: TimeSeq+years t = (map toTime $ iterate rev t1, map toTime $ tail (iterate fwd t1))+  where t0       = toGregorian (localDay t) ^. _1+        t1       = if toTime t0 < t then t0 else rev t0+        rev      = pred+        fwd      = succ+        toTime y = LocalTime (fromGregorian y 1 1) midnight++-- | A 'TimeSeq' for no sequence at all.+noTime :: TimeSeq+noTime _ = ([],[])++-- | Automatically choose a suitable time axis, based upon the time range+--   of data.  The values to be plotted against this axis can be created+--   with 'doubleFromLocalTime'.+autoTimeAxis :: AxisFn LocalTime+autoTimeAxis pts+    | null pts              = timeAxis days    days    (ft "%d-%b-%y") UnderTicks+                                               noTime  (ft "") UnderTicks []+    | tdiff==0 && 100*dsec<1= timeAxis millis1   millis1  (ft "%S%Q") UnderTicks+                                                 noTime (ft "%S%Q") UnderTicks pts+    | tdiff==0 && 10*dsec<1 = timeAxis millis10  millis10  (ft "%S%Q") UnderTicks+                                                 noTime (ft "%S%Q") UnderTicks pts+    | tdiff==0 && dsec<1    = timeAxis millis10  millis100 (ft "%S%Q") UnderTicks+                                                 seconds (ft "%M:%S") BetweenTicks pts+    | tdiff==0 && dsec<5    = timeAxis millis100 seconds (ft "%M:%S%Q") UnderTicks+                                                 seconds (ft "%M:%S") BetweenTicks pts+    | tdiff==0 && dsec<32   = timeAxis seconds seconds (ft "%Ss") UnderTicks+                                               minutes (ft "%d-%b-%y %H:%M") BetweenTicks pts+    | tdiff==0 && dsec<120  = timeAxis seconds fiveSeconds (ft "%Ss") UnderTicks+                                               minutes (ft "%d-%b-%y %H:%M") BetweenTicks pts+    | tdiff==0 && dmin<7    = timeAxis fiveSeconds minutes (ft "%Mm") UnderTicks+                                               hours   (ft "%d-%b-%y %H:00") BetweenTicks pts+    | tdiff==0 && dmin<32   = timeAxis minutes minutes (ft "%Mm") UnderTicks+                                               hours   (ft "%d-%b-%y %H:00") BetweenTicks pts+    | tdiff==0 && dmin<90   = timeAxis minutes fiveMinutes (ft "%Mm") UnderTicks+                                               hours   (ft "%d-%b-%y %H:00") BetweenTicks pts+    | tdiff < 2 && dhour<4  = timeAxis fiveMinutes hours (ft "%H:%M") UnderTicks+                                                   days  (ft "%d-%b-%y") BetweenTicks pts+    | tdiff < 2 && dhour<32 = timeAxis hours  hours  (ft "%H:%M") UnderTicks+                                              days   (ft "%d-%b-%y") BetweenTicks pts+    | tdiff < 4             = timeAxis hours  days   (ft "%d-%b-%y") BetweenTicks+                                              noTime (ft "") BetweenTicks pts+    | tdiff < 12            = timeAxis days   days   (ft "%d-%b") BetweenTicks+                                              years  (ft "%Y") BetweenTicks pts+    | tdiff < 45            = timeAxis days   days   (ft "%d") BetweenTicks+                                              months (ft "%b-%y") BetweenTicks pts+    | tdiff < 95            = timeAxis days   months (ft "%b-%y") BetweenTicks+                                              noTime (ft "") BetweenTicks pts+    | tdiff < 450           = timeAxis months months (ft "%b-%y") BetweenTicks+                                              noTime (ft "") BetweenTicks pts+    | tdiff < 735           = timeAxis months months (ft "%b") BetweenTicks+                                              years  (ft "%Y") BetweenTicks pts+    | tdiff < 1800          = timeAxis months years (ft "%Y") BetweenTicks+                                              noTime (ft "") BetweenTicks pts+    | otherwise             = timeAxis years  years (ft "%Y") BetweenTicks+                                              noTime (ft "") BetweenTicks pts+  where+    tdiff = diffDays (localDay t1) (localDay t0)+    dhour = if tdiff==0 then h1-h0 else 24*fromIntegral tdiff +h1-h0+    dmin  = 60*dhour+(m1-m0)+    dsec  = fromIntegral (60*dmin) + (s1-s0)+    (TimeOfDay h0 m0 s0) = localTimeOfDay t0+    (TimeOfDay h1 m1 s1) = localTimeOfDay t1+    t1    = maximum pts+    t0    = minimum pts+    ft    = formatTime defaultTimeLocale++
+ Graphics/Rendering/Chart/Axis/Time.hs view
@@ -0,0 +1,316 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Graphics.Rendering.Chart.Axis.Time+-- Copyright   :  (c) Tim Docker 2010, 2014+-- License     :  BSD-style (see chart/COPYRIGHT)+--+-- Calculate and render time axes++module Graphics.Rendering.Chart.Axis.Time(+    TimeSeq,+    TimeLabelFn,+    TimeLabelAlignment(..),++    TimeValue (..),++    timeValueAxis,+    autoTimeValueAxis,++    days, months, years,++    ) where++import Data.Default.Class+#if MIN_VERSION_time(1,5,0)+import Data.Time hiding (months)+#else+import Data.Time+import System.Locale (defaultTimeLocale)+#endif+import Data.Fixed+import Control.Lens++import Graphics.Rendering.Chart.Axis.Types+import Graphics.Rendering.Chart.Geometry (Range)++-- | A typeclass abstracting the functions we need+-- to be able to plot against an axis of time type @d@.+class TimeValue t where+    utctimeFromTV :: t -> UTCTime+    tvFromUTCTime :: UTCTime -> t++    {-# MINIMAL utctimeFromTV, tvFromUTCTime #-}++    doubleFromTimeValue  :: t -> Double+    doubleFromTimeValue = doubleFromTimeValue . utctimeFromTV++    timeValueFromDouble  :: Double -> t+    timeValueFromDouble = tvFromUTCTime . timeValueFromDouble++instance TimeValue UTCTime where+    utctimeFromTV       = id+    tvFromUTCTime       = id+    doubleFromTimeValue = doubleFromUTCTime+    timeValueFromDouble = utcTimeFromDouble++instance TimeValue Day where+    utctimeFromTV d     = UTCTime d 0+    tvFromUTCTime       = utctDay+    doubleFromTimeValue = doubleFromDay+    timeValueFromDouble = dayFromDouble++instance TimeValue LocalTime where+    utctimeFromTV (LocalTime d tod) = UTCTime d (timeOfDayToTime tod)+    tvFromUTCTime (UTCTime d dt)    = LocalTime d (timeToTimeOfDay dt)++----------------------------------------------------------------------++instance PlotValue LocalTime where+    toValue    = doubleFromTimeValue+    fromValue  = timeValueFromDouble+    autoAxis   = autoTimeValueAxis++instance PlotValue UTCTime where+    toValue    = doubleFromTimeValue+    fromValue  = timeValueFromDouble+    autoAxis   = autoTimeValueAxis++instance PlotValue Day where+    toValue    = doubleFromTimeValue+    fromValue  = timeValueFromDouble+    autoAxis   = autoTimeValueAxis++----------------------------------------------------------------------++-- | Map a UTCTime value to a plot coordinate.+doubleFromUTCTime :: UTCTime -> Double+doubleFromUTCTime ut = fromIntegral (toModifiedJulianDay (utctDay ut))+              + fromRational (timeOfDayToDayFraction (timeToTimeOfDay (utctDayTime ut)))++-- | Map a plot coordinate to a UTCTime.+utcTimeFromDouble :: Double -> UTCTime+utcTimeFromDouble v =+  UTCTime (ModifiedJulianDay i) (timeOfDayToTime (dayFractionToTimeOfDay (toRational d)))+ where+   (i,d) = properFraction v++-- | Map a Day value to a plot coordinate.+doubleFromDay :: Day -> Double+doubleFromDay d = fromIntegral (toModifiedJulianDay d)++-- | Map a plot coordinate to a Day.+dayFromDouble :: Double -> Day+dayFromDouble v = ModifiedJulianDay (truncate v)++----------------------------------------------------------------------++-- | TimeSeq is a (potentially infinite) set of times. When passed+--   a reference time, the function returns a a pair of lists. The first+--   contains all times in the set less than the reference time in+--   decreasing order. The second contains all times in the set greater+--   than or equal to the reference time, in increasing order.+type TimeSeq = UTCTime -> ([UTCTime],[UTCTime])++coverTS :: TimeSeq -> UTCTime -> UTCTime -> [UTCTime]+coverTS tseq minT maxT = min' ++ enumerateTS tseq minT maxT ++ max'+  where+    min' =  if elemTS minT tseq then [] else take 1 (fst (tseq minT))+    max' =  if elemTS maxT tseq then [] else take 1 (snd (tseq maxT))++enumerateTS :: TimeSeq -> UTCTime -> UTCTime -> [UTCTime]+enumerateTS tseq minT maxT =+    reverse (takeWhile (>=minT) ts1)  ++ takeWhile (<=maxT) ts2+  where+    (ts1,ts2) = tseq minT++elemTS :: UTCTime -> TimeSeq -> Bool+elemTS t tseq = case tseq t of+    (_,t0:_) | t == t0 -> True+    _                  -> False++-- | How to display a time+type TimeLabelFn = UTCTime -> String++data TimeLabelAlignment = UnderTicks+                        | BetweenTicks+                        deriving (Show)++-- | Create an 'AxisFn' to for a time axis.+--+--   The values to be plotted against this axis can be created with+--   'doubleFromLocalTime'.+--+--   Implementation detail: 'PlotValue' constraint is needed to use `vmap`.+timeValueAxis ::+  TimeValue t+  => TimeSeq+  -- ^ Set the minor ticks, and the final range will be aligned to its+  --   elements.+  -> TimeSeq+  -- ^ Set the labels and grid.+  -> TimeLabelFn+  -> TimeLabelAlignment+  -> TimeSeq+  -- ^ Set the second line of labels.+  -> TimeLabelFn+  -- ^ Format @t@ for labels.+  -> TimeLabelAlignment+  -> AxisFn t+timeValueAxis tseq lseq labelf lal cseq contextf clal pts = AxisData {+    _axis_visibility = def,+    _axis_viewport = vmap' (tvFromUTCTime min', tvFromUTCTime max'),+    _axis_tropweiv = invmap' (tvFromUTCTime min', tvFromUTCTime max'),+    _axis_ticks    = [ (tvFromUTCTime t,2) | t <- times] ++ [ (tvFromUTCTime t,5) | t <- ltimes, visible t],+    _axis_labels   = [ [ (tvFromUTCTime t,l) | (t,l) <- labels labelf   ltimes lal, visible t]+                     , [ (tvFromUTCTime t,l) | (t,l) <- labels contextf ctimes clal, visible t]+                     ],+    _axis_grid     = [ tvFromUTCTime t     | t <- ltimes, visible t]+    }+  where+    (minT,maxT)  = case pts of+                       [] -> (refTimeValue,refTimeValue)+                       ps -> (minimum (map utctimeFromTV ps), maximum (map utctimeFromTV ps))+    refTimeValue = timeValueFromDouble 0++    times, ltimes, ctimes :: [UTCTime]+    times        = coverTS tseq minT maxT+    ltimes       = coverTS lseq minT maxT+    ctimes       = coverTS cseq minT maxT+    min'         = minimum times+    max'         = maximum times+    visible t    = min' <= t && t <= max'+    labels f ts lal' =+        [ (align lal' m1' m2', f m1)+          | (m1,m2) <- zip ts (tail ts)+          , let m1' = if m1<min' then min' else m1+          , let m2' = if m2>max' then max' else m2 ]++    align BetweenTicks m1 m2 = avg m1 m2+    align UnderTicks   m1 _  = m1++    avg m1 m2    = timeValueFromDouble $ m1' + (m2' - m1')/2+     where+      m1' = doubleFromTimeValue m1+      m2' = doubleFromTimeValue m2++vmap' :: TimeValue x => (x,x) -> Range -> x -> Double+vmap' (v1,v2) (v3,v4) v = v3 + (doubleFromTimeValue v - doubleFromTimeValue v1) * (v4-v3)+                              / (doubleFromTimeValue v2 - doubleFromTimeValue v1)++invmap' :: TimeValue x => (x,x) -> Range -> Double -> x+invmap' (v3,v4) (d1,d2) d = timeValueFromDouble (doubleFromTimeValue v3 + ( (d-d1) * doubleRange+                                                   / (d2-d1) ))+    where doubleRange = doubleFromTimeValue v4 - doubleFromTimeValue v3++truncateTo :: Real a => a -> a -> a+truncateTo t step = t - t `mod'` step++secondSeq :: NominalDiffTime -> TimeSeq+secondSeq step t@(UTCTime day dt) = (iterate rev t1, tail (iterate fwd t1))+  where t0       = UTCTime day (truncateTo dt step')+        t1       = if t0 < t then t0 else rev t0+        rev      = addUTCTime (negate step)+        fwd      = addUTCTime step+        step'    = realToFrac step++millis1, millis10, millis100, seconds, fiveSeconds :: TimeSeq+millis1 = secondSeq (1 / 1000)+millis10 = secondSeq (1 / 100)+millis100 = secondSeq (1 / 10)+seconds = secondSeq 1+fiveSeconds = secondSeq 5++minutes, fiveMinutes :: TimeSeq+minutes = secondSeq 60+fiveMinutes = secondSeq (5 * 60)++-- | A 'TimeSeq' for hours.+hours :: TimeSeq+hours = secondSeq (60 * 60)++-- | A 'TimeSeq' for calendar days.+days :: TimeSeq+days t = (map toTime $ iterate rev t1, map toTime $ tail (iterate fwd t1))+  where t0       = utctDay t+        t1       = if toTime t0 < t then t0 else rev t0+        rev      = pred+        fwd      = succ+        toTime d = UTCTime d 0++-- | A 'TimeSeq' for calendar months.+months :: TimeSeq+months t = (map toTime $ iterate rev t1, map toTime $ tail (iterate fwd t1))+  where t0       = let (y,m,_) = toGregorian $ utctDay t in fromGregorian y m 1+        t1       = if toTime t0 < t then t0 else rev t0+        rev      = addGregorianMonthsClip (-1)+        fwd      = addGregorianMonthsClip 1+        toTime d = UTCTime d 0++-- | A 'TimeSeq' for calendar years.+years :: TimeSeq+years t = (map toTime $ iterate rev t1, map toTime $ tail (iterate fwd t1))+  where t0       = toGregorian (utctDay t) ^. _1+        t1       = if toTime t0 < t then t0 else rev t0+        rev      = pred+        fwd      = succ+        toTime y = UTCTime (fromGregorian y 1 1) 0++-- | A 'TimeSeq' for no sequence at all.+noTime :: TimeSeq+noTime _ = ([],[])++-- | 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 'doubleFromTimeValue'.+autoTimeValueAxis :: TimeValue t => AxisFn t+autoTimeValueAxis pts+    | null pts     = timeValueAxis days    days    (ft "%d-%b-%y") UnderTicks+                                           noTime  (ft "") UnderTicks []+    | 100*dsec<1   = timeValueAxis millis1   millis1  (ft "%S%Q") UnderTicks+                                             noTime (ft "%S%Q") UnderTicks pts+    | 10*dsec<1    = timeValueAxis millis10  millis10  (ft "%S%Q") UnderTicks+                                             noTime (ft "%S%Q") UnderTicks pts+    | dsec<1       = timeValueAxis millis10  millis100 (ft "%S%Q") UnderTicks+                                             seconds (ft "%M:%S") BetweenTicks pts+    | dsec<5       = timeValueAxis millis100 seconds (ft "%M:%S%Q") UnderTicks+                                             seconds (ft "%M:%S") BetweenTicks pts+    | dsec<32      = timeValueAxis seconds seconds (ft "%Ss") UnderTicks+                                           minutes (ft "%d-%b-%y %H:%M") BetweenTicks pts+    | dsec<120     = timeValueAxis seconds fiveSeconds (ft "%Ss") UnderTicks+                                           minutes (ft "%d-%b-%y %H:%M") BetweenTicks pts+    | dsec<7*60    = timeValueAxis fiveSeconds minutes (ft "%Mm") UnderTicks+                                           hours   (ft "%d-%b-%y %H:00") BetweenTicks pts+    | dsec<32*60   = timeValueAxis minutes minutes (ft "%Mm") UnderTicks+                                           hours   (ft "%d-%b-%y %H:00") BetweenTicks pts+    | dsec<90*60   = timeValueAxis minutes fiveMinutes (ft "%Mm") UnderTicks+                                           hours   (ft "%d-%b-%y %H:00") BetweenTicks pts+    | dsec<4*3600  = timeValueAxis fiveMinutes hours (ft "%H:%M") UnderTicks+                                               days  (ft "%d-%b-%y") BetweenTicks pts+    | dsec<32*3600 = timeValueAxis hours  hours  (ft "%H:%M") UnderTicks+                                          days   (ft "%d-%b-%y") BetweenTicks pts+    | dday<4       = timeValueAxis hours  days   (ft "%d-%b-%y") BetweenTicks+                                          noTime (ft "") BetweenTicks pts+    | dday<12      = timeValueAxis days   days   (ft "%d-%b") BetweenTicks+                                          years  (ft "%Y") BetweenTicks pts+    | dday<45      = timeValueAxis days   days   (ft "%d") BetweenTicks+                                          months (ft "%b-%y") BetweenTicks pts+    | dday<95      = timeValueAxis days   months (ft "%b-%y") BetweenTicks+                                          noTime (ft "") BetweenTicks pts+    | dday<450     = timeValueAxis months months (ft "%b-%y") BetweenTicks+                                          noTime (ft "") BetweenTicks pts+    | dday<735     = timeValueAxis months months (ft "%b") BetweenTicks+                                          years  (ft "%Y") BetweenTicks pts+    | dday<1800    = timeValueAxis months years (ft "%Y") BetweenTicks+                                          noTime (ft "") BetweenTicks pts+    | otherwise    = timeValueAxis years  years (ft "%Y") BetweenTicks+                                          noTime (ft "") BetweenTicks pts+  where+    upts  = map utctimeFromTV pts+    dsec  = diffUTCTime t1 t0  -- seconds+    dday  = dsec / 86400       -- days+    t1    = maximum upts+    t0    = minimum upts+    ft    = formatTime defaultTimeLocale
+ Graphics/Rendering/Chart/Axis/Types.hs view
@@ -0,0 +1,454 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Graphics.Rendering.Chart.Axis.Types+-- Copyright   :  (c) Tim Docker 2006, 2014+-- License     :  BSD-style (see chart/COPYRIGHT)+--+-- Type definitions for Axes+--++{-# LANGUAGE TemplateHaskell #-}++module Graphics.Rendering.Chart.Axis.Types(+    AxisData(..),+    AxisVisibility(..),+    AxisT(..),+    AxisStyle(..),+    PlotValue(..),+    AxisFn,++    defaultAxisLineStyle,+    defaultGridLineStyle,++    makeAxis,+    makeAxis',++    axisToRenderable,+    renderAxisGrid,+    axisOverhang,+    vmap,+    invmap,++    linMap,+    invLinMap,++    axisGridAtTicks,+    axisGridAtBigTicks,+    axisGridAtLabels,+    axisGridHide,+    axisLabelsOverride,+    +    axis_show_line,+    axis_show_ticks,+    axis_show_labels,++    axis_visibility,+    axis_viewport,+    axis_tropweiv,+    axis_ticks,+    axis_labels,+    axis_grid,++    axis_line_style,+    axis_label_style,+    axis_grid_style,+    axis_label_gap,++) where++import Control.Monad+import Data.List(sort,intersperse)+import Control.Lens hiding (at, re)+import Data.Colour (opaque)+import Data.Colour.Names (black, lightgrey)+import Data.Default.Class++import Graphics.Rendering.Chart.Geometry+import Graphics.Rendering.Chart.Drawing+import Graphics.Rendering.Chart.Renderable++-- | A typeclass abstracting the functions we need+-- to be able to plot against an axis of type a+class Ord a => PlotValue a where+    toValue  :: a -> Double+    fromValue:: Double -> a+    autoAxis :: AxisFn a++-- | Configures whick visual elements of a axis are shown at the+--   appropriate edge of a plot area.+data AxisVisibility = AxisVisibility+  { -- | Whether to display a line along the axis.+    _axis_show_line :: Bool+    +    -- | Whether to display the tick marks.+  , _axis_show_ticks :: Bool++    -- | Whether to display the labels.+  , _axis_show_labels :: Bool+  }++-- | The basic data associated with an axis showing values of type x.+data AxisData x = AxisData {+    +    -- | Which parts of the axis shall be displayed.+    _axis_visibility :: AxisVisibility,+    +    -- | The _axis_viewport function maps values into device coordinates.+    _axis_viewport :: Range -> x -> Double,++    -- | The _axis_tropweiv function maps device coordinates back to values.+    _axis_tropweiv :: Range -> Double -> x,++    -- | 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 numbers are drawn+    --   towards the plot area.+    _axis_ticks    :: [(x,Double)],++    -- | The labels on an axis as pairs. The first element of the pair+    --   is the position on the axis (in viewport units) and the+    --   second is the label text string. Note that multiple sets of+    --   labels can be specified, and are shown successively further+    --   away from the axis line.+    _axis_labels   :: [[(x, String)]],++    -- | The positions on the axis (in viewport units) where+    --   we want to show grid lines.+    _axis_grid     :: [ x ]+}++-- | Control values for how an axis gets displayed.+data AxisStyle = AxisStyle {+    -- | 'LineStyle' to use for axis line and ticks.+    _axis_line_style  :: LineStyle,+    -- | 'FontStyle' to use for axis labels.+    _axis_label_style :: FontStyle,+    -- | 'LineStyle' to use for axis grid.+    _axis_grid_style  :: LineStyle,++    -- | How far the labels are to be drawn from the axis.+    _axis_label_gap   :: Double+}++-- | A function to generate the axis data, given the data values+--   to be plotted against it.+type AxisFn x = [x] -> AxisData x++-- | Collect the information we need to render an axis. The+--   bool is true if the axis direction is reversed.+data AxisT x = AxisT RectEdge AxisStyle Bool (AxisData x)++-- | Construct a renderable from an axis, in order that+-- it can be composed with other renderables and drawn. This+-- does not include the drawing of the grid, which must be done+-- separately by the `renderAxisGrid` function.+axisToRenderable :: AxisT x -> Renderable x+axisToRenderable at = Renderable {+     minsize = minsizeAxis at,+     render  = renderAxis at+  }++-- | Modifier to remove grid lines from an axis+axisGridHide         :: AxisData x -> AxisData x+axisGridHide ad       = ad{ _axis_grid = [] }++-- | Modifier to position grid lines to line up with the ticks+axisGridAtTicks      :: AxisData x -> AxisData x+axisGridAtTicks ad    = ad{ _axis_grid = map fst (_axis_ticks ad) }++-- | Modifier to position grid lines to line up with only the major ticks+axisGridAtBigTicks   :: AxisData x -> AxisData x+axisGridAtBigTicks ad = ad{ _axis_grid =+                            map fst $+                            filter ((> minimum (map (abs.snd) (_axis_ticks ad))).snd) $+                            _axis_ticks ad }++-- | Modifier to position grid lines to line up with the labels+axisGridAtLabels     :: AxisData x -> AxisData x+axisGridAtLabels ad   = ad{ _axis_grid = map fst vs }+  where+    vs = case _axis_labels ad of+        [] -> []+        ls -> head ls++-- | Modifier to change labels on an axis+axisLabelsOverride  :: [(x,String)] -> AxisData x -> AxisData x+axisLabelsOverride o ad = ad{ _axis_labels = [o] }++minsizeAxis :: AxisT x -> BackendProgram RectSize+minsizeAxis (AxisT at as _ ad) = do+    let labelVis = _axis_show_labels $ _axis_visibility ad+        tickVis  = _axis_show_ticks  $ _axis_visibility ad+        labels = if labelVis then labelTexts ad else []+        ticks = if tickVis then _axis_ticks ad else []+    labelSizes <- withFontStyle (_axis_label_style as) $+                    mapM (mapM textDimension) labels++    let ag      = _axis_label_gap as+    let tsize   = maximum (0 : [ max 0 (-l) | (_,l) <- ticks ])++    let hw = maximum0 (map (maximum0.map fst) labelSizes)+    let hh = ag + tsize + (sum . intersperse ag . map (maximum0.map snd) $ labelSizes)++    let vw = ag + tsize + (sum . intersperse ag . map (maximum0.map fst) $ labelSizes)+    let vh = maximum0 (map (maximum0.map snd) labelSizes)++    let sz      = case at of+                    E_Top    -> (hw,hh)+                    E_Bottom -> (hw,hh)+                    E_Left   -> (vw,vh)+                    E_Right  -> (vw,vh)+    return sz++labelTexts :: AxisData a -> [[String]]+labelTexts ad = map (map snd) (_axis_labels ad)++maximum0 :: (Num a, Ord a) => [a] -> a+maximum0 [] = 0+maximum0 vs = maximum vs++-- | Calculate the amount by which the labels extend beyond+--   the ends of the axis.+axisOverhang :: (Ord x) => AxisT x -> BackendProgram (Double,Double)+axisOverhang (AxisT at as _ ad) = do+    let labels = map snd . sort . concat . _axis_labels $ ad+    labelSizes <- withFontStyle (_axis_label_style as) $+      mapM textDimension labels+    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 x -> RectSize -> BackendProgram (PickFn x)+renderAxis at@(AxisT et as _ ad) sz = do+  let ls = _axis_line_style as+      vis = _axis_visibility ad+  when (_axis_show_line vis) $ +    withLineStyle (ls {_line_cap = LineCapSquare}) $ do+      p <- alignStrokePoints [Point sx sy,Point ex ey]+      strokePointPath p+  when (_axis_show_ticks vis) $ +    withLineStyle (ls {_line_cap = LineCapButt}) $ +      mapM_ drawTick (_axis_ticks ad)+  when (_axis_show_labels vis) $ +    withFontStyle (_axis_label_style as) $ do+      labelSizes <- mapM (mapM textDimension) (labelTexts ad)+      let sizes = map ((+ag).maximum0.map coord) labelSizes+      let offsets = scanl (+) ag sizes+      mapM_ drawLabels (zip offsets  (_axis_labels ad))+  return pickfn+ where+   (sx,sy,ex,ey,tp,axisPoint,invAxisPoint) = axisMapping at sz++   drawTick (value,len) =+       let t1 = axisPoint value+           t2 = t1 `pvadd` vscale len tp+       in alignStrokePoints [t1,t2] >>= strokePointPath++   (hta,vta,coord,awayFromAxis) = case et of+       E_Top    -> (HTA_Centre, VTA_Bottom, snd, \v -> Vector 0 (-v))+       E_Bottom -> (HTA_Centre, VTA_Top,    snd, \v -> Vector 0 v)+       E_Left   -> (HTA_Right,  VTA_Centre, fst, \v -> Vector (-v) 0)+       E_Right  -> (HTA_Left,   VTA_Centre, fst, \v -> Vector v 0)++   avoidOverlaps labels = do+       rects <- mapM labelDrawRect labels+       return $ map snd . head . filter (noOverlaps . map fst)+              $ map (`eachNth` rects) [0 .. length rects]++   labelDrawRect (value,s) = do+       let pt = axisPoint value `pvadd` awayFromAxis ag+       r <- textDrawRect hta vta pt s+       return (hBufferRect r,(value,s))++   drawLabels (offset,labels) = do+        labels' <- avoidOverlaps labels+        mapM_ drawLabel labels'+     where+       drawLabel (value,s) = do+           drawTextA hta vta (axisPoint value `pvadd` awayFromAxis offset) s+           textDimension s++   ag = _axis_label_gap as+   pickfn = Just . invAxisPoint++hBufferRect :: Rect -> Rect+hBufferRect (Rect p (Point x y)) = Rect p $ Point x' y+  where x' = x + w/2+        w = x - p_x p++noOverlaps :: [Rect] -> Bool+noOverlaps [] = True+noOverlaps [_] = True+noOverlaps (x:y:l) | rectsOverlap x y = False+                   | otherwise        = noOverlaps (y:l)++rectsOverlap :: Rect -> Rect -> Bool+rectsOverlap (Rect p1 p2) r = any (withinRect r) ps+  where (Point x1 y1) = p1+        (Point x2 y2) = p2+        p3 = Point x1 y2+        p4 = Point x2 y1+        ps = [p1,p2,p3,p4]++eachNth :: Int -> [a] -> [a]+eachNth n = skipN+  where+    n' = n - 1+    skipN [] = []+    skipN (x:xs) = x : skipN (drop n' xs)++withinRect :: Rect -> Point -> Bool+withinRect (Rect (Point x1 y1) (Point x2 y2)) (Point x y)+    = and [x >= x1 && x <= x2,+           y >= y1 && y <= y2]++axisMapping :: AxisT z -> RectSize+               -> (Double,Double,Double,Double,Vector,z->Point,Point->z)+axisMapping (AxisT et _ rev ad) (x2,y2) = case et of+    E_Top    -> (x1,y2,x2,y2, Vector 0 1,    mapx y2, imapx)+    E_Bottom -> (x1,y1,x2,y1, Vector 0 (-1), mapx y1, imapx)+    E_Left   -> (x2,y2,x2,y1, Vector 1 0,    mapy x2, imapy) +    E_Right  -> (x1,y2,x1,y1, Vector (-1) 0, mapy x1, imapy)+  where+    (x1,y1) = (0,0)+    xr = reverseR (x1,x2)+    yr = reverseR (y2,y1)++    mapx y x = Point (_axis_viewport ad xr x) y+    mapy x y = Point x (_axis_viewport ad yr y)++    imapx (Point x _) = _axis_tropweiv ad xr x+    imapy (Point _ y) = _axis_tropweiv ad yr y++    reverseR r@(r0,r1)  = if rev then (r1,r0) else r++-- +renderAxisGrid :: RectSize -> AxisT z -> BackendProgram ()+renderAxisGrid sz@(w,h) at@(AxisT re as _ ad) = +    withLineStyle (_axis_grid_style as) $ +      mapM_ (drawGridLine re) (_axis_grid ad)+  where+    (_,_,_,_,_,axisPoint,_) = axisMapping at sz++    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 alignStrokePoints [Point v' 0,Point v' h] >>= strokePointPath++    hline v = let v' = p_y (axisPoint v)+              in alignStrokePoints [Point 0 v',Point w v'] >>= strokePointPath+++-- | Construct an axis given the positions for ticks, grid lines, and +-- labels, and the labelling function+makeAxis :: PlotValue x => ([x] -> [String]) -> ([x],[x],[x]) -> AxisData x+makeAxis labelf (labelvs, tickvs, gridvs) = AxisData {+    _axis_visibility = def,+    _axis_viewport = newViewport,+    _axis_tropweiv = newTropweiv,+    _axis_ticks    = newTicks,+    _axis_grid     = gridvs,+    _axis_labels   = [newLabels]+    }+  where+    newViewport = vmap (min',max')+    newTropweiv = invmap (min',max')+    newTicks    = [ (v,2)        | v <- tickvs  ] ++ [ (v,5) | v <- labelvs ]+    newLabels   = zipWithLengthCheck labelvs (labelf labelvs)+      where+        zipWithLengthCheck (x:xs) (y:ys) = (x,y) : zipWithLengthCheck xs ys+        zipWithLengthCheck [] [] = []+        zipWithLengthCheck _ _ =+          error "makeAxis: label function returned the wrong number of labels"++    min'        = minimum labelvs+    max'        = maximum labelvs++-- | Construct an axis given the positions for ticks, grid lines, and +-- labels, and the positioning and labelling functions+makeAxis' :: Ord x => (x -> Double) -> (Double -> x) -> ([x] -> [String])+                   -> ([x],[x],[x]) -> AxisData x+makeAxis' t f labelf (labelvs, tickvs, gridvs) = AxisData {+    _axis_visibility = def,+    _axis_viewport = linMap t (minimum labelvs, maximum labelvs),+    _axis_tropweiv = invLinMap f t (minimum labelvs, maximum labelvs),+    _axis_ticks    = zip tickvs (repeat 2)  ++  zip labelvs (repeat 5),+    _axis_grid     = gridvs,+    _axis_labels   =+      let zipWithLengthCheck (x:xs) (y:ys) = (x,y) : zipWithLengthCheck xs ys+          zipWithLengthCheck [] [] = []+          zipWithLengthCheck _ _ =+            error "makeAxis': label function returned the wrong number of labels"+      in [zipWithLengthCheck labelvs (labelf labelvs)]+    }+++----------------------------------------------------------------------++-- | The default 'LineStyle' of an axis.+defaultAxisLineStyle :: LineStyle+defaultAxisLineStyle = solidLine 1 $ opaque black++-- | The default 'LineStyle' of a plot area grid.+defaultGridLineStyle :: LineStyle+defaultGridLineStyle = dashedLine 1 [5,5] $ opaque lightgrey++instance Default AxisStyle where+  def = AxisStyle +    { _axis_line_style  = defaultAxisLineStyle+    , _axis_label_style = def+    , _axis_grid_style  = defaultGridLineStyle+    , _axis_label_gap   = 10+    }++-- | By default all parts of a axis are visible.+instance Default AxisVisibility where+  def = AxisVisibility+    { _axis_show_line   = True+    , _axis_show_ticks  = True+    , _axis_show_labels = True+    }++----------------------------------------------------------------------++-- | A linear mapping of points in one range to another.+vmap :: PlotValue x => (x,x) -> Range -> x -> Double+vmap (v1,v2) (v3,v4) v = v3 + (toValue v - toValue v1) * (v4-v3)+                              / (toValue v2 - toValue v1)++-- | The inverse mapping from device co-ordinate range back to+--   interesting values.+invmap :: PlotValue x => (x,x) -> Range -> Double -> x+invmap (v3,v4) (d1,d2) d = fromValue (toValue v3 + ( (d-d1) * doubleRange+                                                   / (d2-d1) ))+    where doubleRange = toValue v4 - toValue v3++-- | A linear mapping of points in one range to another.+linMap :: (a -> Double) -> (a,a) -> Range -> a -> Double+linMap f (x1,x2) (d1,d2) x =+    d1 + (d2 - d1) * (f x - f x1) / (f x2 - f x1)++-- | An inverse linear mapping of points from one range to another.+invLinMap :: (Double -> a) -> (a -> Double) -> (a,a) -> Range -> Double -> a+invLinMap f t (v3,v4) (d1,d2) d =+    f (t v3 + ( (d-d1) * doubleRange / (d2-d1) ))+  where+    doubleRange = t v4 - t v3++$( makeLenses ''AxisVisibility )+$( makeLenses ''AxisData )+$( makeLenses ''AxisStyle )+
+ Graphics/Rendering/Chart/Axis/Unit.hs view
@@ -0,0 +1,34 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Graphics.Rendering.Chart.Axis.Unit+-- Copyright   :  (c) Tim Docker 2010+-- License     :  BSD-style (see chart/COPYRIGHT)+--+-- Calculate and render unit indexed axes+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Graphics.Rendering.Chart.Axis.Unit(+    unitAxis,+) where++import Data.Default.Class++import Graphics.Rendering.Chart.Axis.Types++instance PlotValue () where+    toValue () = 0+    fromValue  = const ()+    autoAxis   = const unitAxis++unitAxis :: AxisData ()+unitAxis = AxisData {+    _axis_visibility = def +                     { _axis_show_ticks  = False+                     , _axis_show_labels = False +                     },+    _axis_viewport = \(x0,x1) _ -> (x0+x1)/2,+    _axis_tropweiv = \_       _ -> (),+    _axis_ticks    = [((), 0)],+    _axis_labels   = [[((), "")]],+    _axis_grid     = []+}
+ Graphics/Rendering/Chart/Backend.hs view
@@ -0,0 +1,67 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Graphics.Rendering.Chart.Backend+-- Copyright   :  (c) Tim Docker 2014+-- License     :  BSD-style (see chart/COPYRIGHT)+--+-- This module provides the API for drawing operations abstracted+-- to drive arbitrary Backend.++module Graphics.Rendering.Chart.Backend+  (+  -- * The backend Monad+    BackendProgram+  +  -- * Backend Operations+  , fillPath+  , strokePath+  , drawText, textSize+  , withTransform+  , withClipRegion+  , withFontStyle, withFillStyle, withLineStyle+  +  -- * Backend Helpers+--  , getTransform+--  , getFillStyle, getFontStyle+--  , getLineStyle, getClipRegion+  , getPointAlignFn, getCoordAlignFn++  -- * Text Metrics+  , TextSize(..)                     +  +  -- * Line Types+  , LineCap(..)+  , LineJoin(..)+  , LineStyle(..)+  +  , line_width+  , line_color+  , line_dashes+  , line_cap+  , line_join+  +  -- * Fill Types+  , FillStyle(..)++  -- * Font and Text Types+  , FontWeight(..)+  , FontSlant(..)+  , FontStyle(..)++  , HTextAnchor(..)+  , VTextAnchor(..)++  , font_name+  , font_size+  , font_slant+  , font_weight+  , font_color+  +  , AlignmentFn+  , AlignmentFns+  , vectorAlignmentFns+  , bitmapAlignmentFns+  ) where++import Graphics.Rendering.Chart.Backend.Types+import Graphics.Rendering.Chart.Backend.Impl
+ Graphics/Rendering/Chart/Backend/Impl.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE GADTs #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Graphics.Rendering.Chart.Backend.Impl+-- Copyright   :  (c) Tim Docker 2014+-- License     :  BSD-style (see chart/COPYRIGHT)+--+-- This module provides the implementation details common to all 'ChartBackend's.++module Graphics.Rendering.Chart.Backend.Impl where++import Control.Monad+import Control.Monad.Operational++import Graphics.Rendering.Chart.Geometry+import Graphics.Rendering.Chart.Backend.Types++-- -----------------------------------------------------------------------+-- Rendering Backend Class+-- -----------------------------------------------------------------------++-- | The abstract drawing operation generated when using the+--   the chart drawing API.+--+--   See the documentation of the different function for the correct semantics+--   of each instruction:+--+--   * 'strokePath', 'fillPath'+--+--   * 'drawText', 'textSize'+--+--   * 'getPointAlignFn', 'getCoordAlignFn', 'AlignmentFns'+--+--   * 'withTransform', 'withClipRegion'+--+--   * 'withLineStyle', 'withFillStyle', 'withFontStyle'+--+data ChartBackendInstr a where+  StrokePath :: Path -> ChartBackendInstr ()+  FillPath   :: Path -> ChartBackendInstr ()+  GetTextSize :: String -> ChartBackendInstr TextSize+  DrawText    :: Point -> String -> ChartBackendInstr ()+  GetAlignments :: ChartBackendInstr AlignmentFns+  WithTransform  :: Matrix ->  Program ChartBackendInstr a -> ChartBackendInstr a+  WithFontStyle  :: FontStyle -> Program ChartBackendInstr a -> ChartBackendInstr a+  WithFillStyle  :: FillStyle -> Program ChartBackendInstr a -> ChartBackendInstr a+  WithLineStyle  :: LineStyle -> Program ChartBackendInstr a -> ChartBackendInstr a+  WithClipRegion :: Rect -> Program ChartBackendInstr a -> ChartBackendInstr a++-- | A 'BackendProgram' provides the capability to render a chart somewhere.+--+--   The coordinate system of the backend has its initial origin (0,0)+--   in the top left corner of the drawing plane. The x-axis points+--   towards the top right corner and the y-axis points towards+--   the bottom left corner. The unit used by coordinates, the font size,+--   and lengths is the always the same, but depends on the backend.+--   All angles are measured in radians.+--+--   The line, fill and font style are set to their default values+--   initially.+--+--   Information about the semantics of the instructions can be+--   found in the documentation of 'ChartBackendInstr'.+type BackendProgram a = Program ChartBackendInstr a++-- | Stroke the outline of the given path using the+--   current 'LineStyle'. This function does /not/ perform+--   alignment operations on the path. See 'Path' for the exact semantic+--   of paths.+strokePath :: Path -> BackendProgram ()+strokePath p = singleton (StrokePath p)++-- | Fill the given path using the current 'FillStyle'.+--   The given path will be closed prior to filling.+--   This function does /not/ perform+--   alignment operations on the path.+--   See 'Path' for the exact semantic of paths.+fillPath :: Path -> BackendProgram ()+fillPath p = singleton (FillPath p)++-- | Calculate a 'TextSize' object with rendering information+--   about the given string without actually rendering it.+textSize :: String -> BackendProgram TextSize+textSize text = singleton (GetTextSize text)++-- | Draw a single-line textual label anchored by the baseline (vertical)+--   left (horizontal) point. Uses the current 'FontStyle' for drawing.+drawText :: Point -> String -> BackendProgram ()+drawText p text = singleton (DrawText p text)++-- | Apply the given transformation in this local+--   environment when drawing. The given transformation+--   is applied after the current transformation. This+--   means both are combined.+withTransform :: Matrix -> BackendProgram a -> BackendProgram a+withTransform t p = singleton (WithTransform t p)++-- | Use the given font style in this local+--   environment when drawing text.+--+--   An implementing backend is expected to guarantee+--   to support the following font families: @serif@, @sans-serif@ and @monospace@;+--+--   If the backend is not able to find or load a given font+--   it is required to fall back to a custom fail-safe font+--   and use it instead.+withFontStyle :: FontStyle -> BackendProgram a -> BackendProgram a+withFontStyle fs p = singleton (WithFontStyle fs p)++-- | Use the given fill style in this local+--   environment when filling paths.+withFillStyle :: FillStyle -> BackendProgram a -> BackendProgram a+withFillStyle fs p = singleton (WithFillStyle fs p)++-- | Use the given line style in this local+--   environment when stroking paths.+withLineStyle :: LineStyle -> BackendProgram a -> BackendProgram a+withLineStyle ls p = singleton (WithLineStyle ls p)++-- | Use the given clipping rectangle when drawing+--   in this local environment. The new clipping region+--   is intersected with the given clip region. You cannot+--   escape the clip!+withClipRegion :: Rect -> BackendProgram a -> BackendProgram a+withClipRegion c p = singleton (WithClipRegion c p)++-- -----------------------------------------------------------------------+-- Rendering Utility Functions+-- -----------------------------------------------------------------------++-- | Get the point alignment function+getPointAlignFn :: BackendProgram (Point->Point)+getPointAlignFn = liftM afPointAlignFn (singleton GetAlignments)++-- | Get the coordinate alignment function+getCoordAlignFn :: BackendProgram (Point->Point)+getCoordAlignFn = liftM afCoordAlignFn (singleton GetAlignments)+
+ Graphics/Rendering/Chart/Backend/Types.hs view
@@ -0,0 +1,189 @@+{-# LANGUAGE TemplateHaskell #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Graphics.Rendering.Chart.Backend.Types+-- Copyright   :  (c) Tim Docker 2014+-- License     :  BSD-style (see chart/COPYRIGHT)+--++module Graphics.Rendering.Chart.Backend.Types where++import Data.Default.Class+import Data.Colour+import Data.Colour.Names+import Control.Lens++import Graphics.Rendering.Chart.Geometry++-- -----------------------------------------------------------------------+-- Line Types+-- -----------------------------------------------------------------------++-- | The different supported line ends.+data LineCap = LineCapButt   -- ^ Just cut the line straight.+             | LineCapRound  -- ^ Make a rounded line end.+             | LineCapSquare -- ^ Make a square that ends the line.+             deriving (Show, Eq, Ord)++-- | The different supported ways to join line ends.+data LineJoin = LineJoinMiter -- ^ Extends the outline until they meet each other.+              | LineJoinRound -- ^ Draw a circle fragment to connet line end.+              | LineJoinBevel -- ^ Like miter, but cuts it off if a certain +                              --   threshold is exceeded.+              deriving (Show, Eq, Ord)++-- | Data type for the style of a line.+data LineStyle = LineStyle +  { _line_width  :: Double+  -- ^ The thickness of a line in device units.+  , _line_color  :: AlphaColour Double+  -- ^ The color of a line.+  , _line_dashes :: [Double]+  -- ^ The dash pattern. Every value at a even index gives a dash width and +  --   every value at a odd index gives a gap width in device units.+  , _line_cap    :: LineCap+  -- ^ How to end a line.+  , _line_join   :: LineJoin+  -- ^ How to connect two lines.+  } deriving (Show, Eq)++-- | The default line style.+instance Default LineStyle where+  def = LineStyle +    { _line_width  = 1+    , _line_color  = opaque black+    , _line_dashes = []+    , _line_cap    = LineCapButt+    , _line_join   = LineJoinBevel+    }++-- -----------------------------------------------------------------------+-- Font & Text Types+-- -----------------------------------------------------------------------++-- | The possible slants of a font.+data FontSlant = FontSlantNormal  -- ^ Normal font style without slant.+               | FontSlantItalic  -- ^ With a slight slant.+               | FontSlantOblique -- ^ With a greater slant.+               deriving (Show, Eq, Ord)++-- | The default font slant.+instance Default FontSlant where+  def = FontSlantNormal++-- | The possible weights of a font.+data FontWeight = FontWeightNormal -- ^ Normal font style without weight.+                | FontWeightBold   -- ^ Bold font.+                deriving (Show, Eq, Ord)++-- | The default font weight.+instance Default FontWeight where+  def = FontWeightNormal++-- | Data type for a font.+data FontStyle = FontStyle {+      _font_name   :: String,+      -- ^ The font family or font face to use.+      _font_size   :: Double,+      -- ^ The height of the rendered font in device coordinates.+      _font_slant  :: FontSlant,+      -- ^ The slant to render with.+      _font_weight :: FontWeight,+      -- ^ The weight to render with.+      _font_color  :: AlphaColour Double+      -- ^ The color to render text with.+} deriving (Show, Eq)++-- | The default font style.+instance Default FontStyle where+  def = FontStyle +    { _font_name   = "sans-serif"+    , _font_size   = 10+    , _font_slant  = def+    , _font_weight = def+    , _font_color  = opaque black+    }++-- | Possible horizontal anchor points for text.+data HTextAnchor = HTA_Left +                 | HTA_Centre +                 | HTA_Right +                 deriving (Show, Eq, Ord)++-- | Possible vertical anchor points for text.+data VTextAnchor = VTA_Top +                 | VTA_Centre +                 | VTA_Bottom +                 | VTA_BaseLine +                 deriving (Show, Eq, Ord)++-- | Text metrics returned by 'textSize'.+data TextSize = TextSize +  { textSizeWidth    :: Double -- ^ The total width of the text.+  , textSizeAscent   :: Double -- ^ The ascent or space above the baseline.+  , textSizeDescent  :: Double -- ^ The decent or space below the baseline.+  , textSizeYBearing :: Double -- ^ The Y bearing.+  , textSizeHeight   :: Double -- ^ The total height of the text.+  } deriving (Show, Eq)++-- -----------------------------------------------------------------------+-- Fill Types+-- -----------------------------------------------------------------------++-- | Abstract data type for a fill style.+--+--   The contained action sets the required fill+--   style in the rendering state.+newtype FillStyle = FillStyleSolid +  { _fill_color :: AlphaColour Double +  } deriving (Show, Eq)++-- | The default fill style.+instance Default FillStyle where+  def = FillStyleSolid { _fill_color = opaque white }++-------------------------------------------------------------------------++-- | A function to align points for a certain rendering device.+type AlignmentFn = Point -> Point++-- | Holds the point and coordinate alignment function.+data AlignmentFns = AlignmentFns {+  afPointAlignFn :: AlignmentFn,+  -- ^ An adjustment applied immediately prior to points+  --   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.+  --   +  --   This is usually used to align prior to stroking.++  -- | The adjustment applied immediately prior to coordinates+  --   being transformed.+  --   +  --   This is usually used to align prior to filling.+  afCoordAlignFn :: AlignmentFn+  }++-- | Alignment to render on raster based graphics.+bitmapAlignmentFns :: AlignmentFns+bitmapAlignmentFns = AlignmentFns (adjfn 0.5) (adjfn 0.0) +  where+    adjfn offset (Point x y) = Point (adj x) (adj y)+      where+        -- avoid messages about Integer default+        rnd :: Double -> Integer+        rnd = round+        adj v = (fromIntegral.rnd) v +offset++-- | Alignment to render on vector based graphics.+vectorAlignmentFns :: AlignmentFns+vectorAlignmentFns = AlignmentFns id id++$( makeLenses ''LineStyle )+$( makeLenses ''FontStyle )+$( makeLenses ''FillStyle )+
+ Graphics/Rendering/Chart/Drawing.hs view
@@ -0,0 +1,504 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Graphics.Rendering.Chart.Drawing+-- Copyright   :  (c) Tim Docker 2006, 2014+-- License     :  BSD-style (see chart/COPYRIGHT)+--+-- This module contains basic types and functions used for drawing.+--+-- Note that Template Haskell is used to derive accessor functions+-- (see 'Control.Lens') for each field of the following data types:+--+--    * 'PointStyle'+--+-- These accessors are not shown in this API documentation.  They have+-- the same name as the field, but with the trailing underscore+-- dropped. Hence for data field @f_::F@ in type @D@, they have type+--+-- @+--   f :: Control.Lens.Lens' D F+-- @+--++{-# LANGUAGE TemplateHaskell #-}++module Graphics.Rendering.Chart.Drawing+  ( -- * Point Types and Drawing+    PointShape(..)+  , PointStyle(..)+  , drawPoint++  -- * Alignments and Paths+  , alignPath+  , alignFillPath+  , alignStrokePath+  , alignFillPoints+  , alignStrokePoints++  , alignFillPoint+  , alignStrokePoint++  , strokePointPath+  , fillPointPath++  -- * Transformation and Style Helpers+  , withRotation+  , withTranslation+  , withScale+  , withScaleX, withScaleY+  , withPointStyle+  , withDefaultStyle++  -- * Text Drawing+  , drawTextA+  , drawTextR+  , drawTextsR+  , textDrawRect+  , textDimension++  -- * Style Helpers+  , defaultColorSeq++  , solidLine+  , dashedLine++  , filledCircles+  , hollowCircles+  , filledPolygon+  , hollowPolygon+  , plusses+  , exes+  , stars+  , arrows++  , solidFillStyle++  -- * Backend and general Types+  , module Graphics.Rendering.Chart.Backend++  -- * Accessors+  , point_color+  , point_border_color+  , point_border_width+  , point_radius+  , point_shape+) where++import Data.Default.Class+-- lens < 4 includes Control.Lens.Zipper.moveTo which clashes+-- with Graphics.Rendering.Chart.Geometry.moveTo (so you get+-- -Wall notices). This would suggest a 'hiding (moveTo)' in+-- the import, but it's been removed in lens-4.0 and I don't+-- feel it's worth the use of conditional compilation. This does+-- lead to the qualified Geometry import below.+import Control.Lens+import Data.Colour+import Data.Colour.Names+import Data.List (unfoldr)++import Graphics.Rendering.Chart.Backend+import Graphics.Rendering.Chart.Geometry hiding (moveTo)+import qualified Graphics.Rendering.Chart.Geometry as G++-- -----------------------------------------------------------------------+-- Transformation helpers+-- -----------------------------------------------------------------------++-- | Apply a local rotation. The angle is given in radians.+withRotation :: Double -> BackendProgram a -> BackendProgram a+withRotation angle = withTransform (rotate angle 1)++-- | Apply a local translation.+withTranslation :: Point -> BackendProgram a -> BackendProgram a+withTranslation p = withTransform (translate (pointToVec p) 1)++-- | Apply a local scale.+withScale :: Vector -> BackendProgram a -> BackendProgram a+withScale v = withTransform (scale v 1)++-- | Apply a local scale on the x-axis.+withScaleX :: Double -> BackendProgram a -> BackendProgram a+withScaleX x = withScale (Vector x 1)++-- | Apply a local scale on the y-axis.+withScaleY :: Double -> BackendProgram a -> BackendProgram a+withScaleY y = withScale (Vector 1 y)++-- | Changes the 'LineStyle' and 'FillStyle' to comply with+--   the given 'PointStyle'.+withPointStyle :: PointStyle -> BackendProgram a -> BackendProgram a+withPointStyle (PointStyle cl bcl bw _ _) m =+  withLineStyle (def { _line_color = bcl, _line_width = bw, _line_join = LineJoinMiter }) $+    withFillStyle (solidFillStyle cl) m++withDefaultStyle :: BackendProgram a -> BackendProgram a+withDefaultStyle = withLineStyle def . withFillStyle def . withFontStyle def++-- -----------------------------------------------------------------------+-- Alignment Helpers+-- -----------------------------------------------------------------------++-- | Align the path by applying the given function on all points.+alignPath :: (Point -> Point) -> Path -> Path+alignPath f = foldPath (G.moveTo . f)+                       (lineTo . f)+                       (arc . f)+                       (arcNeg . f)+                       close++-- | Align the path using the environment's alignment function for points.+--   This is generally useful when stroking.+--   See 'alignPath' and 'getPointAlignFn'.+alignStrokePath :: Path -> BackendProgram Path+alignStrokePath p = do+  f <- getPointAlignFn+  return $ alignPath f p++-- | Align the path using the environment's alignment function for coordinates.+--   This is generally useful when filling.+--   See 'alignPath' and 'getCoordAlignFn'.+alignFillPath :: Path -> BackendProgram Path+alignFillPath p = do+  f <- getCoordAlignFn+  return $ alignPath f p++-- | The points will be aligned by the 'getPointAlignFn', so that+--   when drawing bitmaps, 1 pixel wide lines will be centred on the+--   pixels.+alignStrokePoints :: [Point] -> BackendProgram [Point]+alignStrokePoints p = do+  f <- getPointAlignFn+  return $ fmap f p++-- | The points will be aligned by the 'getCoordAlignFn', so that+--   when drawing bitmaps, the edges of the region will fall between+--   pixels.+alignFillPoints :: [Point] -> BackendProgram [Point]+alignFillPoints p = do+  f <- getCoordAlignFn+  return $ fmap f p++-- | Align the point using the environment's alignment function for points.+--   See 'getPointAlignFn'.+alignStrokePoint :: Point -> BackendProgram Point+alignStrokePoint p = do+    alignfn <- getPointAlignFn+    return (alignfn p)++-- | Align the point using the environment's alignment function for coordinates.+--   See 'getCoordAlignFn'.+alignFillPoint :: Point -> BackendProgram Point+alignFillPoint p = do+    alignfn <- getCoordAlignFn+    return (alignfn p)++-- | Create a path by connecting all points with a line.+--   The path is not closed.+stepPath :: [Point] -> Path+stepPath (p:ps) = G.moveTo p+               <> mconcat (map lineTo ps)+stepPath [] = mempty++-- | Draw lines between the specified points.+strokePointPath :: [Point] -> BackendProgram ()+strokePointPath pts = strokePath $ stepPath pts++-- | Fill the region with the given corners.+fillPointPath :: [Point] -> BackendProgram ()+fillPointPath pts = fillPath $ stepPath pts++-- -----------------------------------------------------------------------+-- Text Drawing+-- -----------------------------------------------------------------------++-- | Draw a line of text that is aligned at a different anchor point.+--   See 'drawText'.+drawTextA :: HTextAnchor -> VTextAnchor -> Point -> String -> BackendProgram ()+drawTextA hta vta = drawTextR hta vta 0++{-+   The following is useful for checking out the bounding-box+   calculation. At present it looks okay for PNG/Cairo but+   is a bit off for SVG/Diagrams; this may well be down to+   differences in how fonts are rendered in the two backends++drawTextA hta vta p txt =+  drawTextR hta vta 0 p txt+  >> withLineStyle (solidLine 1 (opaque red))+     (textDrawRect hta vta p txt+       >>= \rect -> alignStrokePath (rectPath rect) >>= strokePath)+-}++-- | Draw a textual label anchored by one of its corners+--   or edges, with rotation. Rotation angle is given in degrees,+--   rotation is performed around anchor point.+--   See 'drawText'.+drawTextR :: HTextAnchor -> VTextAnchor -> Double -> Point -> String -> BackendProgram ()+drawTextR hta vta angle p s =+  withTranslation p $+    withRotation theta $ do+      ts <- textSize s+      drawText (adjustText hta vta ts) s+  where+    theta = angle*pi/180.0++-- | Draw a multi-line textual label anchored by one of its corners+--   or edges, with rotation. Rotation angle is given in degrees,+--   rotation is performed around anchor point.+--   See 'drawText'.+drawTextsR :: HTextAnchor -> VTextAnchor -> Double -> Point -> String -> BackendProgram ()+drawTextsR hta vta angle p s = case num of+      0 -> return ()+      1 -> drawTextR hta vta angle p s+      _ ->+        withTranslation p $+          withRotation theta $ do+            tss <- mapM textSize ss+            let ts = head tss+            let -- widths = map textSizeWidth tss+                -- maxw   = maximum widths+                maxh   = maximum (map textSizeYBearing tss)+                gap    = maxh / 2 -- half-line spacing+                totalHeight = fromIntegral num*maxh ++                              (fromIntegral num-1)*gap+                ys = take num (unfoldr (\y-> Just (y, y-gap-maxh))+                                       (yinit vta ts totalHeight))+                xs = map (adjustTextX hta) tss+            sequence_ (zipWith3 drawT xs ys ss)+    where+      ss   = lines s+      num  = length ss++      drawT x y = drawText (Point x y)+      theta = angle*pi/180.0++      yinit VTA_Top      ts _      = textSizeAscent ts+      yinit VTA_BaseLine _  _      = 0+      yinit VTA_Centre   ts height = height / 2 + textSizeAscent ts+      yinit VTA_Bottom   ts height = height + textSizeAscent ts++-- | Calculate the correct offset to align the text anchor.+adjustText :: HTextAnchor -> VTextAnchor -> TextSize -> Point+adjustText hta vta ts = Point (adjustTextX hta ts) (adjustTextY vta ts)++-- | Calculate the correct offset to align the horizontal anchor.+adjustTextX :: HTextAnchor -> TextSize -> Double+adjustTextX HTA_Left   _  = 0+adjustTextX HTA_Centre ts = - (textSizeWidth ts / 2)+adjustTextX HTA_Right  ts = - textSizeWidth ts++-- | Calculate the correct offset to align the vertical anchor.+adjustTextY :: VTextAnchor -> TextSize -> Double+adjustTextY VTA_Top      ts = textSizeAscent ts+adjustTextY VTA_Centre   ts = - textSizeYBearing ts / 2+adjustTextY VTA_BaseLine _  = 0+adjustTextY VTA_Bottom   ts = - textSizeDescent ts++-- | Return the bounding rectangle for a text string positioned+--   where it would be drawn by 'drawText'.+--   See 'textSize'.+textDrawRect :: HTextAnchor -> VTextAnchor -> Point -> String -> BackendProgram Rect+textDrawRect hta vta (Point x y) s = do+  ts <- textSize s+  -- This does not account for the pixel width of the label; e.g.+  -- with a label "bread" and a large-enough foint size (e.g. 36)+  -- I have seen the right-hand edge of the bounding box go through+  -- the vertical part of the 'd' character (see chart-tests/tests/Test8.hs+  -- and bump up the label size).+  let (w,h,dh) = (textSizeWidth ts, textSizeHeight ts, textSizeDescent ts)+      lx = adjustTextX hta ts+      ly = adjustTextY vta ts+      (x',y') = (x + lx, y + ly + dh)+      p1 = Point x' (y' - h)+      p2 = Point (x' + w) y'+  return $ Rect p1 p2++-- | Get the width and height of the string when rendered.+--   See 'textSize'.+textDimension :: String -> BackendProgram RectSize+textDimension s = do+  ts <- textSize s+  return (textSizeWidth ts, textSizeHeight ts)++-- -----------------------------------------------------------------------+-- Point Types and Drawing+-- -----------------------------------------------------------------------++-- | The different shapes a point can have.+data PointShape = PointShapeCircle           -- ^ A circle.+                | PointShapePolygon Int Bool -- ^ Number of vertices and is right-side-up?+                | PointShapePlus  -- ^ A plus sign.+                | PointShapeCross -- ^ A cross.+                | PointShapeStar  -- ^ Combination of a cross and a plus.+                | PointShapeArrowHead Double+                | PointShapeEllipse Double Double -- ^ Ratio of minor to major axis and rotation++-- | Abstract data type for the style of a plotted point.+data PointStyle = PointStyle+  { _point_color :: AlphaColour Double+  -- ^ The color to fill the point with.+  , _point_border_color :: AlphaColour Double+  -- ^ The color to stroke the outline with.+  , _point_border_width :: Double+  -- ^ The width of the outline.+  , _point_radius :: Double+  -- ^ The radius of the tightest surrounding circle of the point.+  , _point_shape :: PointShape+  -- ^ The shape.+  }++-- | Default style to use for points.+instance Default PointStyle where+  def = PointStyle+    { _point_color        = opaque black+    , _point_border_color = transparent+    , _point_border_width = 0+    , _point_radius       = 1+    , _point_shape        = PointShapeCircle+    }++-- | Draw a single point at the given location.+drawPoint :: PointStyle  -- ^ Style to use when rendering the point.+          -> Point       -- ^ Position of the point to render.+          -> BackendProgram ()+drawPoint ps@(PointStyle cl _ _ r shape) p = withPointStyle ps $ do+  p'@(Point x y) <- alignStrokePoint p+  case shape of+    PointShapeCircle -> do+      let path = arc p' r 0 (2*pi)+      fillPath path+      strokePath path+    PointShapePolygon sides isrot -> do+      let intToAngle n =+            if isrot+            then       fromIntegral n * 2*pi/fromIntegral sides+            else (0.5 + fromIntegral n)*2*pi/fromIntegral sides+          angles = map intToAngle [0 .. sides-1]+          (p1:p1':p1s) = map (\a -> Point (x + r * sin a)+                                      (y + r * cos a)) angles+      let path = G.moveTo p1 <> mconcat (map lineTo $ p1':p1s) <> lineTo p1 <> lineTo p1'+      fillPath path+      strokePath path+    PointShapeArrowHead theta ->+      withTranslation p $ withRotation (theta - pi/2) $+          drawPoint (filledPolygon r 3 True cl) (Point 0 0)+    PointShapePlus ->+      strokePath $ moveTo' (x+r) y+                <> lineTo' (x-r) y+                <> moveTo' x (y-r)+                <> lineTo' x (y+r)+    PointShapeCross -> do+      let rad = r / sqrt 2+      strokePath $ moveTo' (x+rad) (y+rad)+                <> lineTo' (x-rad) (y-rad)+                <> moveTo' (x+rad) (y-rad)+                <> lineTo' (x-rad) (y+rad)+    PointShapeStar -> do+      let rad = r / sqrt 2+      strokePath $ moveTo' (x+r) y+                <> lineTo' (x-r) y+                <> moveTo' x (y-r)+                <> lineTo' x (y+r)+                <> moveTo' (x+rad) (y+rad)+                <> lineTo' (x-rad) (y-rad)+                <> moveTo' (x+rad) (y-rad)+                <> lineTo' (x-rad) (y+rad)+    PointShapeEllipse b theta ->+      withTranslation p $ withRotation theta $ withScaleX b $ do+        let path = arc (Point 0 0) r 0 (2*pi)+        fillPath path+        strokePath path++-- -----------------------------------------------------------------------+-- Style Helpers+-- -----------------------------------------------------------------------++-- | The default sequence of colours to use when plotings different data sets+--   in a graph.+defaultColorSeq :: [AlphaColour Double]+defaultColorSeq = cycle $ map opaque [blue, red, green, yellow, cyan, magenta]++-- | Create a solid line style (not dashed).+solidLine :: Double             -- ^ Width of line.+          -> AlphaColour Double -- ^ Colour of line.+          -> LineStyle+solidLine w cl = LineStyle w cl [] LineCapButt LineJoinMiter++-- | Create a dashed line style.+dashedLine :: Double   -- ^ Width of line.+           -> [Double] -- ^ The dash pattern in device coordinates.+           -> AlphaColour Double -- ^ Colour of line.+           -> LineStyle+dashedLine w ds cl = LineStyle w cl ds LineCapButt LineJoinMiter++-- | Style for filled circle points.+filledCircles :: Double             -- ^ Radius of circle.+              -> AlphaColour Double -- ^ Fill colour.+              -> PointStyle+filledCircles radius cl =+  PointStyle cl transparent 0 radius PointShapeCircle++-- | Style for stroked circle points.+hollowCircles :: Double -- ^ Radius of circle.+              -> Double -- ^ Thickness of line.+              -> AlphaColour Double -- Colour of line.+              -> PointStyle+hollowCircles radius w cl =+  PointStyle transparent cl w radius PointShapeCircle++-- | Style for stroked polygon points.+hollowPolygon :: Double -- ^ Radius of circle.+              -> Double -- ^ Thickness of line.+              -> Int    -- ^ Number of vertices.+              -> Bool   -- ^ Is right-side-up?+              -> AlphaColour Double -- ^ Colour of line.+              -> PointStyle+hollowPolygon radius w sides isrot cl =+  PointStyle transparent cl w radius (PointShapePolygon sides isrot)++-- | Style for filled polygon points.+filledPolygon :: Double -- ^ Radius of circle.+              -> Int    -- ^ Number of vertices.+              -> Bool   -- ^ Is right-side-up?+              -> AlphaColour Double -- ^ Fill color.+              -> PointStyle+filledPolygon radius sides isrot cl =+  PointStyle cl transparent 0 radius (PointShapePolygon sides isrot)++-- | Plus sign point style.+plusses :: Double -- ^ Radius of tightest surrounding circle.+        -> Double -- ^ Thickness of line.+        -> AlphaColour Double -- ^ Color of line.+        -> PointStyle+plusses radius w cl =+  PointStyle transparent cl w radius PointShapePlus++-- | Cross point style.+exes :: Double -- ^ Radius of circle.+     -> Double -- ^ Thickness of line.+     -> AlphaColour Double -- ^ Color of line.+     -> PointStyle+exes radius w cl =+  PointStyle transparent cl w radius PointShapeCross++-- | Combination of plus and cross point style.+stars :: Double -- ^ Radius of circle.+      -> Double -- ^ Thickness of line.+      -> AlphaColour Double -- ^ Color of line.+      -> PointStyle+stars radius w cl =+  PointStyle transparent cl w radius PointShapeStar++arrows :: Double -- ^ Radius of circle.+       -> Double -- ^ Rotation (Tau)+       -> Double -- ^ Thickness of line.+       -> AlphaColour Double -- ^ Color of line.+       -> PointStyle+arrows radius angle w cl =+  PointStyle transparent cl w radius (PointShapeArrowHead angle)++-- | Fill style that fill everything this the given colour.+solidFillStyle :: AlphaColour Double -> FillStyle+solidFillStyle = FillStyleSolid++$( makeLenses ''PointStyle )
+ Graphics/Rendering/Chart/Easy.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE ScopedTypeVariables, FlexibleInstances #-}+----------------------------------------------------------------------------+-- |+-- Module      :  Graphics.Rendering.Chart.Easy+-- Copyright   :  (c) Tim Docker 2014+-- License     :  BSD-style (see chart/COPYRIGHT)+--+-- A high level API for generating a plot quickly.+--+-- Importing the Easy module brings into scope all core functions and types required+-- for working with the chart library. This includes key external dependencies such as+-- Control.Lens and Data.Colour. The module also provides several helper functions for+-- quickly generating common plots. Note that chart backends must still be explicitly+-- imported, as some backends cannot be built on all platforms.+--+-- Example usage:+--+-- > import Graphics.Rendering.Chart.Easy+-- > import Graphics.Rendering.Chart.Backend.Cairo+-- >+-- > signal :: [Double] -> [(Double,Double)]+-- > signal xs = [ (x,(sin (x*3.14159/45) + 1) / 2 * (sin (x*3.14159/5))) | x <- xs ]+-- >+-- > main = toFile def "example.png" $ do+-- >     layout_title .= "Amplitude Modulation"+-- >     plot (line "am" [signal [0,(0.5)..400]])+-- >     plot (points "am points" (signal [0,7..400]))+--+-- More examples can be found on the <https://github.com/timbod7/haskell-chart/wiki library's wiki>++module Graphics.Rendering.Chart.Easy(++  module Control.Lens,+  module Data.Default.Class,+  module Data.Colour,+  module Data.Colour.Names,++  module Graphics.Rendering.Chart,+  module Graphics.Rendering.Chart.State,++  line,+  points,+  bars,+  setColors,+  setShapes+  ) where++import Control.Lens+import Control.Monad(unless)+import Data.Default.Class+import Data.Colour hiding (over) -- overlaps with lens over function+import Data.Colour.Names+import Graphics.Rendering.Chart+import Graphics.Rendering.Chart.State++-- | Set the contents of the colour source, for+-- subsequent plots+setColors :: [AlphaColour Double] -> EC l ()+setColors cs = liftCState $ colors .= cycle cs++-- | Set the contents of the shape source, for+-- subsequent plots+setShapes :: [PointShape] -> EC l ()+setShapes ps = liftCState $ shapes .= cycle ps++-- | Constuct a line plot with the given title and+-- data, using the next available color.+line :: String -> [[(x,y)]]  -> EC l (PlotLines x y)+line title values = liftEC $ do+    color <- takeColor+    plot_lines_title .= title+    plot_lines_values .= values+    plot_lines_style . line_color .= color++-- | Construct a scatter plot with the given title and data, using the+-- next available color and point shape.+points :: String -> [(x,y)]  -> EC l (PlotPoints x y)+points title values = liftEC $ do+    color <- takeColor+    shape <- takeShape+    plot_points_values .= values+    plot_points_title .= title+    plot_points_style . point_color .= color+    plot_points_style . point_shape .= shape+    plot_points_style . point_radius .= 2++    -- Show borders for unfilled shapes+    unless (isFilled shape) $ do+        plot_points_style . point_border_color .= color+        plot_points_style . point_border_width .= 1++isFilled :: PointShape -> Bool+isFilled PointShapeCircle = True+isFilled PointShapePolygon{} = True+isFilled _ = False++-- | Construct a bar chart with the given titles and data, using the+-- next available colors+bars :: (PlotValue x, BarsPlotValue y) => [String] -> [(x,[y])] -> EC l (PlotBars x y)+bars titles vals = liftEC $ do+    styles <- sequence [fmap mkStyle takeColor | _ <- titles]+    plot_bars_titles .= titles+    plot_bars_values .= vals+    plot_bars_style .= BarsClustered+    plot_bars_spacing .= BarsFixGap 30 5+    plot_bars_item_styles .= styles+  where+    mkStyle c = (solidFillStyle c, Just (solidLine 1.0 $ opaque black))
+ Graphics/Rendering/Chart/Geometry.hs view
@@ -0,0 +1,396 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Graphics.Rendering.Chart.Geometry+-- Copyright   :  (c) Tim Docker 2006, 2014+-- License     :  BSD-style (see chart/COPYRIGHT)+--+module Graphics.Rendering.Chart.Geometry+  ( -- * Points and Vectors+    Rect(..)+  , Point(..)+  , Vector(..)++  , RectSize+  , Range++  , pointToVec++  , mkrect+  , rectPath+  , pvadd+  , pvsub+  , psub+  , vangle+  , vlen+  , vscale+  , within+  , intersectRect++  , RectEdge(..)+  , Limit(..)+  , PointMapFn++  -- * Paths+  , Path(..)+  , lineTo, moveTo+  , lineTo', moveTo'+  , arc, arc'+  , arcNeg, arcNeg'+  , close++  , foldPath+  , makeLinesExplicit++  -- * Matrices+  , transformP, scaleP, rotateP, translateP+  , Matrix(..)+  , identity+  , rotate, scale, translate+  , scalarMultiply+  , adjoint+  , invert+  ) where++import qualified Prelude+import Prelude hiding ((^))++-- The homomorphic version to avoid casts inside the code.+(^) :: Num a => a -> Integer -> a+(^) = (Prelude.^)++-- | A point in two dimensions.+data Point = Point {+    p_x :: Double,+    p_y :: Double+} deriving Show++-- | A vector in two dimensions.+data Vector = Vector {+    v_x :: Double,+    v_y :: Double+} deriving Show++-- | Convert a 'Point' to a 'Vector'.+pointToVec :: Point -> Vector+pointToVec (Point x y) = Vector x y++-- | Angle of a vector (counterclockwise from positive x-axis)+vangle :: Vector -> Double+vangle (Vector x y)+    | x > 0 = atan (y/x)+    | x < 0 = atan (y/x) + pi+    | otherwise = if y > 0 then pi/2 else -pi/2++-- | Length/magnitude of a vector+vlen :: Vector -> Double+vlen (Vector x y) = sqrt $ x^2 + y^2++-- | 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)++data Limit a = LMin | LValue a | LMax+   deriving Show++-- | A function mapping between points.+type PointMapFn x y = (Limit x, Limit y) -> Point++-- | A rectangle is defined by two points.+data Rect = Rect Point Point+   deriving Show++-- | Edge of a rectangle.+data RectEdge = E_Top | E_Bottom | E_Left | E_Right++-- | Create a rectangle based upon the coordinates of 4 points.+mkrect :: Point -> Point -> Point -> Point -> Rect+mkrect (Point x1 _) (Point _ y2) (Point x3 _) (Point _ y4) =+    Rect (Point x1 y2) (Point x3 y4)++-- | Test if a point is within a rectangle.+within :: Point -> Rect -> Bool+within (Point x y) (Rect (Point x1 y1) (Point x2 y2)) =+    x >= x1 && x <= x2 && y >= y1 && y <= y2++-- | Intersects the rectangles. If they intersect the+--   intersection rectangle is returned.+--   'LMin' is the empty rectangle / intersection and+--   'LMax' is the infinite plane.+intersectRect :: Limit Rect -> Limit Rect -> Limit Rect+intersectRect LMax r = r+intersectRect r LMax = r+intersectRect LMin _ = LMin+intersectRect _ LMin = LMin+intersectRect (LValue (Rect (Point x11 y11) (Point x12 y12)))+              (LValue (Rect (Point x21 y21) (Point x22 y22))) =+  let p1@(Point x1 y1) = Point (max x11 x21) (max y11 y21)+      p2@(Point x2 y2) = Point (min x12 x22) (min y12 y22)+  in if x2 < x1 || y2 < y1+        then LMin+        else LValue $ Rect p1 p2++type Range    = (Double,Double)+type RectSize = (Double,Double)++{-+-- | Make a path from a rectangle.+rectPointPath :: Rect -> [Point]+rectPointPath (Rect p1@(Point x1 y1) p3@(Point x2 y2)) = [p1,p2,p3,p4,p1]+  where+    p2 = (Point x1 y2)+    p4 = (Point x2 y1)+-}++-- | Make a path from a rectangle.+rectPath :: Rect -> Path+rectPath (Rect p1@(Point x1 y1) p3@(Point x2 y2)) =+  let p2 = Point x1 y2+      p4 = Point x2 y1+  in moveTo p1 <> lineTo p2 <> lineTo p3 <> lineTo p4 <> close++-- -----------------------------------------------------------------------+-- Path Types+-- -----------------------------------------------------------------------++-- | The path type used by Charts.+--+--   A path can consist of several subpaths. Each+--   is started by a 'MoveTo' operation. All subpaths+--   are open, except the last one, which may be closed+--   using the 'Close' operation. When filling a path+--   all subpaths are closed implicitly.+--+--   Closing a subpath means that a line is drawn from+--   the end point to the start point of the subpath.+--+--   If a 'Arc' (or 'ArcNeg') is drawn a implicit line+--   from the last end point of the subpath is drawn+--   to the beginning of the arc. Another implicit line+--   is drawn from the end of an arc to the beginning of+--   the next path segment.+--+--   The beginning of a subpath is either (0,0) or set+--   by a 'MoveTo' instruction. If the first subpath is started+--   with an arc the beginning of that subpath is the beginning+--   of the arc.+data Path = MoveTo Point Path+          | LineTo Point Path+          | Arc Point Double Double Double Path+          | ArcNeg Point Double Double Double Path+          | End+          | Close++-- | Paths are monoids. After a path is closed you can not append+--   anything to it anymore. The empty path is open.+--   Use 'close' to close a path.+instance Semigroup Path where+  p1 <> p2 = case p1 of+    MoveTo p path -> MoveTo p $ path <> p2+    LineTo p path -> LineTo p $ path <> p2+    Arc    p r a1 a2 path -> Arc p r a1 a2 $ path <> p2+    ArcNeg p r a1 a2 path -> ArcNeg p r a1 a2 $ path <> p2+    End   -> p2+    Close -> Close++instance Monoid Path where+  mappend = (<>)+  mempty = End++-- | Move the paths pointer to the given location.+moveTo :: Point -> Path+moveTo p = MoveTo p mempty++-- | Short-cut for 'moveTo', if you don't want to create a 'Point'.+moveTo' :: Double -> Double -> Path+moveTo' x y = moveTo $ Point x y++-- | Move the paths pointer to the given location and draw a straight+--   line while doing so.+lineTo :: Point -> Path+lineTo p = LineTo p mempty++-- | Short-cut for 'lineTo', if you don't want to create a 'Point'.+lineTo' :: Double -> Double -> Path+lineTo' x y = lineTo $ Point x y++-- | Draw the arc of a circle. A straight line connects+--   the end of the previous path with the beginning of the arc.+--   The zero angle points in direction of the positive x-axis.+--   Angles increase in clock-wise direction. If the stop angle+--   is smaller then the start angle it is increased by multiples of+--   @2 * pi@ until is is greater or equal.+arc :: Point  -- ^ Center point of the circle arc.+    -> Double -- ^ Radius of the circle.+    -> Double -- ^ Angle to start drawing at, in radians.+    -> Double -- ^ Angle to stop drawing at, in radians.+    -> Path+arc p r a1 a2 = Arc p r a1 a2 mempty++-- | Short-cut for 'arc', if you don't want to create a 'Point'.+arc' :: Double -> Double -> Double -> Double -> Double -> Path+arc' x y r a1 a2 = Arc (Point x y) r a1 a2 mempty++-- | Like 'arc', but draws from the stop angle to the start angle+--   instead of between them.+arcNeg :: Point -> Double -> Double -> Double -> Path+arcNeg p r a1 a2 = ArcNeg p r a1 a2 mempty++-- | Short-cut for 'arcNeg', if you don't want to create a 'Point'.+arcNeg' :: Double -> Double -> Double -> Double -> Double -> Path+arcNeg' x y r a1 a2 = ArcNeg (Point x y) r a1 a2 mempty++-- | A closed empty path. Closes a path when appended.+close :: Path+close = Close++-- | Fold the given path to a monoid structure.+foldPath :: (Monoid m)+         => (Point -> m) -- ^ MoveTo+         -> (Point -> m) -- ^ LineTo+         -> (Point -> Double -> Double -> Double -> m) -- ^ Arc+         -> (Point -> Double -> Double -> Double -> m) -- ^ ArcNeg+         -> m    -- ^ Close+         -> Path -- ^ Path to fold+         -> m+foldPath moveTo_ lineTo_ arc_ arcNeg_ close_ path =+  let restF = foldPath moveTo_ lineTo_ arc_ arcNeg_ close_+  in case path of+    MoveTo p rest -> moveTo_ p `mappend` restF rest+    LineTo p rest -> lineTo_ p `mappend` restF rest+    Arc    p r a1 a2 rest -> arc_    p r a1 a2 `mappend` restF rest+    ArcNeg p r a1 a2 rest -> arcNeg_ p r a1 a2 `mappend` restF rest+    End   -> mempty+    Close -> close_++-- | Enriches the path with explicit instructions to draw lines,+--   that otherwise would be implicit. See 'Path' for details+--   about what lines in paths are implicit.+makeLinesExplicit :: Path -> Path+makeLinesExplicit (Arc c r s e rest) =+  Arc c r s e $ makeLinesExplicit' rest+makeLinesExplicit (ArcNeg c r s e rest) =+  ArcNeg c r s e $ makeLinesExplicit' rest+makeLinesExplicit path = makeLinesExplicit' path++-- | Utility for 'makeLinesExplicit'.+makeLinesExplicit' :: Path -> Path+makeLinesExplicit' End   = End+makeLinesExplicit' Close = Close+makeLinesExplicit' (Arc c r s e rest) =+  let p = translateP (pointToVec c) $ rotateP s $ Point r 0+  in lineTo p <> arc c r s e <> makeLinesExplicit' rest+makeLinesExplicit' (ArcNeg c r s e rest) =+  let p = translateP (pointToVec c) $ rotateP s $ Point r 0+  in lineTo p <> arcNeg c r s e <> makeLinesExplicit' rest+makeLinesExplicit' (MoveTo p0 rest) =+  MoveTo p0 $ makeLinesExplicit' rest+makeLinesExplicit' (LineTo p0 rest) =+  LineTo p0 $ makeLinesExplicit' rest++-- -----------------------------------------------------------------------+-- Matrix Type+-- -----------------------------------------------------------------------++-- | Transform a point using the given matrix.+transformP :: Matrix -> Point -> Point+transformP t (Point x y) = Point+  (xx t * x + xy t * y + x0 t)+  (yx t * x + yy t * y + y0 t)++-- | Rotate a point around the origin.+--   The angle is given in radians.+rotateP :: Double -> Point -> Point+rotateP a = transformP (rotate a 1)++-- | Scale a point.+scaleP :: Vector -> Point -> Point+scaleP s = transformP (scale s 1)++-- | Translate a point.+translateP :: Vector -> Point -> Point+translateP = flip pvadd++-- | Copied from Graphics.Rendering.Cairo.Matrix+data Matrix = Matrix { xx :: !Double, yx :: !Double,+                       xy :: !Double, yy :: !Double,+                       x0 :: !Double, y0 :: !Double }+                     deriving Show++-- | Copied from Graphics.Rendering.Cairo.Matrix+instance Num Matrix where+  -- use underscore to avoid ghc complaints about shadowing the Matrix+  -- field names+  (*) (Matrix xx_ yx_ xy_ yy_ x0_ y0_)+      (Matrix xx'_ yx'_ xy'_ yy'_ x0'_ y0'_) =+    Matrix (xx_ * xx'_ + yx_ * xy'_)+           (xx_ * yx'_ + yx_ * yy'_)+           (xy_ * xx'_ + yy_ * xy'_)+           (xy_ * yx'_ + yy_ * yy'_)+           (x0_ * xx'_ + y0_ * xy'_ + x0'_)+           (x0_ * yx'_ + y0_ * yy'_ + y0'_)++  (+) = pointwise2 (+)+  (-) = pointwise2 (-)++  negate = pointwise negate+  abs    = pointwise abs+  signum = pointwise signum++  fromInteger n = Matrix (fromInteger n) 0 0 (fromInteger n) 0 0++-- | Copied from Graphics.Rendering.Cairo.Matrix+{-# INLINE pointwise #-}+pointwise :: (Double -> Double) -> Matrix -> Matrix+pointwise f (Matrix xx_ yx_ xy_ yy_ x0_ y0_) =+  Matrix (f xx_) (f yx_) (f xy_) (f yy_) (f x0_) (f y0_)++-- | Copied from Graphics.Rendering.Cairo.Matrix+{-# INLINE pointwise2 #-}+pointwise2 :: (Double -> Double -> Double) -> Matrix -> Matrix -> Matrix+pointwise2 f (Matrix xx_ yx_ xy_ yy_ x0_ y0_) (Matrix xx'_ yx'_ xy'_ yy'_ x0'_ y0'_) =+  Matrix (f xx_ xx'_) (f yx_ yx'_) (f xy_ xy'_) (f yy_ yy'_) (f x0_ x0'_) (f y0_ y0'_)++-- | Copied from Graphics.Rendering.Cairo.Matrix+identity :: Matrix+identity = Matrix 1 0 0 1 0 0++-- | Copied and adopted from Graphics.Rendering.Cairo.Matrix+translate :: Vector -> Matrix -> Matrix+translate tv m = m * Matrix 1 0 0 1 (v_x tv) (v_y tv)++-- | Copied and adopted from Graphics.Rendering.Cairo.Matrix+scale :: Vector -> Matrix -> Matrix+scale sv m = m * Matrix (v_x sv) 0 0 (v_y sv) 0 0++-- | Copied from Graphics.Rendering.Cairo.Matrix+--   Rotations angle is given in radians.+rotate :: Double -> Matrix -> Matrix+rotate r m = m * Matrix c s (-s) c 0 0+  where s = sin r+        c = cos r++-- | Copied from Graphics.Rendering.Cairo.Matrix+scalarMultiply :: Double -> Matrix -> Matrix+scalarMultiply scalar = pointwise (* scalar)++-- | Copied from Graphics.Rendering.Cairo.Matrix+adjoint :: Matrix -> Matrix+adjoint (Matrix a b c d tx ty) =+  Matrix d (-b) (-c) a (c*ty - d*tx) (b*tx - a*ty)++-- | Copied from Graphics.Rendering.Cairo.Matrix+invert :: Matrix -> Matrix+invert m@(Matrix xx_ yx_ xy_ yy_ _ _) = scalarMultiply (recip det) $ adjoint m+  where det = xx_*yy_ - yx_*xy_
+ Graphics/Rendering/Chart/Grid.hs view
@@ -0,0 +1,320 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Graphics.Rendering.Chart.Grid+-- Copyright   :  (c) Tim Docker 2010, 2014+-- License     :  BSD-style (see chart/COPYRIGHT)+--+-- A container type for values that can be composed by horizonal+-- and vertical layout.++module Graphics.Rendering.Chart.Grid (+    Grid, Span, SpaceWeight,+    tval, tspan,+    empty, nullt,+    (.|.), (./.),+    above, aboveN,+    beside, besideN,+    overlay,+    width, height,+    gridToRenderable,+    weights,+    aboveWide,+    wideAbove,+    tallBeside,+    besideTall,+    fullOverlayUnder,+    fullOverlayOver+) where++import Data.Array+import Control.Monad+import Graphics.Rendering.Chart.Renderable+import Graphics.Rendering.Chart.Geometry hiding (x0, y0)+import Graphics.Rendering.Chart.Drawing++type Span        = (Int,Int)+type Size        = (Int,Int)++-- | When more space is available for an item than the total width of items,+--   extra added space is proportional to 'space weight'.+type SpaceWeight = (Double,Double)++type Cell a      = (a,Span,SpaceWeight)++-- | Abstract datatype representing a grid.+data Grid a+    = Value (a,Span,SpaceWeight)       -- ^ A singleton grid item "a" spanning+                                       --   a given rectangle (measured in grid+                                       --   cells), with given space weight.+    | Above (Grid a) (Grid a) Size     -- ^ One grid above the other. "Size" is+                                       --   their cached total size (so it is+                                       --   NOT specified manually).+    | Beside (Grid a) (Grid a) Size    -- ^ One grid horizontally beside+                                       --   the other.+    | Overlay (Grid a) (Grid a) Size   -- ^ Two grids positioned one over+                                       --   the other.+    | Empty                            -- ^ An empty 1x1 grid cell.+    | Null                             -- ^ An empty 0x0 grid cell.+   deriving (Show)++width :: Grid a -> Int+width Null                = 0+width Empty               = 1+width (Value _)           = 1+width (Beside _ _ (w,_))  = w+width (Above _ _ (w,_))   = w+width (Overlay _ _ (w,_)) = w++height :: Grid a -> Int+height Null                = 0+height Empty               = 1+height (Value _)           = 1+height (Beside _ _ (_,h))  = h+height (Above _ _ (_,h))   = h+height (Overlay _ _ (_,h)) = h++-- | A 1x1 grid from a given value, with no extra space.+tval :: a -> Grid a+tval a = Value (a,(1,1),(0,0))++-- | A WxH (measured in cells) grid from a given value, with space weight (1,1).+tspan :: a -> Span -> Grid a+tspan a spn = Value (a,spn,(1,1))++-- | A 1x1 empty grid.+empty :: Grid a+empty = Empty++-- | A 0x0 empty grid.+nullt :: Grid a+nullt = Null++above, beside :: Grid a -> Grid a -> Grid a+above Null t = t+above t Null = t+above t1 t2  = Above t1 t2 size+  where size = (max (width t1) (width t2), height t1 + height t2)++-- | A value occupying 1 row with the same  horizontal span as the grid.+wideAbove :: a -> Grid a -> Grid a+wideAbove a g = weights (0,0) (tspan a (width g,1)) `above` g++-- | A value placed below the grid, occupying 1 row with the same+--   horizontal span as the grid.+aboveWide :: Grid a -> a -> Grid a+aboveWide g a = g `above` weights (0,0) (tspan a (width g,1))++-- | A value placed to the left of the grid, occupying 1 column with+--   the same vertical span as the grid.+tallBeside  :: a -> Grid a -> Grid a+tallBeside  a g = weights (0,0) (tspan a (1,height g)) `beside` g++-- | A value placed to the right of the grid, occupying 1 column with+--   the same vertical span as the grid.+besideTall :: Grid a -> a -> Grid a+besideTall g a = g `beside` weights (0,0) (tspan a (1,height g))++-- | A value placed under a grid, with the same span as the grid.+fullOverlayUnder :: a -> Grid a -> Grid a+fullOverlayUnder a g = g `overlay` tspan a (width g,height g)++-- | A value placed over a grid, with the same span as the grid.+fullOverlayOver :: a -> Grid a -> Grid a+fullOverlayOver  a g = tspan a (width g,height g) `overlay` g++beside Null t = t+beside t Null = t+beside t1 t2  = Beside t1 t2 size+  where size  = (width t1 + width t2, max (height t1) (height t2))++aboveN, besideN :: [Grid a] -> Grid a+aboveN  = foldl above nullt+besideN = foldl beside nullt++-- | One grid over the other. The first argument is shallow, the second is deep.+overlay :: Grid a -> Grid a -> Grid a+overlay Null t = t+overlay t Null = t+overlay t1 t2  = Overlay t1 t2 size+  where size   = (max (width t1) (width t2), max (height t1) (height t2))++-- | A synonym for 'beside'.+(.|.) :: Grid a -> Grid a -> Grid a+(.|.) = beside++-- | A synonym for 'above'.+(./.) :: Grid a -> Grid a -> Grid a+(./.) = above++-- | Sets the space weight of *every* cell of the grid to given value.+weights :: SpaceWeight -> Grid a -> Grid a+weights _  Null               = Null+weights _  Empty              = Empty+weights sw (Value (v,sp,_))   = Value   (v,sp,sw)+weights sw (Above t1 t2 sz)   = Above   (weights sw t1) (weights sw t2) sz+weights sw (Beside t1 t2 sz)  = Beside  (weights sw t1) (weights sw t2) sz+weights sw (Overlay t1 t2 sz) = Overlay (weights sw t1) (weights sw t2) sz++-- fix me, need to make .|. and .||. higher precedence+-- than ./. and .//.++instance Functor Grid where+    fmap f (Value (a,spn,ew))  = Value   (f a,spn,ew)+    fmap f (Above t1 t2 s)     = Above   (fmap f t1) (fmap f t2) s+    fmap f (Beside t1 t2 s)    = Beside  (fmap f t1) (fmap f t2) s+    fmap f (Overlay t1 t2 s)   = Overlay (fmap f t1) (fmap f t2) s+    fmap _ Empty               = Empty+    fmap _ Null                = Null++mapGridM :: Monad m => (a -> m b) -> Grid a -> m (Grid b)+mapGridM f (Value (a,spn,ew)) = do b <- f a+                                   return (Value (b,spn,ew))+mapGridM f (Above t1 t2 s)    = do t1' <- mapGridM f t1+                                   t2' <- mapGridM f t2+                                   return (Above t1' t2' s)+mapGridM f (Beside t1 t2 s)   = do t1' <- mapGridM f t1+                                   t2' <- mapGridM f t2+                                   return (Beside t1' t2' s)+mapGridM f (Overlay t1 t2 s)  = do t1' <- mapGridM f t1+                                   t2' <- mapGridM f t2+                                   return (Overlay t1' t2' s)+mapGridM _ Empty              = return Empty+mapGridM _ Null               = return Null++----------------------------------------------------------------------+type FlatGrid a = Array (Int,Int) [(a,Span,SpaceWeight)]++flatten :: Grid a -> FlatGrid a+flatten t = accumArray (flip (:)) [] ((0,0), (width t - 1, height t - 1))+                       (flatten2 (0,0) t [])++type FlatEl a = ((Int,Int),Cell a)++flatten2 :: (Int,Int) -> Grid a -> [FlatEl a] -> [FlatEl a]+flatten2 _ Empty        els = els+flatten2 _ Null         els = els+flatten2 i (Value cell) els = (i,cell):els++flatten2 i@(x,y) (Above t1 t2 _) els   = (f1.f2) els+  where+    f1 = flatten2 i t1+    f2 = flatten2 (x,y + height t1) t2++flatten2 i@(x,y) (Beside t1 t2 _) els  = (f1.f2) els+  where+    f1 = flatten2 i t1+    f2 = flatten2 (x + width t1, y) t2++flatten2 i (Overlay t1 t2 _) els = (f1.f2) els+  where+    f1 = flatten2 i t1+    f2 = flatten2 i t2++foldT :: ((Int,Int) -> Cell a -> r -> r) -> r -> FlatGrid a -> r+foldT f iv ft = foldr f' iv (assocs ft)+  where+    f' (i,vs) r = foldr (f i) r vs++----------------------------------------------------------------------+type DArray = Array Int Double++getSizes :: Grid (Renderable a) -> BackendProgram (DArray, DArray, DArray, DArray)+getSizes t = do+    szs <- mapGridM minsize t :: BackendProgram (Grid RectSize)+    let szs'     = flatten szs+    let widths   = accumArray max 0 (0, width  t - 1)+                                                   (foldT (ef wf  fst) [] szs')+    let heights  = accumArray max 0 (0, height t - 1)+                                                   (foldT (ef hf  snd) [] szs')+    let xweights = accumArray max 0 (0, width  t - 1)+                                                   (foldT (ef xwf fst) [] szs')+    let yweights = accumArray max 0 (0, height t - 1)+                                                   (foldT (ef ywf snd) [] szs')+    return (widths,heights,xweights,yweights)+  where+      wf  (x,_) (w,_) _      = (x,w)+      hf  (_,y) (_,h) _      = (y,h)+      xwf (x,_) _     (xw,_) = (x,xw)+      ywf (_,y) _     (_,yw) = (y,yw)++      ef f ds loc (size,spn,ew) r | ds spn == 1 = f loc size ew:r+                                  | otherwise    = r++instance (ToRenderable a) => ToRenderable (Grid a) where+  toRenderable = gridToRenderable . fmap toRenderable++gridToRenderable :: Grid (Renderable a) -> Renderable a+gridToRenderable gt = Renderable minsizef renderf+  where+    minsizef :: BackendProgram RectSize+    minsizef = do+        (widths, heights, _, _) <- getSizes gt+        return (sum (elems widths), sum (elems heights))++    renderf (w,h)  = do+        (widths, heights, xweights, yweights) <- getSizes gt+        let widths'  = addExtraSpace w widths xweights+        let heights' = addExtraSpace h heights yweights+        let borders  = (ctotal widths',ctotal heights')+        rf1 borders (0,0) gt++    -- (x borders, y borders) -> (x,y) -> grid -> drawing+    rf1 borders loc@(i,j) t = case t of+        Null  -> return nullPickFn+        Empty -> return nullPickFn+        (Value (r,spn,_)) -> do+            let (Rect p0 p1) = mkRect borders loc spn+            (Point x0 y0) <- alignFillPoint p0+            (Point x1 y1) <- alignFillPoint p1+            withTranslation (Point x0 y0) $ do+              pf <- render r (x1-x0,y1-y0)+              return (newpf pf x0 y0)+        (Above t1 t2 _) -> do+             pf1 <- rf1 borders (i,j) t1+             pf2 <- rf1 borders (i,j+height t1) t2+             let pf p@(Point _ y) = if y < (snd borders ! (j + height t1))+                                    then pf1 p else pf2 p+             return pf+        (Beside t1 t2 _) -> do+             pf1 <- rf1 borders (i,j) t1+             pf2 <- rf1 borders (i+width t1,j) t2+             let pf p@(Point x _) = if x < (fst borders ! (i + width t1))+                                    then pf1 p else pf2 p+             return pf+        (Overlay t1 t2 _) ->  do+             pf2 <- rf1 borders (i,j) t2+             pf1 <- rf1 borders (i,j) t1+             let pf p = pf1 p `mplus` pf2 p+             return pf++    newpf pf x0 y0 (Point x1 y1) = pf (Point (x1-x0) (y1-y0))++    -- (x borders, y borders) -> (x,y) -> (w,h)+    --     -> rectangle of grid[x..x+w, y..y+h]+    mkRect :: (DArray, DArray) -> (Int,Int) -> (Int,Int) -> Rect+    mkRect (cwidths,cheights) (x,y) (w,h) = Rect (Point x1 y1) (Point x2 y2)+      where+        x1 = cwidths  ! x+        y1 = cheights ! y+        x2 = cwidths  ! min (x+w) (snd $ bounds cwidths)+        y2 = cheights ! min (y+h) (snd $ bounds cheights)+        -- mx = fst (bounds cwidths)+        -- my = fst (bounds cheights)++    -- total size -> item sizes -> item weights -> new item sizes such that+    -- their sum == total size, and added size is proportional to weight+    addExtraSpace :: Double -> DArray -> DArray -> DArray+    addExtraSpace size sizes weights' =+        if totalws == 0 then sizes+                        else listArray (bounds sizes) sizes'+      where+        ws      = elems weights'+        totalws = sum ws+        extra   = size - sum (elems sizes)+        extras  = map (*(extra/totalws)) ws+        sizes'  = zipWith (+) extras (elems sizes)++    -- [1,2,3] -> [0,1,3,6].+    ctotal :: DArray -> DArray+    ctotal a = listArray (let (i,j) = bounds a in (i,j+1))+                         (scanl (+) 0 (elems a))
− Graphics/Rendering/Chart/Gtk.hs 
@@ -1,43 +0,0 @@--------------------------------------------------------------------------------- |--- 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.unsafeInitGUIForThreadedRTS-    -- 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
Graphics/Rendering/Chart/Layout.hs view
@@ -1,157 +1,855 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Graphics.Rendering.Chart.Layout--- Copyright   :  (c) Tim Docker 2006+-- Copyright   :  (c) Tim Docker 2006, 2014 -- License     :  BSD-style (see chart/COPYRIGHT)+--+-- This module glues together axes and plots to actually create a renderable+-- for a chart.+--+-- Note that Template haskell is used to derive accessor functions+-- (see 'Control.Lens') for each field of the following data types:+--+--     * 'Layout'+--+--     * 'LayoutLR'+--+--     * 'StackedLayouts'+--+--     * 'LayoutAxis'+--+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ExistentialQuantification #-} -module Graphics.Rendering.Chart.Layout where+module Graphics.Rendering.Chart.Layout+  ( -- * Types+    Layout(..)+  , LayoutLR(..)+  , LayoutAxis(..)+  , LayoutPick(..)+  , StackedLayouts(..)+  , StackedLayout(..)+  -- , LegendItem  haddock complains about this being missing, but from what?+  , MAxisFn -import qualified Graphics.Rendering.Cairo as C+    -- * Rendering+  , layoutToRenderable+  , layoutToGrid+  , layoutLRToRenderable+  , layoutLRToGrid+  , renderStackedLayouts +    -- * LayoutAxis lenses+  , laxis_title_style+  , laxis_title+  , laxis_style+  , laxis_generate+  , laxis_override+  , laxis_reverse++    -- * Layout lenses+  , layout_background+  , layout_plot_background+  , layout_title+  , layout_title_style+  , layout_x_axis+  , layout_top_axis_visibility+  , layout_bottom_axis_visibility+  , layout_y_axis+  , layout_left_axis_visibility+  , layout_right_axis_visibility+  , layout_margin+  , layout_plots+  , layout_legend+  , layout_grid_last++  , layout_axes_styles+  , layout_axes_title_styles+  , layout_all_font_styles+  , layout_foreground++    -- * LayoutLR lenses+  , layoutlr_background+  , layoutlr_plot_background+  , layoutlr_title+  , layoutlr_title_style+  , layoutlr_x_axis+  , layoutlr_top_axis_visibility+  , layoutlr_bottom_axis_visibility+  , layoutlr_left_axis+  , layoutlr_right_axis+  , layoutlr_left_axis_visibility+  , layoutlr_right_axis_visibility+  , layoutlr_plots+  , layoutlr_legend+  , layoutlr_margin+  , layoutlr_grid_last++  , layoutlr_axes_styles+  , layoutlr_axes_title_styles+  , layoutlr_all_font_styles+  , layoutlr_foreground++    -- * StackedLayouts lenses+  , slayouts_layouts+  , slayouts_compress_legend+  ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif+ import Graphics.Rendering.Chart.Axis-import Graphics.Rendering.Chart.Types+import Graphics.Rendering.Chart.Geometry+import Graphics.Rendering.Chart.Drawing+import Graphics.Rendering.Chart.Utils import Graphics.Rendering.Chart.Plot+import Graphics.Rendering.Chart.Legend import Graphics.Rendering.Chart.Renderable+import Graphics.Rendering.Chart.Grid import Control.Monad+import Control.Lens hiding (at)+import Data.Colour+import Data.Colour.Names (white)+import Data.Default.Class -data HAxis = HA_Top | HA_Bottom deriving (Eq)-data VAxis = VA_Left | VA_Right deriving (Eq)+-- | A @MAxisFn@ is a function that generates an (optional) axis+--   given the points plotted against that axis.+type MAxisFn t = [t] -> Maybe (AxisData t) --- | 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)-}+-- | Type of axis that is used in 'Layout' and 'LayoutLR'.+--+--   To generate the actual axis type ('AxisData' and 'AxisT')+--   the '_laxis_generate' function is called and custom settings+--   are applied with '_laxis_override'. Note that the 'AxisVisibility'+--   values in 'Layout' and 'LayoutLR' override visibility related+--   settings of the axis.+data LayoutAxis x = LayoutAxis+  { _laxis_title_style :: FontStyle+    -- ^ Font style to use for the axis title.+  , _laxis_title       :: String+    -- ^ Title displayed for the axis.+  , _laxis_style       :: AxisStyle+    -- ^ Axis style applied. -instance ToRenderable Layout1 where-    toRenderable = layout1ToRenderable+  , _laxis_generate    :: AxisFn x+    -- ^ Function that generates the axis data, based upon the+    --   points plotted. The default value is 'autoAxis'. -layout1ToRenderable l =-   fillBackground (layout1_background l) (-       vertical [-       (0, addMargins (lm/2,0,0,0)    title),-       (1, addMargins (lm,lm,lm,lm) plotArea),-       (0, horizontal [ (0,mkLegend VA_Left),(1,emptyRenderable),(0, mkLegend VA_Right) ] )-       ]-     )+  , _laxis_override    :: AxisData x -> AxisData x+    -- ^ Function that can be used to override the generated axis data.+    --   The default value is 'id'.++  , _laxis_reverse     :: Bool+    -- ^ True if left to right (bottom to top) is to show descending values.++  }++-- | Information on what is at a specifc location of a 'Layout' or 'LayoutLR'.+--   This is delivered by the 'PickFn' of a 'Renderable'.+data LayoutPick x y1 y2 = LayoutPick_Legend String           -- ^ A legend entry.+                        | LayoutPick_Title String            -- ^ The title.+                        | LayoutPick_XTopAxisTitle String    -- ^ The title of the top x axis.+                        | LayoutPick_XBottomAxisTitle String -- ^ The title of the bottom x axis.+                        | LayoutPick_YLeftAxisTitle String   -- ^ The title of the left y axis.+                        | LayoutPick_YRightAxisTitle String  -- ^ The title of the right y axis.+                        | LayoutPick_PlotArea x y1 y2        -- ^ The plot area at the given plot coordinates.+                        | LayoutPick_XTopAxis x              -- ^ The top x axis at the given plot coordinate.+                        | LayoutPick_XBottomAxis x           -- ^ The bottom x axis at the given plot coordinate.+                        | LayoutPick_YLeftAxis y1            -- ^ The left y axis at the given plot coordinate.+                        | LayoutPick_YRightAxis y2           -- ^ The right y axis at the given plot coordinate.+                          deriving (Show)++type LegendItem = (String,Rect -> BackendProgram ())++-- | A Layout value is a single plot area, with single x and y+--   axis. The title is at the top and the legend at the bottom. It's+--   parametrized by the types of values to be plotted on the x+--   and y axes.+data Layout x y = Layout+  { _layout_background      :: FillStyle+    -- ^ How to fill the background of everything.+  , _layout_plot_background :: Maybe FillStyle+    -- ^ How to fill the background of the plot,+    --   if different from the overall background.++  , _layout_title           :: String+    -- ^ Title to display above the chart.+  , _layout_title_style     :: FontStyle+    -- ^ Font style to use for the title.++  , _layout_x_axis                 :: LayoutAxis x+    -- ^ Rules to generate the x axis.+  , _layout_top_axis_visibility    :: AxisVisibility+    -- ^ Visibility options for the top axis.+  , _layout_bottom_axis_visibility :: AxisVisibility+    -- ^ Visibility options for the bottom axis.++  , _layout_y_axis                :: LayoutAxis y+    -- ^ Rules to generate the y axis.+  , _layout_left_axis_visibility  :: AxisVisibility+    -- ^ Visibility options for the left axis.+  , _layout_right_axis_visibility :: AxisVisibility+    -- ^ Visibility options for the right axis.++  , _layout_plots           :: [Plot x y]+    -- ^ The data sets to plot in the chart.+    --   They are plotted over each other.++  , _layout_legend          :: Maybe LegendStyle+    -- ^ How to style the legend.+  , _layout_margin          :: Double+    -- ^ The margin distance to use.+  , _layout_grid_last       :: Bool+    -- ^ If the grid shall be rendered+    --   beneath (@False@) or over (@True@) all plots.+  }++instance (Ord x, Ord y) => ToRenderable (Layout x y) where+  toRenderable = setPickFn nullPickFn . layoutToRenderable++-- | Render the given 'Layout'.+layoutToRenderable :: forall x y . (Ord x, Ord y) => Layout x y -> Renderable (LayoutPick x y y)+layoutToRenderable l = fillBackground (_layout_background l) $ gridToRenderable (layoutToGrid l)++layoutToGrid :: forall x y . (Ord x, Ord y) => Layout x y -> Grid (Renderable (LayoutPick x y y))+layoutToGrid l = grid   where-    lm = layout1_margin l+    lp :: Grid a -> a -> Grid a+    lp = case maybe LegendBelow _legend_position $ _layout_legend l of+              LegendAbove -> flip wideAbove+              LegendBelow -> aboveWide+              LegendRight -> besideTall+              LegendLeft  -> flip tallBeside -    title = label (layout1_title_style l) HTA_Centre VTA_Centre (layout1_title l)+    title = titleToRenderable lm (_layout_title_style l) (_layout_title l)+    plotArea = addMarginsToGrid (lm,lm,lm,lm) (layoutPlotAreaToGrid l)+    legend = renderLegend l (getLegendItems l)+    grid = title `wideAbove` (plotArea `lp` legend)+    lm = _layout_margin l -    mkLegend va = 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))+getLayoutXVals :: Layout x y -> [x]+getLayoutXVals l = concatMap (fst . _plot_all_points) (_layout_plots l) -    plotArea = grid [0,0,1,0,0] [0,0,1,0,0]-       [ [er,            er,        (1,atitle ta), er,        er       ],-         [er,            (1,tl),    (1,taxis),     (1,tr),    er       ],-         [(1,atitle la), (1,laxis), (0,plots),     (1,raxis), (1,atitle ra)],-         [er,            (1,bl),    (1,baxis),     (1,br),    er       ],-         [er,            er,        (1,atitle ba), er,        er       ] ]+-- | Extract all 'LegendItem's from the plots of a 'Layout'.+getLegendItems :: Layout x y -> [LegendItem]+getLegendItems l = concat [ _plot_legend p | p <- _layout_plots l ] -    atitle Nothing = emptyRenderable-    atitle (Just (AxisT e a)) = rlabel (axis_title_style a) ha va rot (axis_title a)-      where (ha,va,rot) = case e of E_Top -> (HTA_Centre,VTA_Bottom,0)-                                    E_Bottom -> (HTA_Centre,VTA_Top,0)-                                    E_Left -> (HTA_Right,VTA_Centre,90)-                                    E_Right -> (HTA_Left,VTA_Centre,90)+-- | Render the given 'LegendItem's for a 'Layout'.+renderLegend :: Layout x y -> [LegendItem] -> Renderable (LayoutPick x y y)+renderLegend l legItems = gridToRenderable g+  where+    g      = besideN [ tval $ mkLegend (_layout_legend l) (_layout_margin l) legItems+                     , weights (1,1) $ tval emptyRenderable ] -    plots = Renderable {-        minsize=return (0,0),-        render=renderPlots l+-- | Render the plot area of a 'Layout'. This consists of the+--   actual plot area with all plots, the axis and their titles.+layoutPlotAreaToGrid :: forall x y. (Ord x, Ord y) =>+                        Layout x y -> Grid (Renderable (LayoutPick x y y))+layoutPlotAreaToGrid l = buildGrid LayoutGridElements{+  lge_plots = mfill (_layout_plot_background l) $ plotsToRenderable l,+  lge_taxis = (tAxis,_laxis_title $ _layout_x_axis l, _laxis_title_style $ _layout_x_axis l),+  lge_baxis = (bAxis,_laxis_title $ _layout_x_axis l, _laxis_title_style $ _layout_x_axis l),+  lge_laxis = (lAxis,_laxis_title $ _layout_y_axis l, _laxis_title_style $ _layout_y_axis l),+  lge_raxis = (rAxis,"", def),+  lge_margin = _layout_margin l+  }+  where+    xvals = [ x | p <- _layout_plots l, x <- fst $ _plot_all_points p]+    yvals = [ y | p <- _layout_plots l, y <- snd $ _plot_all_points p]++    bAxis = mkAxis E_Bottom (overrideAxisVisibility l _layout_x_axis _layout_bottom_axis_visibility) xvals+    tAxis = mkAxis E_Top    (overrideAxisVisibility l _layout_x_axis _layout_top_axis_visibility   ) xvals+    lAxis = mkAxis E_Left   (overrideAxisVisibility l _layout_y_axis _layout_left_axis_visibility  ) yvals+    rAxis = mkAxis E_Right  (overrideAxisVisibility l _layout_y_axis _layout_right_axis_visibility ) yvals+    axes = (bAxis,lAxis,tAxis,rAxis)++    plotsToRenderable lxy = Renderable {+        minsize = return (0,0),+        render  = renderPlots lxy     } -    (ba,la,ta,ra) = getAxes l-    baxis = maybe emptyRenderable toRenderable ba-    taxis = maybe emptyRenderable toRenderable ta-    laxis = maybe emptyRenderable toRenderable la-    raxis = maybe emptyRenderable toRenderable ra+    -- | Render the plots of a 'Layout' to a plot area of given size.+    renderPlots :: Layout x y -> RectSize -> BackendProgram (PickFn (LayoutPick x y y))+    renderPlots lxy sz@(w,h) = do+        unless (_layout_grid_last lxy) (renderGrids sz axes)+        withClipRegion (Rect (Point 0 0) (Point w h)) $+          mapM_ rPlot (_layout_plots lxy)+        when (_layout_grid_last lxy) (renderGrids sz axes)+        return pickfn+      where+        rPlot = renderSinglePlot sz bAxis lAxis -    tl = axesSpacer fst ta fst la-    bl = axesSpacer fst ba snd la-    tr = axesSpacer snd ta fst ra-    br = axesSpacer snd ba snd ra+        xr = (0, w)+        yr = (h, 0) -    er = (0,emptyRenderable)+        pickfn :: PickFn (LayoutPick x y y)+        pickfn (Point x y) = do  -- Maybe monad+            xat <- mxat+            yat <- myat+            return (LayoutPick_PlotArea (mapx xat x) (mapy yat y) (mapy yat y))+          where+            mxat = case (bAxis,tAxis) of+                (Just at,_)       -> Just at+                (_,Just at)       -> Just at+                (Nothing,Nothing) -> Nothing+            myat = case (lAxis,rAxis) of+                (Just at,_)   -> Just at+                (_,Just at)   -> Just at+                (Nothing,Nothing)   -> Nothing+            mapx (AxisT _ _ rev ad) = _axis_tropweiv ad (optPairReverse rev xr)+            mapy (AxisT _ _ rev ad) = _axis_tropweiv ad (optPairReverse rev yr) -renderPlots l r@(Rect p1 p2) = do-    -- render the plots-    C.save-    setClipRegion p1 p2 -    mapM_ (rPlot r) (layout1_plots l)-    C.restore+-- | Empty 'Layout' without title and plots. The background is white and+--   the grid is drawn beneath all plots. There will be a legend. The top+--   and right axis will not be visible.+instance (PlotValue x, PlotValue y) => Default (Layout x y) where+  def = Layout+    { _layout_background      = solidFillStyle $ opaque white+    , _layout_plot_background = Nothing -    -- render the axes grids-    maybeM () (renderAxisGrid r) tAxis-    maybeM () (renderAxisGrid r) bAxis-    maybeM () (renderAxisGrid r) lAxis-    maybeM () (renderAxisGrid r) rAxis+    , _layout_title           = ""+    , _layout_title_style     = def { _font_size   = 15+                                    , _font_weight = FontWeightBold } +    , _layout_x_axis                 = def+    , _layout_top_axis_visibility    = def { _axis_show_line   = False+                                           , _axis_show_ticks  = False+                                           , _axis_show_labels = False }+    , _layout_bottom_axis_visibility = def+    , _layout_y_axis                 = def+    , _layout_left_axis_visibility   = def+    , _layout_right_axis_visibility  = def { _axis_show_line   = False+                                           , _axis_show_ticks  = False+                                           , _axis_show_labels = False }++    , _layout_margin          = 10+    , _layout_plots           = []+    , _layout_legend          = Just def+    , _layout_grid_last       = False+    }++----------------------------------------------------------------------++-- | A LayoutLR value is a single plot area, with an x axis and+--   independent left and right y axes, with a title at the top;+--   legend at the bottom. It's parametrized by the types of values+--   to be plotted on the x and two y axes.+data LayoutLR x y1 y2 = LayoutLR+  { _layoutlr_background      :: FillStyle+    -- ^ How to fill the background of everything.+  , _layoutlr_plot_background :: Maybe FillStyle+    -- ^ How to fill the background of the plot,+    --   if different from the overall background.++  , _layoutlr_title           :: String+    -- ^ Title to display above the chart.+  , _layoutlr_title_style     :: FontStyle+    -- ^ Font style to use for the title.++  , _layoutlr_x_axis                 :: LayoutAxis x+    -- ^ Rules to generate the x axis.+  , _layoutlr_top_axis_visibility    :: AxisVisibility+    -- ^ Visibility options for the top axis.+  , _layoutlr_bottom_axis_visibility :: AxisVisibility+    -- ^ Visibility options for the bottom axis.++  , _layoutlr_left_axis             :: LayoutAxis y1+    -- ^ Rules to generate the left y axis.+  , _layoutlr_left_axis_visibility  :: AxisVisibility+    -- ^ Visibility options for the left axis.+  , _layoutlr_right_axis            :: LayoutAxis y2+    -- ^ Rules to generate the right y axis.+  , _layoutlr_right_axis_visibility :: AxisVisibility+    -- ^ Visibility options for the right axis.++  , _layoutlr_plots      :: [Either (Plot x y1) (Plot x y2)]+    -- ^ The data sets to plot in the chart.+    --   They are plotted over each other.+    --   The either type associates the plot with the+    --   left or right y axis.++  , _layoutlr_legend          :: Maybe LegendStyle+    -- ^ How to style the legend.+  , _layoutlr_margin          :: Double+    -- ^ The margin distance to use.+  , _layoutlr_grid_last       :: Bool+    -- ^ If the grid shall be rendered+    --   beneath (@False@) or over (@True@) all plots.+  }++instance (Ord x, Ord yl, Ord yr) => ToRenderable (LayoutLR x yl yr) where+  toRenderable = setPickFn nullPickFn . layoutLRToRenderable++-- | Render the given 'LayoutLR'.+layoutLRToRenderable :: forall x yl yr . (Ord x, Ord yl, Ord yr)+                     => LayoutLR x yl yr -> Renderable (LayoutPick x yl yr)+layoutLRToRenderable l = fillBackground (_layoutlr_background l)+                       $ gridToRenderable (layoutLRToGrid l)++layoutLRToGrid :: forall x yl yr . (Ord x, Ord yl, Ord yr)+                     => LayoutLR x yl yr -> Grid (Renderable (LayoutPick x yl yr))+layoutLRToGrid l = grid   where-    (bAxis,lAxis,tAxis,rAxis) = getAxes l+    grid = titleToRenderable lm (_layoutlr_title_style l) (_layoutlr_title l)+           `wideAbove`+           addMarginsToGrid (lm,lm,lm,lm) (layoutLRPlotAreaToGrid l)+           `aboveWide`+           renderLegendLR l (getLegendItemsLR l)+    lm = _layoutlr_margin l -    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 ()+getLayoutLRXVals :: LayoutLR x yl yr -> [x]+getLayoutLRXVals l = concatMap deEither $ _layoutlr_plots l+  where+    deEither :: Either (Plot x yl) (Plot x yr) -> [x]+    deEither (Left x)  = fst $ _plot_all_points x+    deEither (Right x) = fst $ _plot_all_points x +-- | Extract all 'LegendItem's from the plots of a 'LayoutLR'.+--   Left and right plot legend items are still separated.+getLegendItemsLR :: LayoutLR x yl yr -> ([LegendItem],[LegendItem])+getLegendItemsLR l = (+    concat [ _plot_legend p | (Left p ) <- _layoutlr_plots l ],+    concat [ _plot_legend p | (Right p) <- _layoutlr_plots l ]+    )++-- | Render the given 'LegendItem's for a 'LayoutLR'.+renderLegendLR :: LayoutLR x yl yr -> ([LegendItem],[LegendItem]) -> Renderable (LayoutPick x yl yr)+renderLegendLR l (lefts,rights) = gridToRenderable g+  where+    g      = besideN [ tval $ mkLegend (_layoutlr_legend l) (_layoutlr_margin l) lefts+                     , weights (1,1) $ tval emptyRenderable+                     , tval $ mkLegend (_layoutlr_legend l) (_layoutlr_margin l) rights ]+    -- lm     = _layoutlr_margin l++layoutLRPlotAreaToGrid :: forall x yl yr. (Ord x, Ord yl, Ord yr)+                       => LayoutLR x yl yr+                       -> Grid (Renderable (LayoutPick x yl yr))+layoutLRPlotAreaToGrid l = buildGrid LayoutGridElements{+  lge_plots = mfill (_layoutlr_plot_background l) $ plotsToRenderable l,+  lge_taxis = (tAxis,_laxis_title $ _layoutlr_x_axis l, _laxis_title_style $ _layoutlr_x_axis l),+  lge_baxis = (bAxis,_laxis_title $ _layoutlr_x_axis l, _laxis_title_style $ _layoutlr_x_axis l),+  lge_laxis = (lAxis,_laxis_title $ _layoutlr_left_axis l, _laxis_title_style $ _layoutlr_left_axis l),+  lge_raxis = (rAxis,_laxis_title $ _layoutlr_right_axis l, _laxis_title_style $ _layoutlr_right_axis l),+  lge_margin = _layoutlr_margin l+  }+  where+    xvals =  [ x | (Left p)  <- _layoutlr_plots l, x <- fst $ _plot_all_points p]+          ++ [ x | (Right p) <- _layoutlr_plots l, x <- fst $ _plot_all_points p]+    yvalsL = [ y | (Left p)  <- _layoutlr_plots l, y <- snd $ _plot_all_points p]+    yvalsR = [ y | (Right p) <- _layoutlr_plots l, y <- snd $ _plot_all_points p]++    bAxis = mkAxis E_Bottom (overrideAxisVisibility l _layoutlr_x_axis _layoutlr_bottom_axis_visibility) xvals+    tAxis = mkAxis E_Top    (overrideAxisVisibility l _layoutlr_x_axis _layoutlr_top_axis_visibility   ) xvals+    lAxis = mkAxis E_Left   (overrideAxisVisibility l _layoutlr_left_axis  _layoutlr_left_axis_visibility ) yvalsL+    rAxis = mkAxis E_Right  (overrideAxisVisibility l _layoutlr_right_axis _layoutlr_right_axis_visibility) yvalsR+    axes = (bAxis,lAxis,tAxis,rAxis)++    plotsToRenderable llr = Renderable {+        minsize = return (0,0),+        render  = renderPlots llr+    }++    renderPlots :: LayoutLR x yl yr -> RectSize -> BackendProgram (PickFn (LayoutPick x yl yr))+    renderPlots llr sz@(w,h) = do+        unless (_layoutlr_grid_last llr) (renderGrids sz axes)+        withClipRegion (Rect (Point 0 0) (Point w h)) $+          mapM_ rPlot (_layoutlr_plots llr)+        when (_layoutlr_grid_last llr) (renderGrids sz axes)+        return pickfn+      where+        rPlot (Left  p) = renderSinglePlot sz bAxis lAxis p+        rPlot (Right p) = renderSinglePlot sz bAxis rAxis p++        xr = (0, w)+        yr = (h, 0)++        pickfn (Point x y) = do  -- Maybe monad+            xat <- mxat+            (yatL,yatR) <- myats+            return (LayoutPick_PlotArea (mapx xat x) (mapy yatL y) (mapy yatR y))+          where+            mxat = case (bAxis,tAxis) of+                (Just at,_)       -> Just at+                (_,Just at)       -> Just at+                (Nothing,Nothing) -> Nothing+            myats = case (lAxis,rAxis) of+                (Just at1,Just at2) -> Just (at1,at2)+                (_,_)   -> Nothing+            mapx (AxisT _ _ rev ad) = _axis_tropweiv ad (optPairReverse rev xr)+            mapy (AxisT _ _ rev ad) = _axis_tropweiv ad (optPairReverse rev yr)++----------------------------------------------------------------------++-- | A layout with its y type hidden, so that it can be stacked+--   with other layouts with differing y axis, but the same x axis.+--   See 'StackedLayouts'.+data StackedLayout x = forall y     . (Ord y)          => StackedLayout (Layout x y)+                       -- ^ A 'Layout' to stack.+                     | forall yl yr . (Ord yl, Ord yr) => StackedLayoutLR (LayoutLR x yl yr)+                       -- ^ A 'LayoutLR' to stack.++-- | A container for a set of vertically 'StackedLayout's.+--   The x axis of the different layouts will be aligned.+data StackedLayouts x = StackedLayouts+  { _slayouts_layouts :: [StackedLayout x]+    -- ^ The stacked layouts from top (first element) to bottom (last element).+  , _slayouts_compress_legend :: Bool+    -- ^ If the different legends shall be combined in one legend at the bottom.+  }++-- | A empty 'StackedLayout' with compressions applied.+instance Default (StackedLayouts x) where+  def = StackedLayouts [] True++++instance Ord x => ToRenderable (StackedLayouts x) where+  toRenderable = renderStackedLayouts+++-- | Render several layouts with the same x-axis type and range,+--   vertically stacked so that their origins and x-values are aligned.+--+--   The legends from all the charts may be optionally combined, and shown+--   once on the bottom chart. See 'StackedLayouts' for further information.+renderStackedLayouts :: forall x. (Ord x) => StackedLayouts x -> Renderable ()+renderStackedLayouts (StackedLayouts{_slayouts_layouts=[]}) = emptyRenderable+renderStackedLayouts slp@(StackedLayouts{_slayouts_layouts=sls@(sl1:_)}) = gridToRenderable g+  where+    g = fullOverlayUnder (fillBackground bg emptyRenderable)+      $ foldr (above.mkGrid) nullt (zip sls [0,1..])++    mkGrid :: (StackedLayout x, Int) -> Grid (Renderable ())+    mkGrid (sl, i)+        = titleR+          `wideAbove`+          addMarginsToGrid (lm,lm,lm,lm) (mkPlotArea usedAxis)+          `aboveWide`+          (if showLegend then legendR else emptyRenderable)+      where+        titleR = case sl of+                   StackedLayout l -> noPickFn $ titleToRenderable (_layout_margin l) (_layout_title_style l) (_layout_title l)+                   StackedLayoutLR l -> noPickFn $ titleToRenderable (_layoutlr_margin l) (_layoutlr_title_style l) (_layoutlr_title l)+        legendR = case sl of+                    StackedLayout l -> noPickFn $ renderLegend l $ fst legenditems+                    StackedLayoutLR l -> noPickFn $ renderLegendLR l legenditems++        legenditems = case (_slayouts_compress_legend slp,isBottomPlot) of+            (False,_) -> case sl of+                           StackedLayout l -> (getLegendItems l, [])+                           StackedLayoutLR l -> getLegendItemsLR l+            (True,True) -> allLegendItems+            (True,False) -> ([],[])++        mkPlotArea :: LayoutAxis x -> Grid (Renderable ())+        mkPlotArea axis = case sl of+          StackedLayout l -> fmap noPickFn+                           $ layoutPlotAreaToGrid+                           $ l { _layout_x_axis = axis }+          StackedLayoutLR l -> fmap noPickFn+                             $ layoutLRPlotAreaToGrid+                             $ l { _layoutlr_x_axis = axis }++        showLegend = not (null (fst legenditems)) || not (null (snd legenditems))++        isBottomPlot = i == length sls - 1++        lm = case sl of+          StackedLayout l -> _layout_margin l+          StackedLayoutLR l -> _layoutlr_margin l++        xAxis :: LayoutAxis x+        xAxis = case sl of+          StackedLayout l -> _layout_x_axis l+          StackedLayoutLR l -> _layoutlr_x_axis l++        usedAxis :: LayoutAxis x+        usedAxis = xAxis+          { _laxis_generate = const (_laxis_generate xAxis all_xvals) }++    bg = case sl1 of+           StackedLayout l -> _layout_background l+           StackedLayoutLR l -> _layoutlr_background l++    getXVals :: StackedLayout x -> [x]+    getXVals (StackedLayout l) = getLayoutXVals l+    getXVals (StackedLayoutLR l) = getLayoutLRXVals l++    all_xvals = concatMap getXVals sls++    allLegendItems = (concatMap (fst.legendItems) sls, concatMap (snd.legendItems) sls)++    legendItems :: StackedLayout x -> ([LegendItem], [LegendItem])+    legendItems (StackedLayout l)   = (getLegendItems l, [])+    legendItems (StackedLayoutLR l) = getLegendItemsLR l++    noPickFn :: Renderable a -> Renderable ()+    noPickFn = mapPickFn (const ())++----------------------------------------------------------------------++addMarginsToGrid :: (Double,Double,Double,Double) -> Grid (Renderable a)+                 -> Grid (Renderable a)+addMarginsToGrid (t,b,l,r) g = aboveN [+     besideN [er, ts, er],+     besideN [ls, g,  rs],+     besideN [er, bs, er]+  ]+  where+    er = empty+    ts = tval $ spacer (0,t)+    ls = tval $ spacer (l,0)+    bs = tval $ spacer (0,b)+    rs = tval $ spacer (r,0)++titleToRenderable :: Double -> FontStyle -> String -> Renderable (LayoutPick x yl yr)+titleToRenderable _  _  "" = emptyRenderable+titleToRenderable lm fs s = addMargins (lm/2,0,0,0) (mapPickFn LayoutPick_Title title)+  where+    title = label fs HTA_Centre VTA_Centre s++mkLegend :: Maybe LegendStyle -> Double -> [LegendItem] -> Renderable (LayoutPick x yl yr)+mkLegend mls lm vals = case mls of+    Nothing -> emptyRenderable+    Just ls ->  case filter ((/="").fst) vals of+        []  -> emptyRenderable ;+        lvs -> addMargins (0,lm,lm,lm) $+                   mapPickFn LayoutPick_Legend $ legendToRenderable (Legend ls lvs)+++data LayoutGridElements x yl yr = LayoutGridElements {+  lge_plots :: Renderable (LayoutPick x yl yr),++  lge_taxis :: (Maybe (AxisT x),String,FontStyle),+  lge_baxis :: (Maybe (AxisT x),String,FontStyle),+  lge_laxis :: (Maybe (AxisT yl),String,FontStyle),+  lge_raxis :: (Maybe (AxisT yr),String,FontStyle),++  lge_margin :: Double+}++buildGrid :: (Ord x, Ord yl, Ord yr) => LayoutGridElements x yl yr -> Grid (Renderable (LayoutPick x yl yr))+buildGrid lge = layer2 `overlay` layer1+  where+    layer1 = aboveN+         [ besideN [er,     er,  er,    er   ]+         , besideN [er,     er,  er,    weights (1,1) plots ]+         ]++    layer2 = aboveN+         [ besideN [er,     er,  tl,    taxis,  tr,    er,  er       ]+         , besideN [ltitle, lam, laxis, er,     raxis, ram, rtitle   ]+         , besideN [er,     er,  bl,    baxis,  br,    er,  er       ]+         , besideN [er,     er,  er,    btitle, er,    er,  er       ]+         ]++    er = tval emptyRenderable++    plots = tval $ lge_plots lge++    (tdata,_,_)         = lge_taxis lge+    (bdata,blbl,bstyle) = lge_baxis lge+    (ldata,llbl,lstyle) = lge_laxis lge+    (rdata,rlbl,rstyle) = lge_raxis lge++    -- (ttitle,_) = mktitle HTA_Centre VTA_Bottom   0 tlbl tstyle LayoutPick_XTopAxisTitle+    (btitle,_) = mktitle HTA_Centre VTA_Top      0 blbl bstyle LayoutPick_XBottomAxisTitle+    (ltitle,lam) = mktitle HTA_Right  VTA_Centre 270 llbl lstyle LayoutPick_YLeftAxisTitle+    (rtitle,ram) = mktitle HTA_Left   VTA_Centre 270 rlbl rstyle LayoutPick_YRightAxisTitle++    baxis = tval $ maybe emptyRenderable+                         (mapPickFn LayoutPick_XBottomAxis . axisToRenderable) bdata+    taxis = tval $ maybe emptyRenderable+                         (mapPickFn LayoutPick_XTopAxis . axisToRenderable) tdata+    laxis = tval $ maybe emptyRenderable+                         (mapPickFn LayoutPick_YLeftAxis . axisToRenderable) ldata+    raxis = tval $ maybe emptyRenderable+                         (mapPickFn LayoutPick_YRightAxis . axisToRenderable) rdata++    tl = tval $ axesSpacer fst tdata fst ldata+    bl = tval $ axesSpacer fst bdata snd ldata+    tr = tval $ axesSpacer snd tdata fst rdata+    br = tval $ axesSpacer snd bdata snd rdata++    mktitle :: HTextAnchor -> VTextAnchor+            -> Double+            -> String -> FontStyle+            -> (String -> LayoutPick x yl yr)+            -> ( Grid (Renderable (LayoutPick x yl yr))+               , Grid (Renderable (LayoutPick x yl yr)) )+    mktitle ha va rot lbl style pf = if lbl == "" then (er,er) else (labelG,gapG)+      where+        labelG = tval $ mapPickFn pf $ rlabel style ha va rot lbl+        gapG = tval $ spacer (lge_margin lge,0)++-- | Render the grids of the given axis to a plot area of given size.+renderGrids :: RectSize -> (Maybe (AxisT x), Maybe (AxisT yl), Maybe (AxisT x), Maybe (AxisT yr)) -> BackendProgram ()+renderGrids sz (bAxis, lAxis, tAxis, rAxis) = do+  maybeM () (renderAxisGrid sz) tAxis+  maybeM () (renderAxisGrid sz) bAxis+  maybeM () (renderAxisGrid sz) lAxis+  maybeM () (renderAxisGrid sz) rAxis++-- | Swap the contents of the pair depending on the flag.+optPairReverse :: Bool -> (a,a) -> (a,a)+optPairReverse rev (a,b) = if rev then (b,a) else (a,b)++-- | Render a single set of plot data onto a plot area of given size using+--   the given x and y axis.+renderSinglePlot :: RectSize -> Maybe (AxisT x) -> Maybe (AxisT y) -> Plot x y -> BackendProgram ()+renderSinglePlot (w, h) (Just (AxisT _ _ xrev xaxis)) (Just (AxisT _ _ yrev yaxis)) p =+  let xr = optPairReverse xrev (0, w)+      yr = optPairReverse yrev (h, 0)+      -- yrange = if yrev then (0, h) else (h, 0)+      pmfn (x,y) = Point (mapv xr (_axis_viewport xaxis xr) x)+                         (mapv yr (_axis_viewport yaxis yr) y)+      mapv lims _ LMin       = fst lims+      mapv lims _ LMax       = snd lims+      mapv _    f (LValue v) = f v+  in _plot_render p pmfn+renderSinglePlot _ _ _ _ = return ()++axesSpacer :: (Ord x, Ord y)+           => ((Double, Double) -> Double) -> Maybe (AxisT x)+           -> ((Double, Double) -> Double) -> Maybe (AxisT y)+           -> Renderable a axesSpacer f1 a1 f2 a2 = embedRenderable $ do     oh1 <- maybeM (0,0) axisOverhang a1     oh2 <- maybeM (0,0) axisOverhang a2     return (spacer (f1 oh1, f2 oh2)) -maybeM v = maybe (return v)+-- | Construct a axis for the given edge using the attributes+--   from a 'LayoutAxis' the given values.+mkAxis :: RectEdge -> LayoutAxis z -> [z] -> Maybe (AxisT z)+mkAxis edge laxis vals = if axisVisible+                           then Just $ AxisT edge style rev adata+                           else Nothing+  where+    style = _laxis_style laxis+    rev   = _laxis_reverse laxis+    adata = _laxis_override laxis (_laxis_generate laxis vals)+    vis   = _axis_visibility adata+    axisVisible = _axis_show_labels vis || _axis_show_line vis || _axis_show_ticks vis -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)+-- | Override the visibility of a selected axis with the selected 'AxisVisibility'.+overrideAxisVisibility :: layout+                       -> (layout -> LayoutAxis z)+                       -> (layout -> AxisVisibility)+                       -> LayoutAxis z+overrideAxisVisibility ly selAxis selVis =+  let vis = selVis ly+  in (selAxis ly) { _laxis_override = (\ad -> ad { _axis_visibility = vis })+                                    . _laxis_override (selAxis ly)+                  } +mfill :: Maybe FillStyle -> Renderable a -> Renderable a+mfill Nothing   = id+mfill (Just fs) = fillBackground fs -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  ]+-- | Empty 'LayoutLR' without title and plots. The background is white and+--   the grid is drawn beneath all plots. There will be a legend. The top+--   axis will not be visible.+instance (PlotValue x, PlotValue y1, PlotValue y2) => Default (LayoutLR x y1 y2) where+  def = LayoutLR+    { _layoutlr_background      = solidFillStyle $ opaque white+    , _layoutlr_plot_background = Nothing +    , _layoutlr_title           = ""+    , _layoutlr_title_style     = def { _font_size   = 15+                                      , _font_weight = FontWeightBold } -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-}+    , _layoutlr_x_axis                 = def+    , _layoutlr_top_axis_visibility    = def { _axis_show_line   = False+                                             , _axis_show_ticks  = False+                                             , _axis_show_labels = False }+    , _layoutlr_bottom_axis_visibility = def +    , _layoutlr_left_axis           = def+    , _layoutlr_left_axis_visibility  = def+    , _layoutlr_right_axis          = def+    , _layoutlr_right_axis_visibility = def++    , _layoutlr_plots      = []++    , _layoutlr_legend          = Just def+    , _layoutlr_margin          = 10+    , _layoutlr_grid_last       = False+    }++instance PlotValue t => Default (LayoutAxis t) where+  def = LayoutAxis+    { _laxis_title_style = def { _font_size=10 }+    , _laxis_title       = ""+    , _laxis_style       = def+    , _laxis_generate    = autoAxis+    , _laxis_override    = id+    , _laxis_reverse     = False+    }++----------------------------------------------------------------------+-- Template haskell to derive an instance of Data.Accessor.Accessor+-- for each field.+$( makeLenses ''Layout )+$( makeLenses ''LayoutLR )+$( makeLenses ''LayoutAxis )+$( makeLenses ''StackedLayouts )++-- | Setter to update all axis styles on a `Layout`+layout_axes_styles :: Setter' (Layout x y) AxisStyle+layout_axes_styles = sets $ \af ->+    (layout_x_axis . laxis_style %~ af) .+    (layout_y_axis . laxis_style %~ af)++-- | Setter to update all the axes title styles on a `Layout`+layout_axes_title_styles :: Setter' (Layout x y) FontStyle+layout_axes_title_styles = sets $ \af ->+    (layout_x_axis . laxis_title_style %~ af) .+    (layout_y_axis . laxis_title_style %~ af)++-- | Setter to update all the font styles on a `Layout`+layout_all_font_styles :: Setter' (Layout x y) FontStyle+layout_all_font_styles = sets $ \af ->+    (layout_axes_title_styles %~ af) .+    (layout_x_axis . laxis_style . axis_label_style %~ af) .+    (layout_y_axis . laxis_style . axis_label_style %~ af) .+    (layout_legend . _Just . legend_label_style %~ af) .+    (layout_title_style %~ af)++-- | Setter to update the foreground color of core chart elements on a `Layout`+layout_foreground ::  Setter' (Layout x y) (AlphaColour Double)+layout_foreground = sets $ \af ->+    (layout_all_font_styles . font_color %~ af) .+    (layout_axes_styles . axis_line_style . line_color %~ af)++-- | Setter to update all axis styles on a `LayoutLR`+layoutlr_axes_styles :: Setter' (LayoutLR x y1 y2) AxisStyle+layoutlr_axes_styles = sets $ \af ->+    (layoutlr_x_axis . laxis_style %~ af) .+    (layoutlr_left_axis . laxis_style %~ af) .+    (layoutlr_right_axis . laxis_style %~ af)++-- | Setter to update all the axes title styles on a `LayoutLR`+layoutlr_axes_title_styles :: Setter' (LayoutLR x y1 y2) FontStyle+layoutlr_axes_title_styles = sets $ \af ->+    (layoutlr_x_axis . laxis_title_style %~ af) .+    (layoutlr_left_axis . laxis_title_style %~ af) .+    (layoutlr_right_axis . laxis_title_style %~ af)++-- | Setter to update all the font styles on a `LayoutLR`+layoutlr_all_font_styles :: Setter' (LayoutLR x y1 y2) FontStyle+layoutlr_all_font_styles = sets $ \af ->+    (layoutlr_axes_title_styles %~ af) .+    (layoutlr_x_axis . laxis_style . axis_label_style %~ af) .+    (layoutlr_left_axis . laxis_style . axis_label_style %~ af) .+    (layoutlr_right_axis . laxis_style . axis_label_style %~ af) .+    (layoutlr_legend . _Just . legend_label_style %~ af) .+    (layoutlr_title_style %~ af)++-- | Setter to update the foreground color of core chart elements on a `LayoutLR`+layoutlr_foreground ::  Setter' (LayoutLR x y1 y2) (AlphaColour Double)+layoutlr_foreground = sets $ \af ->+    (layoutlr_all_font_styles . font_color %~ af) .+    (layoutlr_axes_styles . axis_line_style . line_color %~ af)
+ Graphics/Rendering/Chart/Legend.hs view
@@ -0,0 +1,125 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Graphics.Rendering.Chart.Legend+-- Copyright   :  (c) Tim Docker 2006, 2014+-- License     :  BSD-style (see chart/COPYRIGHT)+-- +-- Types and functions for handling the legend(s) on a chart. A legend+-- is an area on the chart used to label the plotted values.+{-# LANGUAGE TemplateHaskell #-}++module Graphics.Rendering.Chart.Legend(+    Legend(..),+    LegendStyle(..),+    LegendOrientation(..),+    LegendPosition(..),+    legendToRenderable,+    legend_label_style,+    legend_margin,+    legend_plot_size,+    legend_orientation,+    legend_position+) where++import Data.List (partition,intersperse)+import Control.Lens+import Data.Default.Class++import Graphics.Rendering.Chart.Geometry+import Graphics.Rendering.Chart.Drawing+import Graphics.Rendering.Chart.Renderable+import Graphics.Rendering.Chart.Grid++----------------------------------------------------------------------+-- Legend++data LegendStyle = LegendStyle {+   _legend_label_style :: FontStyle,+   _legend_margin      :: Double,+   _legend_plot_size   :: Double,+   _legend_orientation :: LegendOrientation,+   _legend_position    :: LegendPosition+}++-- | Legends can be constructed in two orientations: in rows+-- (where we specify the maximum number of columns), and in+-- columns (where we specify the maximum number of rows)+data LegendOrientation = LORows Int+                       | LOCols Int++-- | Defines the position of the legend, relative to the plot.+data LegendPosition = LegendAbove+                    | LegendBelow+                    | LegendRight+                    | LegendLeft++data Legend x y = Legend LegendStyle [(String, Rect -> BackendProgram ())]++instance ToRenderable (Legend x y) where+  toRenderable = setPickFn nullPickFn . legendToRenderable++legendToRenderable :: Legend x y -> Renderable String+legendToRenderable (Legend ls lvs) = gridToRenderable grid+  where+    grid :: Grid (Renderable String)+    grid = case _legend_orientation ls of+        LORows n -> mkGrid n aboveG besideG+        LOCols n -> mkGrid n besideG aboveG ++    aboveG, besideG :: [Grid (Renderable String)] -> Grid (Renderable String)+    aboveG = aboveN.intersperse ggap1+    besideG = besideN.intersperse ggap1++    mkGrid :: Int+              -> ([Grid (Renderable String)] -> Grid (Renderable String))+              -> ([Grid (Renderable String)] -> Grid (Renderable String))+              -> Grid (Renderable String)+    mkGrid n join1 join2 = join1 [ join2 (map rf ps1) | ps1 <- groups n ps ]++    ps  :: [(String, [Rect -> BackendProgram ()])]+    ps   = join_nub lvs++    rf :: (String, [Rect -> BackendProgram ()]) -> Grid (Renderable String)+    rf (title,rfs) = besideN [gpic,ggap2,gtitle]+      where+        gpic :: Grid (Renderable String)+        gpic = besideN $ intersperse ggap2 (map rp rfs)++        gtitle :: Grid (Renderable String)+        gtitle = tval $ lbl title++        rp :: (Rect -> BackendProgram ()) -> Grid (Renderable String)+        rp rfn = tval Renderable {+                     minsize = return (_legend_plot_size ls, 0),+                     render  = \(w,h) -> do+                         _ <- rfn (Rect (Point 0 0) (Point w h))+                         return (\_-> Just title)+                 }++    ggap1, ggap2 :: Grid (Renderable String)+    ggap1 = tval $ spacer (_legend_margin ls,_legend_margin ls / 2)+    ggap2 = tval $ spacer1 (lbl "X")++    lbl :: String -> Renderable String+    lbl = label (_legend_label_style ls) HTA_Left VTA_Centre++groups :: Int -> [a] -> [[a]]+groups _ [] = []+groups n vs = let (vs1,vs2) = splitAt n vs in vs1:groups n vs2++join_nub :: [(String, a)] -> [(String, [a])]+join_nub ((x,a1):ys) = case partition ((==x) . fst) ys of+                         (xs, rest) -> (x, a1:map snd xs) : join_nub rest+join_nub []          = []++instance Default LegendStyle where+  def = LegendStyle+    { _legend_label_style = def+    , _legend_margin      = 20+    , _legend_plot_size   = 20+    , _legend_orientation = LORows 4+    , _legend_position    = LegendBelow+    }++$( makeLenses ''LegendStyle )+
Graphics/Rendering/Chart/Plot.hs view
@@ -3,176 +3,36 @@ -- Module      :  Graphics.Rendering.Chart.Plot -- Copyright   :  (c) Tim Docker 2006 -- License     :  BSD-style (see chart/COPYRIGHT)+--+-- Code to calculate and render various types of plots.+--  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]-+    module Graphics.Rendering.Chart.Plot.Types,+    module Graphics.Rendering.Chart.Plot.Lines,+    module Graphics.Rendering.Chart.Plot.Vectors,+    module Graphics.Rendering.Chart.Plot.Points,+    module Graphics.Rendering.Chart.Plot.FillBetween,+    module Graphics.Rendering.Chart.Plot.ErrBars,+    module Graphics.Rendering.Chart.Plot.Candle,+    module Graphics.Rendering.Chart.Plot.Bars,+    module Graphics.Rendering.Chart.Plot.Hidden,+    module Graphics.Rendering.Chart.Plot.Annotation,+    module Graphics.Rendering.Chart.Plot.AreaSpots,+    module Graphics.Rendering.Chart.Plot.Pie,+    module Graphics.Rendering.Chart.Plot.Histogram,+) where -defaultPlotFillBetween = PlotFillBetween {-    plot_fillbetween_style=solidFillStyle 0.5 0.5 1.0,-    plot_fillbetween_values=[]-}+import Graphics.Rendering.Chart.Plot.Types+import Graphics.Rendering.Chart.Plot.Lines+import Graphics.Rendering.Chart.Plot.Vectors+import Graphics.Rendering.Chart.Plot.Points+import Graphics.Rendering.Chart.Plot.FillBetween+import Graphics.Rendering.Chart.Plot.ErrBars+import Graphics.Rendering.Chart.Plot.Candle+import Graphics.Rendering.Chart.Plot.Bars+import Graphics.Rendering.Chart.Plot.Hidden+import Graphics.Rendering.Chart.Plot.Annotation+import Graphics.Rendering.Chart.Plot.AreaSpots+import Graphics.Rendering.Chart.Plot.Pie+import Graphics.Rendering.Chart.Plot.Histogram
+ Graphics/Rendering/Chart/Plot/Annotation.hs view
@@ -0,0 +1,101 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Graphics.Rendering.Chart.Plot.Annotation+-- Copyright   :  (c) Tim Docker 2006, 2014+-- License     :  BSD-style (see chart/COPYRIGHT)+--+-- Show textual annotations on a chart.++{-# LANGUAGE TemplateHaskell #-}++module Graphics.Rendering.Chart.Plot.Annotation(+    PlotAnnotation(..),++    plot_annotation_hanchor,+    plot_annotation_vanchor,+    plot_annotation_angle,+    plot_annotation_style,+    plot_annotation_background,+    plot_annotation_offset,+    plot_annotation_values+) where++import Control.Lens+import Data.Default.Class+import Graphics.Rendering.Chart.Geometry+import Graphics.Rendering.Chart.Drawing+import Graphics.Rendering.Chart.Renderable+import Graphics.Rendering.Chart.Plot.Types+import Graphics.Rendering.Chart.Drawing+import Graphics.Rendering.Chart.Geometry+import Graphics.Rendering.Chart.Plot.Types++-- | Value for describing a series of text annotations+--   to be placed at arbitrary points on the graph. Annotations+--   can be rotated and styled.++data PlotAnnotation  x y = PlotAnnotation {+      _plot_annotation_hanchor :: HTextAnchor,+      _plot_annotation_vanchor :: VTextAnchor,+      _plot_annotation_angle   :: Double,+      -- ^ Angle, in degrees, to rotate the annotation about the anchor point.+      _plot_annotation_style   :: FontStyle,+      _plot_annotation_background :: Rectangle,+      -- ^ Rectangle which style determines the background of the annotation+      -- text and which '_rect_minsize' determines the additional width and+      -- height of the background area+      _plot_annotation_offset  :: Vector,+      _plot_annotation_values  :: [(x,y,String)]+}+++instance ToPlot PlotAnnotation where+    toPlot p = Plot {+      _plot_render = renderAnnotation p,+      _plot_legend = [],+      _plot_all_points = (map (^._1) vs , map (^._2) vs)+    }+      where+        vs = _plot_annotation_values p+++renderAnnotation :: PlotAnnotation x y -> PointMapFn x y -> BackendProgram ()+renderAnnotation p pMap = withFontStyle style $ do+                            mapM_ drawRect values+                            mapM_ drawOne values+    where hta = _plot_annotation_hanchor p+          vta = _plot_annotation_vanchor p+          values = _plot_annotation_values p+          angle =  _plot_annotation_angle p+          style =  _plot_annotation_style p+          offset = _plot_annotation_offset p+          rectangle = _plot_annotation_background p+          (x1,y1) = _rect_minsize rectangle+          drawRect (x,y,s) = do+              ts <- textSize s+              let (x2,y2) = (textSizeWidth ts, textSizeHeight ts)+                  Point x3 y3 = point x y+                  -- position of top-left vertex of the rectangle+                  xvp HTA_Left = x3 - x1 / 2+                  xvp HTA_Centre = x3 - (x1 + x2) / 2+                  xvp HTA_Right = x3 - x2 - x1 / 2+                  yvp VTA_Top = y3 - y1 / 2+                  yvp VTA_Centre = y3 - (y1 + y2) / 2+                  yvp VTA_Bottom = y3 - y2 - y1 / 2+                  yvp VTA_BaseLine = y3 - y1 / 2 - textSizeAscent ts+              drawRectangle (Point (xvp hta) (yvp vta) `pvadd` offset) rectangle{ _rect_minsize = (x1+x2,y1+y2) }+          drawOne (x,y,s) = drawTextsR hta vta angle (point x y) s+          point x y = pMap (LValue x, LValue y) `pvadd` offset++instance Default (PlotAnnotation x y) where+  def = PlotAnnotation+    { _plot_annotation_hanchor = HTA_Centre+    , _plot_annotation_vanchor = VTA_Centre+    , _plot_annotation_angle   = 0+    , _plot_annotation_style   = def+    , _plot_annotation_background = def+    , _plot_annotation_values  = []+    , _plot_annotation_offset  = Vector 0 0+    }++$( makeLenses ''PlotAnnotation )
+ Graphics/Rendering/Chart/Plot/AreaSpots.hs view
@@ -0,0 +1,192 @@+-- |+-- Module     :  Graphics.Rendering.Chart.Plot.AreaSpots+-- Copyright  :  (c) Malcolm Wallace 2009+-- License    :  BSD-style (see COPYRIGHT file)+--+-- Area spots are a collection of unconnected filled circles,+-- with x,y position, and an independent z value to be represented+-- by the relative area of the spots.++{-# LANGUAGE TemplateHaskell #-}++module Graphics.Rendering.Chart.Plot.AreaSpots+  ( AreaSpots(..)++  , area_spots_title+  , area_spots_linethick+  , area_spots_linecolour+  , area_spots_fillcolour+  , area_spots_opacity+  , area_spots_max_radius+  , area_spots_values++  , AreaSpots4D(..)++  , area_spots_4d_title+  , area_spots_4d_linethick+  , area_spots_4d_palette+  , area_spots_4d_opacity+  , area_spots_4d_max_radius+  , area_spots_4d_values+  ) where++import Graphics.Rendering.Chart.Geometry hiding (scale, x0, y0)+import Graphics.Rendering.Chart.Drawing+import Graphics.Rendering.Chart.Plot.Types+import Graphics.Rendering.Chart.Axis+import Control.Lens+import Data.Colour hiding (over)+import Data.Colour.Names+import Data.Default.Class++import Control.Monad++-- | A collection of unconnected spots, with x,y position, and an+--   independent z value to be represented by the area of the spot.+data AreaSpots z x y = AreaSpots+  { _area_spots_title      :: String+  , _area_spots_linethick  :: Double+  , _area_spots_linecolour :: AlphaColour Double+  , _area_spots_fillcolour :: Colour Double+  , _area_spots_opacity    :: Double+  , _area_spots_max_radius :: Double   -- ^ the largest size of spot+  , _area_spots_values     :: [(x,y,z)]+  }++instance Default (AreaSpots z x y) where+  def = AreaSpots+    { _area_spots_title      = ""+    , _area_spots_linethick  = 0.1+    , _area_spots_linecolour = opaque blue+    , _area_spots_fillcolour = blue+    , _area_spots_opacity    = 0.2+    , _area_spots_max_radius = 20  -- in pixels+    , _area_spots_values     = []+    }++instance (PlotValue z) => ToPlot (AreaSpots z) where+    toPlot p = Plot { _plot_render = renderAreaSpots p+                    , _plot_legend = [(_area_spots_title p, renderSpotLegend p)]+                    , _plot_all_points = ( map (^._1) (_area_spots_values p)+                                         , map (^._2) (_area_spots_values p) )+                    }++renderAreaSpots  :: (PlotValue z) => AreaSpots z x y -> PointMapFn x y -> BackendProgram ()+renderAreaSpots p pmap = +    forM_ (scaleMax (_area_spots_max_radius p^(2::Integer))+                    (_area_spots_values p))+          (\ (x,y,z)-> do+              let radius = sqrt z+              let psSpot = filledCircles radius $+                                                    flip withOpacity +                                                      (_area_spots_opacity p) $+                                                    _area_spots_fillcolour p+              drawPoint psSpot (pmap (LValue x, LValue y))+              let psOutline = hollowCircles radius+                                                      (_area_spots_linethick p)+                                                      (_area_spots_linecolour p)+              drawPoint psOutline (pmap (LValue x, LValue y))+          )+  where+    scaleMax :: PlotValue z => Double -> [(x,y,z)] -> [(x,y,Double)]+    scaleMax n points = let largest  = maximum (map (^._3.to toValue) points)+                            scale v  = n * toValue v / largest+                        in over (mapped._3) scale points++renderSpotLegend :: AreaSpots z x y -> Rect -> BackendProgram ()+renderSpotLegend p (Rect p1 p2) = do+    let radius = min (abs (p_y p1 - p_y p2)) (abs (p_x p1 - p_x p2))+        centre = linearInterpolate p1 p2+        psSpot = filledCircles radius $ withOpacity +                                        (_area_spots_fillcolour p)+                                        (_area_spots_opacity p)+        psOutline = hollowCircles radius (_area_spots_linethick p)+                                         (_area_spots_linecolour p)+    drawPoint psSpot centre+    drawPoint psOutline centre+  where+    linearInterpolate (Point x0 y0) (Point x1 y1) =+        Point (x0 + abs(x1-x0)/2) (y0 + abs(y1-y0)/2)++-- | A collection of unconnected spots, with x,y position, an+--   independent z value to be represented by the area of the spot,+--   and in addition, a fourth variable t to be represented by a colour+--   from a given palette.  (A linear transfer function from t to palette+--   is assumed.)+data AreaSpots4D z t x y = AreaSpots4D+  { _area_spots_4d_title      :: String+  , _area_spots_4d_linethick  :: Double+  , _area_spots_4d_palette    :: [Colour Double]+  , _area_spots_4d_opacity    :: Double+  , _area_spots_4d_max_radius :: Double        -- ^ the largest size of spot+  , _area_spots_4d_values     :: [(x,y,z,t)]+  }++instance Default (AreaSpots4D z t x y) where+  def = AreaSpots4D+    { _area_spots_4d_title      = ""+    , _area_spots_4d_linethick  = 0.1+    , _area_spots_4d_palette    = [ blue, green, yellow, orange, red ]+    , _area_spots_4d_opacity    = 0.2+    , _area_spots_4d_max_radius = 20  -- in pixels+    , _area_spots_4d_values     = []+    }++instance (PlotValue z, PlotValue t, Show t) => ToPlot (AreaSpots4D z t) where+    toPlot p = Plot { _plot_render = renderAreaSpots4D p+                    , _plot_legend = [ (_area_spots_4d_title p+                                       , renderSpotLegend4D p) ]+                    , _plot_all_points = ( map (^._1) (_area_spots_4d_values p)+                                         , map (^._2) (_area_spots_4d_values p) )+                    }++renderAreaSpots4D  :: (PlotValue z, PlotValue t, Show t) =>+                      AreaSpots4D z t x y -> PointMapFn x y -> BackendProgram ()+renderAreaSpots4D p pmap = +    forM_ (scaleMax (_area_spots_4d_max_radius p^(2::Integer))+                    (length (_area_spots_4d_palette p))+                    (_area_spots_4d_values p))+          (\ (x,y,z,t)-> do+              let radius  = sqrt z+              let colour  = _area_spots_4d_palette p !! t +              let psSpot+                    = filledCircles radius $+                          withOpacity colour (_area_spots_4d_opacity p)+              drawPoint psSpot (pmap (LValue x, LValue y))+              let psOutline+                    = hollowCircles radius (_area_spots_4d_linethick p)+                                           (opaque colour)+              drawPoint psOutline (pmap (LValue x, LValue y))+          )+  where+    scaleMax :: (PlotValue z, PlotValue t, Show t) =>+                Double -> Int -> [(x,y,z,t)] -> [(x,y,Double,Int)]+    scaleMax n c points = let largest  = maximum (map (^._3.to toValue) points)+                              scale v  = n * toValue v / largest+                              colVals  = map (^._4.to toValue) points+                              colMin   = minimum colVals+                              colMax   = maximum colVals+                              select t = min (c-1) $ +                                         truncate ( fromIntegral c+                                                       * (toValue t-colMin)+                                                       / (colMax-colMin))+                          in map (\ (x,y,z,t) -> (x,y, scale z, select t))+                                 points++renderSpotLegend4D :: AreaSpots4D z t x y -> Rect -> BackendProgram ()+renderSpotLegend4D p (Rect p1 p2) = do+    let radius = min (abs (p_y p1 - p_y p2)) (abs (p_x p1 - p_x p2))+        centre = linearInterpolate p1 p2+        palCol = head $ _area_spots_4d_palette p+        psSpot = filledCircles radius $ withOpacity palCol+                                        (_area_spots_4d_opacity p)+        psOutline = hollowCircles radius (_area_spots_4d_linethick p)+                                         (opaque palCol)+    drawPoint psSpot centre+    drawPoint psOutline centre+  where+    linearInterpolate (Point x0 y0) (Point x1 y1) =+        Point (x0 + abs(x1-x0)/2) (y0 + abs(y1-y0)/2)++$( makeLenses ''AreaSpots )+$( makeLenses ''AreaSpots4D )
+ Graphics/Rendering/Chart/Plot/Bars.hs view
@@ -0,0 +1,411 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Graphics.Rendering.Chart.Plot.Bars+-- Copyright   :  (c) Tim Docker 2006, 2014+-- License     :  BSD-style (see chart/COPYRIGHT)+--+-- Bar Charts+--+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}++module Graphics.Rendering.Chart.Plot.Bars(+    PlotBars(..),+    PlotBarsStyle(..),+    PlotBarsSpacing(..),+    PlotBarsAlignment(..),+    BarsPlotValue(..),+    BarHorizAnchor(..),+    BarVertAnchor(..),++    plotBars,+    plotHBars,++    plot_bars_style,+    plot_bars_item_styles,+    plot_bars_titles,+    plot_bars_spacing,+    plot_bars_alignment,+    plot_bars_singleton_width,+    plot_bars_label_bar_hanchor,+    plot_bars_label_bar_vanchor,+    plot_bars_label_text_hanchor,+    plot_bars_label_text_vanchor,+    plot_bars_label_angle,+    plot_bars_label_style,+    plot_bars_label_offset,++    plot_bars_values,++    plot_bars_settings,+    plot_bars_values_with_labels,++    addLabels+) where++import Control.Arrow+import Control.Lens+import Control.Monad+import Data.Colour (opaque)+import Data.Colour.Names (black)+import Data.Default.Class+import Data.Tuple(swap)+import Data.List(nub,sort)+import Graphics.Rendering.Chart.Axis+import Graphics.Rendering.Chart.Drawing+import Graphics.Rendering.Chart.Geometry hiding (x0, y0)+import Graphics.Rendering.Chart.Plot.Types+import Graphics.Rendering.Chart.Utils+class PlotValue a => BarsPlotValue a where+    barsIsNull    :: a -> Bool+    -- | The starting level for the chart, a function of some statistic+    --   (normally the lowest value or just const 0).+    barsReference :: [a] -> a+    barsAdd       :: a -> a -> a++instance BarsPlotValue Double where+    barsIsNull a  = a == 0.0+    barsReference = const 0+    barsAdd       = (+)++instance BarsPlotValue Int where+    barsIsNull a  = a == 0+    barsReference = const 0+    barsAdd       = (+)++instance BarsPlotValue LogValue where+    barsIsNull (LogValue a) = a == 0.0+    barsReference as        =+      10.0 ^^ (floor (log10 $ minimum $ filter (/= 0.0) as) :: Integer)+    barsAdd                 = (+)++data PlotBarsStyle+    = BarsStacked   -- ^ Bars for a fixed x are stacked vertically+                    --   on top of each other.+    | BarsClustered -- ^ Bars for a fixed x are put horizontally+                    --   beside each other.+     deriving (Show)++data PlotBarsSpacing+    = BarsFixWidth Double       -- ^ All bars have the same width in pixels.+    | BarsFixGap Double Double  -- ^ (BarsFixGap g mw) means make the gaps between+                                --   the bars equal to g, but with a minimum bar width+                                --   of mw+     deriving (Show)++-- | How bars for a given (x,[y]) are aligned with respect to screen+--   coordinate corresponding to x (deviceX).+data PlotBarsAlignment = BarsLeft      -- ^ The left edge of bars is at deviceX+                       | BarsCentered  -- ^ Bars are centered around deviceX+                       | BarsRight     -- ^ The right edge of bars is at deviceX+     deriving (Show)++data BarHorizAnchor+    = BHA_Left+    | BHA_Centre+    | BHA_Right+     deriving (Show)++data BarVertAnchor+    = BVA_Bottom+    | BVA_Centre+    | BVA_Top+     deriving (Show)++-- | Value describing how to plot a set of bars.+--   Note that the input data is typed [(x,[y])], ie for each x value+--   we plot several y values. Typically the size of each [y] list would+--   be the same.+data BarsSettings = BarsSettings {+   -- | This value specifies whether each value from [y] should be+   --   shown beside or above the previous value.+   _bars_settings_style           :: PlotBarsStyle,++   -- | The style in which to draw each element of [y]. A fill style+   --   is required, and if a linestyle is given, each bar will be+   --   outlined.+   _bars_settings_item_styles     :: [ (FillStyle,Maybe LineStyle) ],++   -- | This value controls how the widths of the bars are+   --   calculated. Either the widths of the bars, or the gaps between+   --   them can be fixed.+   _bars_settings_spacing         :: PlotBarsSpacing,++   -- | This value controls how bars for a fixed x are aligned with+   --   respect to the device coordinate corresponding to x.+   _bars_settings_alignment       :: PlotBarsAlignment,++   _bars_settings_singleton_width :: Double,++   -- | The point on the bar to horizontally anchor the label to+   _bars_settings_label_bar_hanchor :: BarHorizAnchor,++   -- | The point on the bar to vertically anchor the label to+   _bars_settings_label_bar_vanchor  :: BarVertAnchor,++    -- | The anchor point on the label.+   _bars_settings_label_text_hanchor :: HTextAnchor,++    -- | The anchor point on the label.+   _bars_settings_label_text_vanchor :: VTextAnchor,++   -- | Angle, in degrees, to rotate the label about the anchor point.+   _bars_settings_label_angle   :: Double,++   -- | The style to use for the label.+   _bars_settings_label_style   :: FontStyle,++   -- | The offset from the anchor point to display the label at.+   _bars_settings_label_offset  :: Vector+}+instance Default BarsSettings where+  def = BarsSettings+    { _bars_settings_style              = BarsClustered+    , _bars_settings_item_styles        = cycle istyles+    , _bars_settings_spacing            = BarsFixGap 10 2+    , _bars_settings_alignment          = BarsCentered+    , _bars_settings_singleton_width    = 20+    , _bars_settings_label_bar_hanchor  = BHA_Centre+    , _bars_settings_label_bar_vanchor  = BVA_Top+    , _bars_settings_label_text_hanchor = HTA_Centre+    , _bars_settings_label_text_vanchor = VTA_Bottom+    , _bars_settings_label_angle        = 0+    , _bars_settings_label_style        = def+    , _bars_settings_label_offset       = Vector 0 0+    }+    where+      istyles   = map mkstyle defaultColorSeq+      mkstyle c = (solidFillStyle c, Just (solidLine 1.0 $ opaque black))+data PlotBars x y = PlotBars {+   _plot_bars_settings :: BarsSettings,+   -- | The title of each element of [y]. These will be shown in the legend.+   _plot_bars_titles :: [String],+   -- | The actual points to be plotted, and their labels+   _plot_bars_values_with_labels :: [(x, [(y, String)])]+}+instance Default (PlotBars x y) where+  def = PlotBars+    { _plot_bars_settings = def+    , _plot_bars_titles = []+    , _plot_bars_values_with_labels = []+    }++plotBars :: (BarsPlotValue y) => PlotBars x y -> Plot x y+plotBars p = Plot {+        _plot_render     = \pmap -> renderBars s vals yref0+                                      (barRect pmap) (mapX pmap),+        _plot_legend     = zip (_plot_bars_titles p)+                               (map renderPlotLegendBars+                                    (_bars_settings_item_styles s)),+        _plot_all_points = allBarPoints s vals+    }+  where+    s = _plot_bars_settings p+    vals = _plot_bars_values_with_labels p+    yref0 = refVal s vals++    barRect pmap xos width x y0 y1 = Rect (Point (x'+xos) y0') (Point (x'+xos+width) y') where+      Point x' y' = mapXY pmap (x,y1)+      Point _ y0' = mapXY pmap (x,y0)++    mapX pmap x = p_x (mapXY pmap (x, yref0))++plotHBars :: (BarsPlotValue x) => PlotBars y x -> Plot x y+plotHBars p = Plot {+        _plot_render     = \pmap -> renderBars s vals xref0+                                      (barRect pmap) (mapY pmap),+        _plot_legend     = zip (_plot_bars_titles p)+                               (map renderPlotLegendBars+                                    (_bars_settings_item_styles s)),+        _plot_all_points = swap $ allBarPoints s vals+    }+  where+    s = _plot_bars_settings p+    vals = _plot_bars_values_with_labels p+    xref0 = refVal s vals++    barRect pmap yos height y x0 x1 = Rect (Point x0' (y'+yos)) (Point x' (y'+yos+height)) where+      Point x' y' = mapXY pmap (x1,y)+      Point x0' _ = mapXY pmap (x0,y)++    mapY pmap y = p_y (mapXY pmap (xref0, y))++renderBars :: (BarsPlotValue v) =>+              BarsSettings+           -> [(k, [(v, String)])]+           -> v+           -> (Double -> Double -> k -> v -> v -> Rect)+           -> (k -> Double)+           -> BackendProgram ()+renderBars p vals vref0 r mapk = case _bars_settings_style p of+      BarsClustered -> forM_ vals clusteredBars+      BarsStacked   -> forM_ vals stackedBars+  where+    clusteredBars (k,vs) = do+       let offset i = case _bars_settings_alignment p of+             BarsLeft     -> fromIntegral i * bsize+             BarsRight    -> fromIntegral (i-nvs) * bsize+             BarsCentered -> fromIntegral (2*i-nvs) * bsize/2+       forM_ (zip3 [0,1..] vs styles) $ \(i, (v, _), (fstyle,_)) ->+           unless (barsIsNull v) $+           withFillStyle fstyle $+             alignFillPath (barPath (offset i) k vref0 v)+             >>= fillPath+       forM_ (zip3 [0,1..] vs styles) $ \(i, (v, _), (_,mlstyle)) ->+           unless (barsIsNull v) $+           whenJust mlstyle $ \lstyle ->+             withLineStyle lstyle $+               alignStrokePath (barPath (offset i) k vref0 v)+               >>= strokePath+       withFontStyle (_bars_settings_label_style p) $+           forM_ (zip [0,1..] vs) $ \(i, (v, txt)) ->+             unless (null txt) $ do+               let ha = _bars_settings_label_bar_hanchor p+               let va = _bars_settings_label_bar_vanchor p+               let pt = rectCorner ha va (r (offset i) bsize k vref0 v)+               drawTextR+                  (_bars_settings_label_text_hanchor p)+                  (_bars_settings_label_text_vanchor p)+                  (_bars_settings_label_angle p)+                  (pvadd pt $ _bars_settings_label_offset p)+                  txt++    stackedBars (k,vs) = do+       let (vs', lbls) = unzip vs+       let vs'' = map (\v -> if barsIsNull v then vref0 else v) (stack vs')+       let v2s = zip (vref0:vs'') vs''+       let ofs = case _bars_settings_alignment p of+             BarsLeft     -> 0+             BarsRight    -> -bsize+             BarsCentered -> -(bsize/2)+       forM_ (zip v2s styles) $ \((v0,v1), (fstyle,_)) ->+           unless (v0 >= v1) $+           withFillStyle fstyle $+             alignFillPath (barPath ofs k v0 v1)+             >>= fillPath+       forM_ (zip v2s styles) $ \((v0,v1), (_,mlstyle)) ->+           unless (v0 >= v1) $+           whenJust mlstyle $ \lstyle ->+              withLineStyle lstyle $+                alignStrokePath (barPath ofs k v0 v1)+                >>= strokePath+       withFontStyle (_bars_settings_label_style p) $+           forM_ (zip v2s lbls) $ \((v0, v1), txt) ->+             unless (null txt) $ do+               let ha = _bars_settings_label_bar_hanchor p+               let va = _bars_settings_label_bar_vanchor p+               let pt = rectCorner ha va (r ofs bsize k v0 v1)+               drawTextR+                  (_bars_settings_label_text_hanchor p)+                  (_bars_settings_label_text_vanchor p)+                  (_bars_settings_label_angle p)+                  (pvadd pt $ _bars_settings_label_offset p)+                  txt++    styles = _bars_settings_item_styles p++    barPath os k v0 v1 = rectPath $ r os bsize k v0 v1++    bsize = case _bars_settings_spacing p of+        BarsFixGap gap minw -> let w = max (minKInterval - gap) minw in+            case _bars_settings_style p of+                BarsClustered -> w / fromIntegral nvs+                BarsStacked -> w+        BarsFixWidth width' -> width'++    minKInterval = let diffs = zipWith (-) (tail mks) mks+                   in if null diffs+                        then _bars_settings_singleton_width p+                        else minimum diffs+      where+        mks = nub $ sort $ map (mapk . fst) vals++    nvs = maximum $ map (length . snd) vals++rectCorner :: BarHorizAnchor -> BarVertAnchor -> Rect -> Point+rectCorner h v (Rect (Point x0 y0) (Point x1 y1)) = Point x' y' where+    x' = case h of+              BHA_Left   -> x0+              BHA_Right  -> x1+              BHA_Centre -> (x0 + x1) / 2+    y' = case v of+              BVA_Bottom -> y0+              BVA_Top    -> y1+              BVA_Centre -> (y0 + y1) / 2++-- Helper function for printing bar values as labels+addLabels :: Show y => [(x, [y])] -> [(x, [(y, String)])]+addLabels = map . second $ map (\y -> (y, show y))++refVal :: (BarsPlotValue y) => BarsSettings -> [(x, [(y, String)])] -> y+refVal p vals = barsReference $ case _bars_settings_style p of+    BarsClustered -> concatMap (map fst . snd) vals+    BarsStacked   -> concatMap (take 1 . dropWhile barsIsNull . stack . map fst . snd) vals++allBarPoints :: (BarsPlotValue y) => BarsSettings -> [(x, [(y, String)])] -> ([x],[y])+allBarPoints p vals = case _bars_settings_style p of+    BarsClustered ->+      let ys = concatMap (map fst) yls in+      ( xs, barsReference ys:ys )+    BarsStacked   ->+      let ys = map (stack . map fst) yls in+      ( xs, barsReference (concatMap (take 1 . dropWhile barsIsNull) ys):concat ys)+  where (xs, yls) = unzip vals++stack :: (BarsPlotValue y) => [y] -> [y]+stack = scanl1 barsAdd++renderPlotLegendBars :: (FillStyle,Maybe LineStyle) -> Rect -> BackendProgram ()+renderPlotLegendBars (fstyle,_) r =+  withFillStyle fstyle $+    fillPath (rectPath r)++$( makeLenses ''BarsSettings )+$( makeLenses ''PlotBars )++-- Lens provided for backward compat.++-- Note that this one does not satisfy the lens laws, as it discards/overwrites the labels.+plot_bars_values :: Lens' (PlotBars x y) [(x, [y])]+plot_bars_values = lens getter setter+  where+    getter = mapYs fst . _plot_bars_values_with_labels+    setter pb vals' = pb { _plot_bars_values_with_labels = mapYs (, "") vals' }+    mapYs :: (a -> b) -> [(c, [a])] -> [(c, [b])]+    mapYs f = map (over _2 $ map f)++plot_bars_style :: Lens' (PlotBars x y) PlotBarsStyle+plot_bars_style = plot_bars_settings . bars_settings_style++plot_bars_item_styles :: Lens' (PlotBars x y) [(FillStyle, Maybe LineStyle)]+plot_bars_item_styles = plot_bars_settings . bars_settings_item_styles++plot_bars_spacing :: Lens' (PlotBars x y) PlotBarsSpacing+plot_bars_spacing = plot_bars_settings . bars_settings_spacing++plot_bars_alignment :: Lens' (PlotBars x y) PlotBarsAlignment+plot_bars_alignment =  plot_bars_settings . bars_settings_alignment++plot_bars_singleton_width :: Lens' (PlotBars x y) Double+plot_bars_singleton_width = plot_bars_settings . bars_settings_singleton_width++plot_bars_label_bar_hanchor :: Lens' (PlotBars x y) BarHorizAnchor+plot_bars_label_bar_hanchor = plot_bars_settings . bars_settings_label_bar_hanchor++plot_bars_label_bar_vanchor :: Lens' (PlotBars x y) BarVertAnchor+plot_bars_label_bar_vanchor = plot_bars_settings . bars_settings_label_bar_vanchor++plot_bars_label_text_hanchor :: Lens' (PlotBars x y) HTextAnchor+plot_bars_label_text_hanchor = plot_bars_settings . bars_settings_label_text_hanchor++plot_bars_label_text_vanchor :: Lens' (PlotBars x y) VTextAnchor+plot_bars_label_text_vanchor = plot_bars_settings . bars_settings_label_text_vanchor++plot_bars_label_angle :: Lens' (PlotBars x y) Double+plot_bars_label_angle = plot_bars_settings . bars_settings_label_angle++plot_bars_label_style :: Lens' (PlotBars x y) FontStyle+plot_bars_label_style = plot_bars_settings . bars_settings_label_style++plot_bars_label_offset :: Lens' (PlotBars x y) Vector+plot_bars_label_offset = plot_bars_settings . bars_settings_label_offset
+ Graphics/Rendering/Chart/Plot/Candle.hs view
@@ -0,0 +1,151 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Graphics.Rendering.Chart.Plot.Candle+-- Copyright   :  (c) Tim Docker 2006, 2014+-- License     :  BSD-style (see chart/COPYRIGHT)+--+-- Candlestick charts for financial plotting+--+{-# LANGUAGE TemplateHaskell #-}++module Graphics.Rendering.Chart.Plot.Candle(+    PlotCandle(..),+    Candle(..),++    plot_candle_title,+    plot_candle_line_style,+    plot_candle_tick_length,+    plot_candle_width,+    plot_candle_centre,+    plot_candle_fill,+    plot_candle_rise_fill_style,+    plot_candle_fall_fill_style,+    plot_candle_values,+) where++import Control.Lens hiding (op)++import Graphics.Rendering.Chart.Geometry hiding (close)+import Graphics.Rendering.Chart.Drawing+import Graphics.Rendering.Chart.Plot.Types+import Control.Monad+import Data.Colour (opaque)+import Data.Colour.Names (white, blue)+import Data.Default.Class++-- | Value defining a financial interval: opening and closing prices, with+--   maxima and minima; and a style in which to render them.+--   By convention, there are different fill styles depending on whether+--   the price rises (open < close) or falls (close < open).+--   (This plot type can also be re-purposed for statistical intervals, e.g.+--    minimum, first quartile, median, third quartile, maximum.)+data PlotCandle x y = PlotCandle {+    _plot_candle_title           :: String,+    _plot_candle_line_style      :: LineStyle,+    _plot_candle_fill            :: Bool,+    _plot_candle_rise_fill_style :: FillStyle,+    _plot_candle_fall_fill_style :: FillStyle,+    _plot_candle_tick_length     :: Double,+    _plot_candle_width           :: Double,+    _plot_candle_centre          :: Double,+    _plot_candle_values          :: [Candle x y]+}++-- | A Value holding price intervals for a given x-coord.+--   An alternative view is that these are statistical intervals: the+--   0th, 25th, 50th, 75th, and 100th percentiles.+data Candle x y = Candle { candle_x     :: x+                         , candle_low   :: y+                         , candle_open  :: y+                         , candle_mid   :: y+                         , candle_close :: y+                         , candle_high  :: y+                         } deriving (Show)++instance ToPlot PlotCandle where+    toPlot p = Plot {+        _plot_render     = renderPlotCandle p,+        _plot_legend     = [(_plot_candle_title p, renderPlotLegendCandle p)],+        _plot_all_points = ( map candle_x pts+                           , concat [ [candle_low c, candle_high c]+                                    | c <- pts ] )+    }+      where+        pts = _plot_candle_values p++renderPlotCandle :: PlotCandle x y -> PointMapFn x y -> BackendProgram ()+renderPlotCandle p pmap =+    mapM_ (drawCandle p . candlemap) (_plot_candle_values p)+  where+    candlemap (Candle x lo op mid cl hi) =+        Candle x' lo' op' mid' cl' hi'+        where (Point x' mid')  = pmap' (x,mid)+              (Point _  lo')   = pmap' (x,lo)+              (Point _  op')   = pmap' (x,op)+              (Point _  cl')   = pmap' (x,cl)+              (Point _  hi')   = pmap' (x,hi)+    pmap' = mapXY pmap++drawCandle :: PlotCandle x y -> Candle Double Double -> BackendProgram ()+drawCandle ps (Candle x lo open mid close hi) = do+        let tl = _plot_candle_tick_length ps+        let wd = _plot_candle_width ps+        let ct = _plot_candle_centre ps+        let f  = _plot_candle_fill ps+        -- the pixel coordinate system is inverted wrt the value coords.+        when f $ withFillStyle (if open >= close+                                   then _plot_candle_rise_fill_style ps+                                   else _plot_candle_fall_fill_style ps) $+                    fillPath $ moveTo' (x-wd) open+                            <> lineTo' (x-wd) close+                            <> lineTo' (x+wd) close+                            <> lineTo' (x+wd) open+                            <> lineTo' (x-wd) open++        withLineStyle (_plot_candle_line_style ps) $ do+          strokePath $ moveTo' (x-wd) open+                    <> lineTo' (x-wd) close+                    <> lineTo' (x+wd) close+                    <> lineTo' (x+wd) open+                    <> lineTo' (x-wd) open++          strokePath $ moveTo' x (min lo hi)+                    <> lineTo' x (min open close)+                    <> moveTo' x (max open close)+                    <> lineTo' x (max hi lo)++          when (tl > 0) $ strokePath $ moveTo' (x-tl) lo+                                    <> lineTo' (x+tl) lo+                                    <> moveTo' (x-tl) hi+                                    <> lineTo' (x+tl) hi++          when (ct > 0) $ strokePath $ moveTo' (x-ct) mid+                                    <> lineTo' (x+ct) mid++renderPlotLegendCandle :: PlotCandle x y -> Rect -> BackendProgram ()+renderPlotLegendCandle pc (Rect p1 p2) = do+    drawCandle pc2 (Candle (xwid*1/4) lo open mid close hi)+    drawCandle pc2 (Candle (xwid*2/3) lo close mid open hi)+  where+    pc2   = pc { _plot_candle_width = 2 }+    xwid  = p_x p1 + p_x p2+    lo    = max (p_y p1) (p_y p2)+    mid   = (p_y p1 + p_y p2)/2+    hi    = min (p_y p1) (p_y p2)+    open  = (lo + mid) / 2+    close = (mid + hi) / 2++instance Default (PlotCandle x y) where+  def = PlotCandle+    { _plot_candle_title       = ""+    , _plot_candle_line_style  = solidLine 1 $ opaque blue+    , _plot_candle_fill        = False+    , _plot_candle_rise_fill_style  = solidFillStyle $ opaque white+    , _plot_candle_fall_fill_style  = solidFillStyle $ opaque blue+    , _plot_candle_tick_length = 2+    , _plot_candle_width       = 5+    , _plot_candle_centre      = 0+    , _plot_candle_values      = []+    }++$( makeLenses ''PlotCandle )
+ Graphics/Rendering/Chart/Plot/ErrBars.hs view
@@ -0,0 +1,127 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Graphics.Rendering.Chart.Plot.ErrBars+-- Copyright   :  (c) Tim Docker 2006, 2014+-- License     :  BSD-style (see chart/COPYRIGHT)+--+-- Plot series of points with associated error bars.+--+{-# LANGUAGE TemplateHaskell #-}++module Graphics.Rendering.Chart.Plot.ErrBars(+    PlotErrBars(..),+    ErrPoint(..),+    ErrValue(..),+    symErrPoint,++    -- * Accessors+    -- | These accessors are generated by template haskell++    plot_errbars_title,+    plot_errbars_line_style,+    plot_errbars_tick_length,+    plot_errbars_overhang,+    plot_errbars_values,+) where++import Control.Lens++import Graphics.Rendering.Chart.Geometry+import Graphics.Rendering.Chart.Drawing+import Graphics.Rendering.Chart.Plot.Types+import Data.Colour (opaque)+import Data.Colour.Names (blue)+import Data.Default.Class++-- | Value for holding a point with associated error bounds for each axis.++data ErrValue x = ErrValue {+      ev_low  :: x,+      ev_best :: x,+      ev_high :: x+} deriving Show++data ErrPoint x y = ErrPoint {+      ep_x :: ErrValue x,+      ep_y :: ErrValue y+} deriving Show++-- | When the error is symmetric, we can simply pass in dx for the error.+symErrPoint :: (Num a, Num b) => a -> b -> a -> b -> ErrPoint a b+symErrPoint x y dx dy = ErrPoint (ErrValue (x-dx) x (x+dx))+                                 (ErrValue (y-dy) y (y+dy))++-- | Value defining a series of error intervals, and a style in+--   which to render them.+data PlotErrBars x y = PlotErrBars {+    _plot_errbars_title       :: String,+    _plot_errbars_line_style  :: LineStyle,+    _plot_errbars_tick_length :: Double,+    _plot_errbars_overhang    :: Double,+    _plot_errbars_values      :: [ErrPoint x y]+}+++instance ToPlot PlotErrBars where+    toPlot p = Plot {+        _plot_render     = renderPlotErrBars p,+        _plot_legend     = [(_plot_errbars_title p, renderPlotLegendErrBars p)],+        _plot_all_points = ( concat [ [ev_low x,ev_high x]+                                    | ErrPoint x _ <- pts ]+                           , concat [ [ev_low y,ev_high y]+                                    | ErrPoint _ y <- pts ] )+    }+      where+        pts = _plot_errbars_values p++renderPlotErrBars :: PlotErrBars x y -> PointMapFn x y -> BackendProgram ()+renderPlotErrBars p pmap =+    mapM_ (drawErrBar.epmap) (_plot_errbars_values p)+  where+    epmap (ErrPoint (ErrValue xl x xh) (ErrValue yl y yh)) =+        ErrPoint (ErrValue xl' x' xh') (ErrValue yl' y' yh')+        where (Point x' y')   = pmap' (x,y)+              (Point xl' yl') = pmap' (xl,yl)+              (Point xh' yh') = pmap' (xh,yh)+    drawErrBar = drawErrBar0 p+    pmap'      = mapXY pmap++drawErrBar0 :: PlotErrBars x y -> ErrPoint Double Double -> BackendProgram ()+drawErrBar0 ps (ErrPoint (ErrValue xl x xh) (ErrValue yl y yh)) = do+        let tl = _plot_errbars_tick_length ps+        let oh = _plot_errbars_overhang ps+        withLineStyle (_plot_errbars_line_style ps) $+          strokePath $ moveTo' (xl-oh) y+                    <> lineTo' (xh+oh) y+                    <> moveTo' x (yl-oh)+                    <> lineTo' x (yh+oh)+                    <> moveTo' xl (y-tl)+                    <> lineTo' xl (y+tl)+                    <> moveTo' (x-tl) yl+                    <> lineTo' (x+tl) yl+                    <> moveTo' xh (y-tl)+                    <> lineTo' xh (y+tl)+                    <> moveTo' (x-tl) yh+                    <> lineTo' (x+tl) yh++renderPlotLegendErrBars :: PlotErrBars x y -> Rect -> BackendProgram ()+renderPlotLegendErrBars p (Rect p1 p2) = do+    drawErrBar (symErrPoint (p_x p1)              y dx dx)+    drawErrBar (symErrPoint ((p_x p1 + p_x p2)/2) y dx dx)+    drawErrBar (symErrPoint (p_x p2)              y dx dx)++  where+    drawErrBar = drawErrBar0 p+    dx         = min ((p_x p2 - p_x p1)/6) ((p_y p2 - p_y p1)/2)+    y          = (p_y p1 + p_y p2)/2++instance Default (PlotErrBars x y) where+  def = PlotErrBars+    { _plot_errbars_title       = ""+    , _plot_errbars_line_style  = solidLine 1 $ opaque blue+    , _plot_errbars_tick_length = 3+    , _plot_errbars_overhang    = 0+    , _plot_errbars_values      = []+    }++$( makeLenses ''PlotErrBars )
+ Graphics/Rendering/Chart/Plot/FillBetween.hs view
@@ -0,0 +1,89 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Graphics.Rendering.Chart.Plot.FillBetween+-- Copyright   :  (c) Tim Docker 2006, 2014+-- License     :  BSD-style (see chart/COPYRIGHT)+--+-- Plots that fill the area between two lines.+--+{-# LANGUAGE TemplateHaskell #-}++module Graphics.Rendering.Chart.Plot.FillBetween(+    PlotFillBetween(..),++    -- * Accessors+    -- | These accessors are generated by template haskell+    plot_fillbetween_title,+    plot_fillbetween_style,+    plot_fillbetween_line,+    plot_fillbetween_values,+) where++import Control.Lens+import Graphics.Rendering.Chart.Geometry+import Graphics.Rendering.Chart.Drawing+import Graphics.Rendering.Chart.Plot.Types+import Data.Colour (opaque)+import Data.Colour.SRGB (sRGB)+import Data.Default.Class++-- | Value specifying a plot filling the area between two sets of Y+--   coordinates, given common X coordinates.++data PlotFillBetween x y = PlotFillBetween {+    _plot_fillbetween_title  :: String,+    _plot_fillbetween_style  :: FillStyle,+    _plot_fillbetween_line  :: Maybe LineStyle,+    _plot_fillbetween_values :: [ (x, (y,y))]+}+++instance ToPlot PlotFillBetween where+    toPlot p = Plot {+        _plot_render     = renderPlotFillBetween p,+        _plot_legend     = [(_plot_fillbetween_title p,renderPlotLegendFill p)],+        _plot_all_points = plotAllPointsFillBetween p+    }++renderPlotFillBetween :: PlotFillBetween x y -> PointMapFn x y -> BackendProgram ()+renderPlotFillBetween p =+    renderPlotFillBetween' p (_plot_fillbetween_values p)++renderPlotFillBetween' :: +  PlotFillBetween x y +  -> [(a, (b, b))]+  -> ((Limit a, Limit b) -> Point)+  -> BackendProgram ()+renderPlotFillBetween' _ [] _     = return ()+renderPlotFillBetween' p vs pmap  = +  withFillStyle (_plot_fillbetween_style p) $ do+    ps <- alignFillPoints $ [p0] ++ p1s ++ reverse p2s ++ [p0]+    fillPointPath ps+    case _plot_fillbetween_line p of+      Nothing -> return ()+      Just lineStyle -> withLineStyle lineStyle $ strokePointPath ps+  where+    pmap'    = mapXY pmap+    (p0:p1s) = map pmap' [ (x,y1) | (x,(y1,_)) <- vs ]+    p2s      = map pmap' [ (x,y2) | (x,(_,y2)) <- vs ]++renderPlotLegendFill :: PlotFillBetween x y -> Rect -> BackendProgram ()+renderPlotLegendFill p r = +  withFillStyle (_plot_fillbetween_style p) $ +    fillPath (rectPath r)++plotAllPointsFillBetween :: PlotFillBetween x y -> ([x],[y])+plotAllPointsFillBetween p = ( [ x | (x,(_,_)) <- pts ]+                             , concat [ [y1,y2] | (_,(y1,y2)) <- pts ] )+  where+    pts = _plot_fillbetween_values p++instance Default (PlotFillBetween x y) where+  def = PlotFillBetween +    { _plot_fillbetween_title  = ""+    , _plot_fillbetween_style  = solidFillStyle (opaque $ sRGB 0.5 0.5 1.0)+    , _plot_fillbetween_line   = Nothing+    , _plot_fillbetween_values = []+    }++$( makeLenses ''PlotFillBetween )
+ Graphics/Rendering/Chart/Plot/Hidden.hs view
@@ -0,0 +1,36 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Graphics.Rendering.Chart.Plot.Hidden+-- Copyright   :  (c) Tim Docker 2006, 2014+-- License     :  BSD-style (see chart/COPYRIGHT)+--+-- Plots that don't show, but occupy space so as to effect axis+-- scaling+--+{-# LANGUAGE TemplateHaskell #-}++module Graphics.Rendering.Chart.Plot.Hidden(+    PlotHidden(..),+    +    plot_hidden_x_values,+    plot_hidden_y_values+) where++import Control.Lens+import Graphics.Rendering.Chart.Plot.Types++-- | Value defining some hidden x and y values. The values are+--   not displayed, but they still affect axis scaling.+data PlotHidden x y = PlotHidden {+    _plot_hidden_x_values :: [x],+    _plot_hidden_y_values :: [y]+}++instance ToPlot PlotHidden where+    toPlot ph = Plot {+        _plot_render     = \_ -> return (),+        _plot_legend     = [],+        _plot_all_points = (_plot_hidden_x_values ph, _plot_hidden_y_values ph)+    }++$( makeLenses ''PlotHidden )
+ Graphics/Rendering/Chart/Plot/Histogram.hs view
@@ -0,0 +1,188 @@+{-# LANGUAGE TemplateHaskell, FlexibleInstances #-}++module Graphics.Rendering.Chart.Plot.Histogram+  ( -- * Histograms+    PlotHist (..)+  , histToPlot+  , defaultPlotHist+  , defaultFloatPlotHist+  , defaultNormedPlotHist+  , histToBins+    -- * Accessors+  , plot_hist_title+  , plot_hist_bins+  , plot_hist_values+  , plot_hist_no_zeros+  , plot_hist_range+  , plot_hist_drop_lines+  , plot_hist_line_style+  , plot_hist_fill_style+  , plot_hist_norm_func+  ) where++import Control.Monad (when)+import Data.Maybe (fromMaybe)+import qualified Data.Foldable as F+import qualified Data.Vector as V++import Control.Lens+import Graphics.Rendering.Chart.Plot.Types+import Graphics.Rendering.Chart.Geometry+import Graphics.Rendering.Chart.Drawing+import Data.Default.Class++import Data.Colour (opaque)+import Data.Colour.Names (blue)+import Data.Colour.SRGB (sRGB)++import Numeric.Histogram++data PlotHist x y = PlotHist+    { -- | Plot title+      _plot_hist_title                :: String++      -- | Number of bins+    , _plot_hist_bins                 :: Int++      -- | Values to histogram+    , _plot_hist_values               :: [x]++      -- | Don't attempt to plot bins with zero counts. Useful when+      -- the y-axis is logarithmically scaled.+    , _plot_hist_no_zeros             :: Bool++      -- | Override the range of the histogram. If @Nothing@ the+      -- range of @_plot_hist_values@ is used.+      --+      -- Note that any normalization is always computed over the full+      -- data set, including samples not falling in the histogram range.+    , _plot_hist_range                :: Maybe (x,x)++      -- | Plot vertical lines between bins+    , _plot_hist_drop_lines           :: Bool++      -- | Fill style of the bins+    , _plot_hist_fill_style           :: FillStyle++      -- | Line style of the bin outlines+    , _plot_hist_line_style           :: LineStyle++      -- | Normalization function+    , _plot_hist_norm_func            :: Double -> Int -> y+    }++instance Default (PlotHist x Int) where+    def = defaultPlotHist++-- | The default style is an unnormalized histogram of 20 bins.+defaultPlotHist :: PlotHist x Int+defaultPlotHist = PlotHist { _plot_hist_bins        = 20+                           , _plot_hist_title       = ""+                           , _plot_hist_values      = []+                           , _plot_hist_no_zeros    = False+                           , _plot_hist_range       = Nothing+                           , _plot_hist_drop_lines  = False+                           , _plot_hist_line_style  = defaultLineStyle+                           , _plot_hist_fill_style  = defaultFillStyle+                           , _plot_hist_norm_func   = const id+                           }++-- | @defaultPlotHist@ but with real counts+defaultFloatPlotHist :: PlotHist x Double+defaultFloatPlotHist = defaultPlotHist { _plot_hist_norm_func = const realToFrac }++-- | @defaultPlotHist@ but normalized such that the integral of the+-- histogram is one.+defaultNormedPlotHist :: PlotHist x Double+defaultNormedPlotHist = defaultPlotHist { _plot_hist_norm_func = \n y->realToFrac y / n }++defaultFillStyle :: FillStyle+defaultFillStyle = solidFillStyle (opaque $ sRGB 0.5 0.5 1.0)++defaultLineStyle :: LineStyle+defaultLineStyle = (solidLine 1 $ opaque blue)+     { _line_cap  = LineCapButt+     , _line_join = LineJoinMiter+     }++-- | Convert a @PlotHist@ to a @Plot@+--+-- N.B. In principle this should be Chart's @ToPlot@ class but unfortunately+-- this does not allow us to set bounds on the x and y axis types, hence+-- the need for this function.+histToPlot :: (RealFrac x, Num y, Ord y) => PlotHist x y -> Plot x y+histToPlot p = Plot {+        _plot_render      = renderPlotHist p,+        _plot_legend      = [(_plot_hist_title p, renderPlotLegendHist p)],+        _plot_all_points  = unzip+                            $ concatMap (\((x1,x2), y)->[ (x1,y)+                                                        , (x2,y)+                                                        , (x1,0)+                                                        , (x2,0)+                                                        ])+                            $ histToBins p+    }++buildHistPath :: (RealFrac x, Num y)+              => PointMapFn x y -> [((x,x), y)] -> Path+buildHistPath _ [] = End+buildHistPath pmap bins = MoveTo (pt xb 0) (go bins)+    where go [((x1,x2),y)]      = LineTo (pt x1 y)+                                $ LineTo (pt x2 y)+                                $ LineTo (pt x2 0)+                                $ End+          go (((x1,x2),y):rest) = LineTo (pt x1 y)+                                $ LineTo (pt x2 y)+                                $ go rest+          go []                 = End+          ((xb,_),_) = head bins+          pt x y = pmap (LValue x, LValue y)++renderPlotHist :: (RealFrac x, Num y, Ord y)+               => PlotHist x y -> PointMapFn x y -> BackendProgram ()+renderPlotHist p pmap+    | null bins = return ()+    | otherwise = do+        withFillStyle (_plot_hist_fill_style p) $+            alignFillPath (buildHistPath pmap bins) >>= fillPath+        withLineStyle (_plot_hist_line_style p) $ do+            when (_plot_hist_drop_lines p) $+                alignStrokePath dropLinesPath >>= strokePath+            alignStrokePath (buildHistPath pmap bins) >>= strokePath+    where bins = histToBins p+          pt x y = pmap (LValue x, LValue y)+          dropLinesPath = F.foldMap (\((x1,_), y)->moveTo (pt x1 0)+                                                <> lineTo (pt x1 y)+                                    ) $ tail bins++renderPlotLegendHist :: PlotHist x y -> Rect -> BackendProgram ()+renderPlotLegendHist p (Rect p1 p2) =+    withLineStyle (_plot_hist_line_style p) $+        let y = (p_y p1 + p_y p2) / 2+        in strokePath $ moveTo' (p_x p1) y <> lineTo' (p_x p2) y++-- | Obtain the bin dimensions of a given @PlotHist@.+histToBins :: (RealFrac x, Num y, Ord y) => PlotHist x y -> [((x,x), y)]+histToBins hist =+    filter_zeros $ zip bounds $ counts+    where n = _plot_hist_bins hist+          (a,b) = realHistRange hist+          dx = realToFrac (b-a) / realToFrac n+          bounds = binBounds a b n+          values = V.fromList (_plot_hist_values hist)+          filter_zeros | _plot_hist_no_zeros hist  = filter (\(_,c)->c > 0)+                       | otherwise                 = id+          norm = dx * realToFrac (V.length values)+          normalize = _plot_hist_norm_func hist norm+          counts = V.toList $ V.map (normalize . snd)+                   $ histWithBins (V.fromList bounds)+                   $ zip (repeat 1) (V.toList values)++realHistRange :: (RealFrac x) => PlotHist x y -> (x,x)+realHistRange hist = fromMaybe range $ _plot_hist_range hist+    where values = V.fromList (_plot_hist_values hist)+          range = if V.null values+                    then (0,0)+                    else (V.minimum values, V.maximum values)++$( makeLenses ''PlotHist )
+ Graphics/Rendering/Chart/Plot/Lines.hs view
@@ -0,0 +1,102 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Graphics.Rendering.Chart.Plot.Lines+-- Copyright   :  (c) Tim Docker 2006, 2014+-- License     :  BSD-style (see chart/COPYRIGHT)+--+-- Line plots+--+{-# LANGUAGE TemplateHaskell #-}++module Graphics.Rendering.Chart.Plot.Lines(+    PlotLines(..),+    defaultPlotLineStyle,+    hlinePlot,+    vlinePlot,++    plot_lines_title,+    plot_lines_style,+    plot_lines_values,+    plot_lines_limit_values,+) where++import Control.Lens+import Graphics.Rendering.Chart.Geometry+import Graphics.Rendering.Chart.Drawing+import Graphics.Rendering.Chart.Plot.Types+import Data.Colour (opaque)+import Data.Colour.Names (blue)+import Data.Default.Class++-- | Value defining a series of (possibly disjointed) lines,+--   and a style in which to render them.+data PlotLines x y = PlotLines {+    _plot_lines_title        :: String,+    _plot_lines_style        :: LineStyle,++    -- | The lines to be plotted+    _plot_lines_values       :: [[(x,y)]],++    -- | Additional lines to be plotted, specified using+    -- the Limit type to allow referencing the edges of+    -- the plot area.+    _plot_lines_limit_values :: [[(Limit x, Limit y)]]+}++instance ToPlot PlotLines where+    toPlot p = Plot {+        _plot_render     = renderPlotLines p,+        _plot_legend     = [(_plot_lines_title p, renderPlotLegendLines p)],+        _plot_all_points = ( map fst pts ++ xs, map snd pts ++ ys )+    }+      where+        pts = concat (_plot_lines_values p)+        xs = [ x | (LValue x,_) <- concat (_plot_lines_limit_values p)]+        ys = [ y | (_,LValue y) <- concat (_plot_lines_limit_values p)]++renderPlotLines :: PlotLines x y -> PointMapFn x y -> BackendProgram ()+renderPlotLines p pmap = +  withLineStyle (_plot_lines_style p) $ do+    mapM_ (drawLines (mapXY pmap)) (_plot_lines_values p)+    mapM_ (drawLines pmap) (_plot_lines_limit_values p)+  where+    drawLines mapfn pts = alignStrokePoints (map mapfn pts) >>= strokePointPath ++renderPlotLegendLines :: PlotLines x y -> Rect -> BackendProgram ()+renderPlotLegendLines p (Rect p1 p2) = +  withLineStyle (_plot_lines_style p) $ do+    let y = (p_y p1 + p_y p2) / 2+    ps <- alignStrokePoints [Point (p_x p1) y, Point (p_x p2) y]+    strokePointPath ps++defaultPlotLineStyle :: LineStyle+defaultPlotLineStyle = (solidLine 1 $ opaque blue){+     _line_cap  = LineCapRound,+     _line_join = LineJoinRound+ }++instance Default (PlotLines x y) where+  def = PlotLines +    { _plot_lines_title        = ""+    , _plot_lines_style        = defaultPlotLineStyle+    , _plot_lines_values       = []+    , _plot_lines_limit_values = []+    }++-- | Helper function to plot a single horizontal line.+hlinePlot :: String -> LineStyle -> b -> Plot a b+hlinePlot t ls v = toPlot def {+    _plot_lines_title        = t,+    _plot_lines_style        = ls,+    _plot_lines_limit_values = [[(LMin, LValue v),(LMax, LValue v)]]+    }++-- | Helper function to plot a single vertical line.+vlinePlot :: String -> LineStyle -> a -> Plot a b+vlinePlot t ls v = toPlot def {+    _plot_lines_title        = t,+    _plot_lines_style        = ls,+    _plot_lines_limit_values = [[(LValue v,LMin),(LValue v,LMax)]]+    }++$( makeLenses ''PlotLines )
+ Graphics/Rendering/Chart/Plot/Pie.hs view
@@ -0,0 +1,228 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Graphics.Rendering.Chart.Plot.Pie+-- Copyright   :  (c) Tim Docker 2008, 2014+-- License     :  BSD-style (see chart/COPYRIGHT)+--+-- A  basic pie chart.+--+-- Pie charts are handled different to other plots, in that they+-- have their own layout, and can't be composed with other plots. A+-- pie chart is rendered with code in the following form:+--+-- @+-- values :: [PieItem]+-- values = [...]+-- layout :: PieLayout+-- layout = pie_plot ^: pie_data ^= values+--        $ def+-- renderable = toRenderable layout+-- @+{-# LANGUAGE TemplateHaskell #-}++module Graphics.Rendering.Chart.Plot.Pie(+    PieLayout(..),+    PieChart(..),+    PieItem(..),++    pieToRenderable,+    pieChartToRenderable,++    pie_title,+    pie_title_style,+    pie_plot,+    pie_background,+    pie_margin,+    pie_data,+    pie_colors,+    pie_label_style,+    pie_label_line_style,+    pie_start_angle,+    pitem_label,+    pitem_offset,+    pitem_value,++) where+-- original code thanks to Neal Alexander++-- see ../Drawing.hs for why we do not use hiding (moveTo) for+-- lens < 4+import Control.Lens+import Data.Colour+import Data.Colour.Names (white)+import Data.Default.Class+import Control.Monad++import Graphics.Rendering.Chart.Geometry hiding (moveTo)+import qualified Graphics.Rendering.Chart.Geometry as G+import Graphics.Rendering.Chart.Drawing+import Graphics.Rendering.Chart.Renderable+import Graphics.Rendering.Chart.Grid++data PieLayout = PieLayout {+   _pie_title       :: String,+   _pie_title_style :: FontStyle,+   _pie_plot        :: PieChart,+   _pie_background  :: FillStyle,+   _pie_margin      :: Double+}++data PieChart = PieChart {+   _pie_data             :: [PieItem],+   _pie_colors           :: [AlphaColour Double],+   _pie_label_style      :: FontStyle,+   _pie_label_line_style :: LineStyle,+   _pie_start_angle      :: Double++}++data PieItem = PieItem {+   _pitem_label  :: String,+   _pitem_offset :: Double,+   _pitem_value  :: Double+}++instance Default PieChart where+  def = PieChart+    { _pie_data             = []+    , _pie_colors           = defaultColorSeq+    , _pie_label_style      = def+    , _pie_label_line_style = solidLine 1 $ opaque black+    , _pie_start_angle      = 0+    }++instance Default PieItem where+  def = PieItem "" 0 0++instance Default PieLayout where+  def = PieLayout+    { _pie_background  = solidFillStyle $ opaque white+    , _pie_title       = ""+    , _pie_title_style = def { _font_size   = 15+                             , _font_weight = FontWeightBold }+    , _pie_plot        = def+    , _pie_margin      = 10+    }++instance ToRenderable PieLayout where+  toRenderable = setPickFn nullPickFn . pieToRenderable++pieChartToRenderable :: PieChart -> Renderable (PickFn a)+pieChartToRenderable p = Renderable { minsize = minsizePie p+                                    , render  = renderPie p+                                    }++instance ToRenderable PieChart where+  toRenderable = setPickFn nullPickFn . pieChartToRenderable++pieToRenderable :: PieLayout -> Renderable (PickFn a)+pieToRenderable p = fillBackground (_pie_background p) (+       gridToRenderable $ aboveN+         [ tval $ addMargins (lm/2,0,0,0) (setPickFn nullPickFn title)+         , weights (1,1) $ tval $ addMargins (lm,lm,lm,lm)+                                             (pieChartToRenderable $ _pie_plot p)+         ] )+      where+        title = label (_pie_title_style p) HTA_Centre VTA_Top (_pie_title p)+        lm    = _pie_margin p++extraSpace :: PieChart -> BackendProgram (Double, Double)+extraSpace p = do+    textSizes <- mapM (textDimension . _pitem_label) (_pie_data p)+    let maxw  = foldr (max.fst) 0 textSizes+    let maxh  = foldr (max.snd) 0 textSizes+    let maxo  = foldr (max._pitem_offset) 0 (_pie_data p)+    let extra = label_rgap + label_rlength + maxo+    return (extra + maxw, extra + maxh )++minsizePie :: PieChart -> BackendProgram (Double, Double)+minsizePie p = do+    (extraw,extrah) <- extraSpace p+    return (extraw * 2, extrah * 2)++renderPie :: PieChart -> (Double, Double) -> BackendProgram (PickFn a)+renderPie p (w,h) = do+    (extraw,extrah) <- extraSpace p+    -- let (w,h)  = (p_x p2 - p_x p1, p_y p2 - p_y p1)+    -- let center = Point (p_x p1 + w/2)  (p_y p1 + h/2)+    --+    let center = Point (w/2) (h/2)+    let radius = min (w - 2*extraw) (h - 2*extrah) / 2++    foldM_ (paint center radius) (_pie_start_angle p)+           (zip (_pie_colors p) content)+    return nullPickFn++    where+        -- p1 = Point 0 0+        -- p2 = Point w h+        content = let total = sum (map _pitem_value (_pie_data p))+                  in [ pitem{_pitem_value=_pitem_value pitem/total}+                     | pitem <- _pie_data p ]++        paint :: Point -> Double -> Double -> (AlphaColour Double, PieItem)+              -> BackendProgram Double+        paint center radius a1 (color,pitem) = do+            let ax     = 360.0 * _pitem_value pitem+            let a2     = a1 + (ax / 2)+            let a3     = a1 + ax+            let offset = _pitem_offset pitem++            pieSlice (ray a2 offset) a1 a3 color+            pieLabel (_pitem_label pitem) a2 offset++            return a3++            where+                pieLabel :: String -> Double -> Double -> BackendProgram ()+                pieLabel name angle offset =+                    withFontStyle (_pie_label_style p) $+                      withLineStyle (_pie_label_line_style p) $ do+                        let p1 = ray angle (radius+label_rgap+label_rlength+offset)+                        p1a <- alignStrokePoint p1+                        (tw,_) <- textDimension name+                        let (offset',anchor) = if angle < 90 || angle > 270+                                              then ((0+),HTA_Left)+                                              else ((0-),HTA_Right)+                        p0 <- alignStrokePoint $ ray angle (radius + label_rgap+offset)+                        strokePath $ G.moveTo p0+                                  <> lineTo p1a+                                  <> lineTo' (p_x p1a + offset' (tw + label_rgap)) (p_y p1a)++                        let p2 = p1 `pvadd` Vector (offset' label_rgap) 0+                        drawTextA anchor VTA_Bottom p2 name++                pieSlice :: Point -> Double -> Double -> AlphaColour Double -> BackendProgram ()+                pieSlice (Point x y) arc1 arc2 pColor = do+                    let path = arc' x y radius (radian arc1) (radian arc2)+                            <> lineTo' x y+                            <> lineTo' x y+                            <> close++                    withFillStyle (FillStyleSolid pColor) $+                      fillPath path+                    withLineStyle (def { _line_color = withOpacity white 0.1 }) $+                      strokePath path++                ray :: Double -> Double -> Point+                ray angle r = Point x' y'+                  where+                    x'   = x + (cos' * x'')+                    y'   = y + (sin' * x'')+                    cos' = (cos . radian) angle+                    sin' = (sin . radian) angle+                    -- TODO: is x'' defined in this way to try and avoid+                    --       numerical rounding?+                    x''  = (x + r) - x+                    x    = p_x center+                    y    = p_y center++                radian = (*(pi / 180.0))++label_rgap, label_rlength :: Double+label_rgap = 5+label_rlength = 15++$( makeLenses ''PieLayout )+$( makeLenses ''PieChart )+$( makeLenses ''PieItem )
+ Graphics/Rendering/Chart/Plot/Points.hs view
@@ -0,0 +1,69 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Graphics.Rendering.Chart.Plot.Points+-- Copyright   :  (c) Tim Docker 2006, 2014+-- License     :  BSD-style (see chart/COPYRIGHT)+--+-- Functions to plot sets of points, marked in various styles.++{-# LANGUAGE TemplateHaskell #-}++module Graphics.Rendering.Chart.Plot.Points(+    PlotPoints(..),++    -- * Accessors+    -- | These accessors are generated by template haskell++    plot_points_title,+    plot_points_style,+    plot_points_values,+) where+    +import Control.Lens+import Graphics.Rendering.Chart.Geometry+import Graphics.Rendering.Chart.Drawing+import Graphics.Rendering.Chart.Plot.Types+import Data.Default.Class++-- | Value defining a series of datapoints, and a style in+--   which to render them.+data PlotPoints x y = PlotPoints {+    _plot_points_title  :: String,+    _plot_points_style  :: PointStyle,+    _plot_points_values :: [(x,y)]+}++instance ToPlot PlotPoints where+    toPlot p = Plot {+        _plot_render     = renderPlotPoints p,+        _plot_legend     = [(_plot_points_title p, renderPlotLegendPoints p)],+        _plot_all_points = (map fst pts, map snd pts)+    }+      where+        pts = _plot_points_values p++renderPlotPoints :: PlotPoints x y -> PointMapFn x y -> BackendProgram ()+renderPlotPoints p pmap = +    mapM_ (drawPoint ps . pmap') (_plot_points_values p)+  where+    pmap' = mapXY pmap+    ps = _plot_points_style p++renderPlotLegendPoints :: PlotPoints x y -> Rect -> BackendProgram ()+renderPlotLegendPoints p (Rect p1 p2) = do+    drawPoint ps (Point (p_x p1)              y)+    drawPoint ps (Point ((p_x p1 + p_x p2)/2) y)+    drawPoint ps (Point (p_x p2)              y)++  where+    ps = _plot_points_style p+    y = (p_y p1 + p_y p2)/2++instance Default (PlotPoints x y) where+  def = PlotPoints +    { _plot_points_title  = ""+    , _plot_points_style  = def+    , _plot_points_values = []+    }++$( makeLenses ''PlotPoints )
+ Graphics/Rendering/Chart/Plot/Types.hs view
@@ -0,0 +1,79 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Graphics.Rendering.Chart.Plot.Types+-- Copyright   :  (c) Tim Docker 2006, 2014+-- License     :  BSD-style (see chart/COPYRIGHT)+--+-- Datatypes and functions common to the implementation of the various+-- plot types.+--+{-# LANGUAGE TemplateHaskell #-}++module Graphics.Rendering.Chart.Plot.Types(+    Plot(..),+    joinPlot,+    ToPlot(..),++    mapXY,++    plot_render,+    plot_legend,+    plot_all_points,++    ) where++import Graphics.Rendering.Chart.Geometry+import Graphics.Rendering.Chart.Drawing+import Control.Lens++-- | Interface to control plotting on a 2D area.+data Plot x y = Plot {++    -- | Given the mapping between model space coordinates and device+    --   coordinates, render this plot into a chart.+    _plot_render     :: PointMapFn x y -> BackendProgram (),++    -- | Details for how to show this plot in a legend. For each item+    --   the string is the text to show, and the function renders a+    --   graphical sample of the plot.+    _plot_legend     :: [ (String, Rect -> BackendProgram ()) ],++    -- | All of the model space coordinates to be plotted. These are+    --   used to autoscale the axes where necessary.+    _plot_all_points :: ([x],[y])+}++-- | A type class abstracting the conversion of a value to a Plot.+class ToPlot a where+   toPlot :: a x y -> Plot x y++instance ToPlot Plot where+  toPlot p = p++-- | Join any two plots together (they will share a legend).+joinPlot :: Plot x y -> Plot x y -> Plot x y+joinPlot Plot{ _plot_render     = renderP+             , _plot_legend     = legendP+             , _plot_all_points = (xsP,ysP) }+         Plot{ _plot_render     = renderQ+             , _plot_legend     = legendQ+             , _plot_all_points = (xsQ,ysQ) }++       = Plot{ _plot_render     = \a-> renderP a >> renderQ a+             , _plot_legend     = legendP ++ legendQ+             , _plot_all_points = ( xsP++xsQ, ysP++ysQ )+             }+++----------------------------------------------------------------------++mapXY :: PointMapFn x y -> (x,y) -> Point+mapXY f (x,y) = f (LValue x, LValue y)++----------------------------------------------------------------------++++----------------------------------------------------------------------++$( makeLenses ''Plot )
+ Graphics/Rendering/Chart/Plot/Vectors.hs view
@@ -0,0 +1,145 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Graphics.Rendering.Chart.Plot.Vectors+-- Copyright   :  (c) Anton Vorontsov <anton@enomsg.org> 2014+-- License     :  BSD-style (see chart/COPYRIGHT)+--+-- Vector plots+--+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}++module Graphics.Rendering.Chart.Plot.Vectors(+    PlotVectors(..),+    VectorStyle(..),+    plotVectorField,+    plot_vectors_mapf,+    plot_vectors_grid,+    plot_vectors_title,+    plot_vectors_style,+    plot_vectors_scale,+    plot_vectors_values,+    vector_line_style,+    vector_head_style,+) where++import Control.Lens+import Control.Monad+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif+import Data.Tuple+import Data.Colour hiding (over)+import Data.Colour.Names+import Data.Default.Class+import Graphics.Rendering.Chart.Axis+import Graphics.Rendering.Chart.Drawing+import Graphics.Rendering.Chart.Geometry+import Graphics.Rendering.Chart.Plot.Types++data VectorStyle = VectorStyle+    { _vector_line_style :: LineStyle+    , _vector_head_style :: PointStyle+    }++$( makeLenses ''VectorStyle )++data PlotVectors x y = PlotVectors+    { _plot_vectors_title        :: String+    , _plot_vectors_style        :: VectorStyle+    -- | Set to 1 (default) to normalize the length of vectors to a space+    --   between them (so that the vectors never overlap on the graph).+    --   Set to 0 to disable any scaling.+    --   Values in between 0 and 1 are also permitted to adjust scaling.+    , _plot_vectors_scale        :: Double+    -- | Provide a square-tiled regular grid.+    , _plot_vectors_grid         :: [(x,y)]+    -- | Provide a vector field (R^2 -> R^2) function.+    , _plot_vectors_mapf         :: (x,y) -> (x,y)+    -- | Provide a prepared list of (start,vector) pairs.+    , _plot_vectors_values       :: [((x,y),(x,y))]+    }++$( makeLenses ''PlotVectors )++mapGrid :: (PlotValue y, PlotValue x)+        => [(x,y)] -> ((x,y) -> (x,y)) -> [((x,y),(x,y))]+mapGrid grid f = zip grid (f <$> grid)++plotVectorField :: (PlotValue x, PlotValue y) => PlotVectors x y -> Plot x y+plotVectorField pv = Plot+    { _plot_render     = renderPlotVectors pv+    , _plot_legend     = [(_plot_vectors_title pv, renderPlotLegendVectors pv)]+    , _plot_all_points = (map fst pts, map snd pts)+    }+  where+    pvals = _plot_vectors_values pv+    mvals = mapGrid (_plot_vectors_grid pv) (_plot_vectors_mapf pv)+    pts = concatMap (\(a,b) -> [a,b]) (pvals ++ mvals)++renderPlotVectors :: (PlotValue x, PlotValue y)+                  => PlotVectors x y -> PointMapFn x y -> BackendProgram ()+renderPlotVectors pv pmap = do+    let pvals   = _plot_vectors_values pv+        mvals   = mapGrid (_plot_vectors_grid pv) (_plot_vectors_mapf pv)+        trans   = translateToStart <$> (pvals ++ mvals)+        pvecs   = filter (\v -> vlen' v > 0) $ over both (mapXY pmap) <$> trans+        mgrid   = take 2 $ fst <$> pvecs+        maxLen  = maximum $ vlen' <$> pvecs+        spacing = (!!1) $ (vlen <$> zipWith psub mgrid (reverse mgrid)) ++ [maxLen]+        sfactor = spacing/maxLen                  -- Non-adjusted scale factor+        afactor = sfactor + (1 - sfactor)*(1 - _plot_vectors_scale pv)+        tails   = pscale afactor <$> pvecs          -- Paths of arrows' tails+        angles  = (vangle . psub' . swap) <$> pvecs -- Angles of the arrows+        centers = snd <$> tails                     -- Where to draw arrow heads+    mapM_ (drawTail radius) tails+    zipWithM_ (drawArrowHead radius) centers angles+  where+    psub' = uncurry psub+    vlen' = vlen . psub'+    pvs = _plot_vectors_style pv+    radius = _point_radius $ _vector_head_style pvs+    hs angle = _vector_head_style pvs & point_shape+                  %~ (\(PointShapeArrowHead a) -> PointShapeArrowHead $ a+angle)+    translateToStart (s@(x,y),(vx,vy)) = (s,(tr x vx,tr y vy))+      where tr p t = fromValue $ toValue p + toValue t+    pscale w v@(s,_) = (s,translateP (vscale w . psub' $ swap v) s)+    drawTail r v = withLineStyle (_vector_line_style pvs) $+        strokePointPath $ (^..each) v'+      where+        v'  = pscale (1-(3/2)*r/l) v+        l   = vlen' v+    drawArrowHead r (Point x y) theta =+        withTranslation (Point (-r*cos theta) (-r*sin theta))+                        (drawPoint (hs theta) (Point x y))++renderPlotLegendVectors :: (PlotValue x, PlotValue y)+                        => PlotVectors x y -> Rect -> BackendProgram ()+renderPlotLegendVectors pv (Rect p1 p2) = do+    let y = (p_y p1 + p_y p2)/2+        pv' = plot_vectors_grid .~ []+            $ plot_vectors_values .~ [((fromValue $ p_x p1, fromValue y),+                                       (fromValue $ p_x p2, fromValue 0))]+            $ pv+    renderPlotVectors pv' pmap+  where+    pmap (LValue x,LValue y) = Point (toValue x) (toValue y)+    pmap _ = Point 0 0++instance Default VectorStyle where+  def = VectorStyle+    { _vector_line_style = (solidLine lw $ opaque blue)+                              { _line_cap = LineCapSquare }+    , _vector_head_style = PointStyle (opaque red) transparent lw (2*lw)+                                      (PointShapeArrowHead 0)+    } where lw = 2++instance Default (PlotVectors x y) where+  def = PlotVectors+    { _plot_vectors_title        = ""+    , _plot_vectors_style        = def+    , _plot_vectors_scale        = 1+    , _plot_vectors_grid         = []+    , _plot_vectors_mapf         = id+    , _plot_vectors_values       = []+    }
Graphics/Rendering/Chart/Renderable.hs view
@@ -1,272 +1,271 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Graphics.Rendering.Chart.Renderable--- Copyright   :  (c) Tim Docker 2006+-- Copyright   :  (c) Tim Docker 2006, 2014 -- License     :  BSD-style (see chart/COPYRIGHT)+--+-- This module contains the definition of the 'Renderable' type, which+-- is a composable drawing element, along with assorted functions to+-- them.+--+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE TemplateHaskell #-} -module Graphics.Rendering.Chart.Renderable where+module Graphics.Rendering.Chart.Renderable(+    Renderable(..),+    ToRenderable(..),+    PickFn,+    Rectangle(..),+    RectCornerStyle(..), -import qualified Graphics.Rendering.Cairo as C+    rectangleToRenderable,+    drawRectangle,++    fillBackground,+    addMargins,+    emptyRenderable,+    embedRenderable,+    label,+    rlabel,+    spacer,+    spacer1,+    setPickFn,+    mapMaybePickFn,+    mapPickFn,+    nullPickFn,++    rect_minsize,+    rect_fillStyle,+    rect_lineStyle,+    rect_cornerStyle,+) where+ import Control.Monad-import Data.List ( nub, partition, transpose, sort )+import Control.Lens+import Data.Default.Class -import Graphics.Rendering.Chart.Types-import Graphics.Rendering.Chart.Plot+import Graphics.Rendering.Chart.Geometry+import Graphics.Rendering.Chart.Drawing+import Graphics.Rendering.Chart.Utils +-- | A function that maps a point in device coordinates to some value.+--+--   Perhaps it might be generalised from Maybe a to+--   (MonadPlus m ) => m a in the future.+type PickFn a = Point -> Maybe a++nullPickFn :: PickFn a+nullPickFn = const Nothing+ -- | A Renderable is a record of functions required to layout a--- graphic element.-data Renderable = Renderable {+--   graphic element.+data Renderable a = Renderable { -   -- | a Cairo action to calculate a minimum size,-   minsize :: C.Render RectSize,+   -- | Calculate the minimum size of the renderable.+   minsize :: BackendProgram RectSize, -   -- | a Cairo action for drawing it within a specified rectangle.-   render ::  Rect -> C.Render ()+   -- | Draw the renderable with a rectangle, which covers+   --   the origin to a given point.+   --+   --   The resulting "pick" function  maps a point in the image to a value.+   render  :: RectSize -> BackendProgram (PickFn a) }---- | A type class abtracting the conversion of a value to a--- Renderable.+  deriving (Functor) +-- | A type class abtracting the conversion of a value to a Renderable. class ToRenderable a where-   toRenderable :: a -> Renderable+  toRenderable :: a -> Renderable () +instance ToRenderable (Renderable a) where+  toRenderable = void++emptyRenderable :: Renderable a emptyRenderable = spacer (0,0) -spacer sz = Renderable {+-- | Create a blank renderable with a specified minimum size.+spacer :: RectSize -> Renderable a+spacer sz  = Renderable {    minsize = return sz,-   render  = \_ -> return ()+   render  = \_ -> return nullPickFn } -addMargins :: (Double,Double,Double,Double) -> Renderable -> Renderable++-- | Create a blank renderable with a minimum size the same as+--   some other renderable.+spacer1 :: Renderable a -> Renderable b+spacer1 r  = r{ render  = \_ -> return nullPickFn }++-- | Replace the pick function of a renderable with another.+setPickFn :: PickFn b -> Renderable a -> Renderable b+setPickFn pickfn r = r{ render  = \sz -> render r sz >> return pickfn }++-- | Map a function over the result of a renderable's pickfunction, keeping only 'Just' results.+mapMaybePickFn :: (a -> Maybe b) -> Renderable a -> Renderable b+mapMaybePickFn f r = r{ render = \sz -> do pf <- render r sz+                                           return (join . fmap f . pf) }++-- | Map a function over result of a renderable's pickfunction.+mapPickFn :: (a -> b) -> Renderable a -> Renderable b+mapPickFn f = mapMaybePickFn (Just . f)++-- | Add some spacing at the edges of a renderable.+addMargins :: (Double,Double,Double,Double) -- ^ The spacing to be added.+           -> Renderable a                  -- ^ The source renderable.+           -> Renderable a addMargins (t,b,l,r) rd = Renderable { minsize = mf, render = rf }   where     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+    rf (w,h) =+        withTranslation (Point l t) $ do+          pickf <- render rd (w-l-r,h-t-b)+          return (mkpickf pickf (t,b,l,r) (w,h)) -vertical, horizontal :: [(Double,Renderable)] -> Renderable -vertical rs = grid [1] (map fst rs) [[(0,snd r)] | r <- rs]-horizontal rs = grid (map fst rs) [1] [[(0,snd r) | r <- rs]]+    mkpickf pickf (t',b',l',r') (w,h) (Point x y)+        | x >= l' && x <= w-r' && y >= t' && t' <= h-b' = pickf (Point (x-l') (y-t'))+        | otherwise                                     = Nothing --- | Layout multiple Renderables into a grid.--- Arg 1 is the weights for the allocation of extra horizontal space--- to columns, Arg 2 is the weights for the allocation of extra--- vertical space to rows, and Arg 3 is the grid of renderables to be--- layed out. Each element of the grid is a tuple - the first item of--- the tuple is the drawing priority.  Lower priorities get drawn--- first. Drawing order is significant when Renderables draw outside--- their edges.-grid :: [Double] -> [Double] -> [[(Int,Renderable)]] -> Renderable-grid we he rss = Renderable { minsize = mf, render = rf }+-- | Overlay a renderable over a solid background fill.+fillBackground :: FillStyle -> Renderable a -> Renderable a+fillBackground fs r = r{ render = rf }   where-    mf = do-      msizes <- getSizes-      let widths = (map.map) fst msizes-      let heights = (map.map) snd msizes-      return ((sum.map maximum.transpose) widths,(sum.map maximum) heights)+    rf rsize@(w,h) = do+      withFillStyle fs $ do+        p <- alignFillPath $ rectPath (Rect (Point 0 0) (Point w h))+        fillPath p+      render r rsize -    rf (Rect p1 p2) = do-      msizes <- getSizes-      let widths = (map maximum.(map.map) fst.transpose) msizes-      let heights = (map maximum.(map.map) snd) msizes-      let widths1 = allocate (p_x p2 - p_x p1 - sum widths) we widths-      let heights1 = allocate (p_y p2 - p_y p1 - sum heights) he heights-      let xs = scanl (+) (p_x p1) widths1-      let ys = scanl (+) (p_y p1) heights1-      -      forM_ priorities $ \pr->-        forM_ (zip3 rss ys (tail ys))  $ \(rs,y0,y1) ->-          forM_ (zip3 rs xs (tail xs))  $ \((n,r),x0,x1) ->-            when (n==pr) $ render r (Rect (Point x0 y0) (Point x1 y1))+-- | Helper function for using a renderable, when we generate it+--   in the BackendProgram monad.+embedRenderable :: BackendProgram (Renderable a) -> Renderable a+embedRenderable ca = Renderable {+   minsize = do { a <- ca; minsize a },+   render  = \ r -> do { a <- ca; render a r }+} -    getSizes = (mapM.mapM) (\(n,r)-> minsize r) rss-    priorities = sort (nub ((concatMap.map) fst rss)) -allocate :: Double -> [Double] -> [Double] -> [Double]-allocate extra ws vs = zipWith (+) vs (extras++[0,0..])-  where-    total = sum ws -    extras = [ extra * v / total | v <- ws ]--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+----------------------------------------------------------------------+-- Labels -    rect = Rect (Point 0 0) (Point (fromIntegral width) (fromIntegral height))+-- | Construct a renderable from a text string, aligned with the axes.+label :: FontStyle -> HTextAnchor -> VTextAnchor -> String -> Renderable String+label fs hta vta = rlabel fs hta vta 0 -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+-- | Construct a renderable from a text string, rotated wrt to axes. The angle+--   of rotation is in degrees, measured clockwise from the horizontal.+rlabel :: FontStyle -> HTextAnchor -> VTextAnchor -> Double -> String -> Renderable String+rlabel fs hta vta rot s = Renderable { minsize = mf, render = rf }   where-    rfn = do-	render chart rect-        C.showPage+    mf = withFontStyle fs $ do+       ts <- textSize s+       let sz = (textSizeWidth ts, textSizeHeight ts)+       return (xwid sz, ywid sz) -    rect = Rect (Point 0 0) (Point (fromIntegral width) (fromIntegral height))+    rf (w0,h0) = withFontStyle fs $ do+      ts <- textSize s+      let sz@(w,h) = (textSizeWidth ts, textSizeHeight ts)+          descent = textSizeDescent ts -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+          xadj HTA_Left   = xwid sz/2+          xadj HTA_Centre = w0/2+          xadj HTA_Right  = w0 - xwid sz/2 -    rect = Rect (Point 0 0) (Point (fromIntegral width) (fromIntegral height))+          yadj VTA_Top      = ywid sz/2+          yadj VTA_Centre   = h0/2+          yadj VTA_Bottom   = h0 - ywid sz/2+          yadj VTA_BaseLine = h0 - ywid sz/2 + descent*acr -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+      withTranslation (Point 0 (-descent)) $+        withTranslation (Point (xadj hta) (yadj vta)) $+          withRotation rot' $ do+            drawText (Point (-w/2) (h/2)) s+            return (\_-> Just s)  -- PickFn String -embedRenderable :: C.Render Renderable -> Renderable-embedRenderable ca = Renderable {-   minsize = do { a <- ca; minsize a },-   render = \ r -> do { a <- ca; render a r }-}+    rot'      = rot / 180 * pi+    (cr,sr)   = (cos rot', sin rot')+    (acr,asr) = (abs cr, abs sr) +    xwid (w,h) = w*acr + h*asr+    ywid (w,h) = w*asr + h*acr  ------------------------------------------------------------------------- Legend+-- Rectangles -data LegendStyle = LegendStyle {-   legend_label_style :: CairoFontStyle,-   legend_margin :: Double,-   legend_plot_size :: Double-}+data RectCornerStyle = RCornerSquare+                     | RCornerBevel Double+                     | RCornerRounded Double -data Legend = Legend Bool LegendStyle [(String,Plot)]+data Rectangle = Rectangle {+  _rect_minsize     :: RectSize,+  _rect_fillStyle   :: Maybe FillStyle,+  _rect_lineStyle   :: Maybe LineStyle,+  _rect_cornerStyle :: RectCornerStyle+} -instance ToRenderable Legend where-  toRenderable l = Renderable {-    minsize=minsizeLegend l,-    render=renderLegend l-  }+instance Default Rectangle where+  def = Rectangle+    { _rect_minsize     = (0,0)+    , _rect_fillStyle   = Nothing+    , _rect_lineStyle   = Nothing+    , _rect_cornerStyle = RCornerSquare+    } -minsizeLegend :: Legend -> C.Render RectSize-minsizeLegend (Legend _ ls plots) = do-    let labels = nub $ 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)+instance ToRenderable Rectangle where+  toRenderable = rectangleToRenderable -renderLegend :: Legend -> Rect -> C.Render ()-renderLegend (Legend _ ls plots) (Rect rp1 rp2) = do-    foldM_ rf rp1 $ join_nub plots+rectangleToRenderable :: Rectangle -> Renderable a+rectangleToRenderable rectangle = Renderable mf rf   where-    lm = legend_margin ls-    lps = legend_plot_size ls--    rf :: Point -> (String,[Plot]) -> C.Render Point-    rf p1 (label,theseplots) = do-        (w,h) <- textSize label-	lgap <- legendSpacer-	let p2 = (p1 `pvadd` Vector lps 0)-        mapM_ (\p -> plot_render_legend p (mkrect p1 rp1 p2 rp2)) theseplots-	let p3 = Point (p_x p2 + lgap) (p_y rp1)-	drawText HTA_Left VTA_Top p3 label-        return (p3 `pvadd` Vector (w+lm) 0)-    join_nub :: [(String, a)] -> [(String, [a])]-    join_nub ((x,a1):ys) = case partition ((==x) . fst) ys of-                           (xs, rest) -> (x, a1:map snd xs) : join_nub rest-    join_nub [] = []+    mf = return (_rect_minsize rectangle)+    rf = \rectSize -> drawRectangle (Point 0 0)+                                    rectangle{ _rect_minsize = rectSize } -legendSpacer = do-    (lgap,_) <- textSize "X"-    return lgap+-- | Draw the specified rectangle such that its top-left vertex is placed at+--   the given position+drawRectangle :: Point -> Rectangle -> BackendProgram (PickFn a)+drawRectangle point rectangle = do+  maybeM () (fill point size) (_rect_fillStyle rectangle)+  maybeM () (stroke point size) (_rect_lineStyle rectangle)+  return nullPickFn+    where+      size = _rect_minsize rectangle -defaultLegendStyle = LegendStyle {-    legend_label_style=defaultFontStyle,-    legend_margin=20,-    legend_plot_size=20-}+      fill p sz fs =+          withFillStyle fs $+            fillPath $ strokeRectangleP p sz (_rect_cornerStyle rectangle) +      stroke p sz ls =+          withLineStyle ls $+            strokePath $ strokeRectangleP p sz (_rect_cornerStyle rectangle) -------------------------------------------------------------------------- Labels+      strokeRectangleP (Point x1 y1) (x2,y2) RCornerSquare =+          let (x3,y3) = (x1+x2,y1+y2) in moveTo' x1 y1+                                      <> lineTo' x1 y3+                                      <> lineTo' x3 y3+                                      <> lineTo' x3 y1+                                      <> lineTo' x1 y1 -label :: CairoFontStyle -> HTextAnchor -> VTextAnchor -> String -> Renderable-label fs hta vta = rlabel fs hta vta 0+      strokeRectangleP (Point x1 y1) (x2,y2) (RCornerBevel s) =+          let (x3,y3) = (x1+x2,y1+y2) in moveTo' x1 (y1+s)+                                      <> lineTo' x1 (y3-s)+                                      <> lineTo' (x1+s) y3+                                      <> lineTo' (x3-s) y3+                                      <> lineTo' x3 (y3-s)+                                      <> lineTo' x3 (y1+s)+                                      <> lineTo' (x3-s) y1+                                      <> lineTo' (x1+s) y1+                                      <> lineTo' x1 (y1+s) -rlabel :: CairoFontStyle -> HTextAnchor -> VTextAnchor -> Double -> String -> Renderable-rlabel fs hta vta rot s = Renderable { minsize = mf, render = rf }-  where-    mf = do-       C.save-       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-       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-    xadj (w,h) HTA_Left x1 x2 =  x1 +(w*acr+h*asr)/2-    xadj (w,h) HTA_Centre x1 x2 = (x1 + x2)/2-    xadj (w,h) HTA_Right x1 x2 =  x2 -(w*acr+h*asr)/2-    yadj (w,h) VTA_Top y1 y2 =  y1 +(w*asr+h*acr)/2-    yadj (w,h) VTA_Centre y1 y2 = (y1+y2)/2-    yadj (w,h) VTA_Bottom y1 y2 =  y2 - (w*asr+h*acr)/2+      strokeRectangleP (Point x1 y1) (x2,y2) (RCornerRounded s) =+          let (x3,y3) = (x1+x2,y1+y2) in+            arcNeg (Point (x1+s) (y3-s)) s (pi2*2) pi2+            <> arcNeg (Point (x3-s) (y3-s)) s pi2 0+            <> arcNeg (Point (x3-s) (y1+s)) s 0 (pi2*3)+            <> arcNeg (Point (x1+s) (y1+s)) s (pi2*3) (pi2*2)+            <> lineTo' x1 (y3-s) -    rot' = rot / 180 * pi-    (cr,sr) = (cos rot', sin rot')-    (acr,asr) = (abs cr, abs sr)+      pi2 = pi / 2 --- a quick test to display labels with all combinations--- 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 ]-    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-    fs = fontStyle "sans" 30 C.FontSlantNormal C.FontWeightBold-    crossHairs r =Renderable {-      minsize = minsize r,-      render = \rect@(Rect (Point x1 y1) (Point x2 y2)) -> do-          let xa = (x1 + x2) / 2-          let ya = (y1 + y2) / 2-          strokeLines [Point x1 ya,Point x2 ya]-          strokeLines [Point xa y1,Point xa y2]-          render r rect-    }-    +$( makeLenses ''Rectangle )
− Graphics/Rendering/Chart/Simple.hs 
@@ -1,265 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Graphics.Rendering.Chart.Simple--- Copyright   :  (c) David Roundy 2007--- License     :  BSD-style (see chart/COPYRIGHT)------ An even simpler framework for creating 2D charts in Haskell.------ The basic idea is to make it as easy to plot as octave, which means that--- you provide no more information than you wish to provide.  We provide--- four plotting functions, which differ only in their output.  One--- produces a "Layout1" that you can customize using other--- Graphics.Rendering.Chart functions.  The other three produce their--- output directly.  All three accept the same input (except for the--- filename required by plotPDF and plotPS), and produce the same plots.------ The plot functions accept a variable number of arguments.  You must--- provide a [Double] which defines the points on the x axis, which must--- precede any of the "y" values.  The y values may either be [Double] or--- functions.  After any given y value, you can give either Strings or--- PlotKinds describing how you'd like that y printed.------ Examples:------ renderableToWindow (toRenderable $ plot [0,0.1..10] sin "sin(x)") 640 480------ plotWindow [0,1,3,4,8]] [12,15,1,5,8] "o" "points"------ plotPDF "foo.pdf" [0,0.1..10] sin "- " cos ". " cos "o"------ plotPS "foo.ps" [0,0.1..10] (sin.exp) "- " (sin.exp) "o-"-------------------------------------------------------------------------------module Graphics.Rendering.Chart.Simple( plot, PlotKind(..), xcoords,-                                        plotWindow, plotPDF, plotPS-                                      ) where--import Data.Maybe ( catMaybes )--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)]--styleSymbol :: Int -> PlotKind-styleSymbol ind = symbolSequence !! ind-    where symbolSequence = cycle [ Ex, HollowCircle, Triangle, DownTriangle, Square,-                                   Diamond, Plus, Star, FilledCircle ]--iplot :: [InternalPlot] -> Layout1-iplot foobar = defaultLayout1 {-        layout1_plots = concat $ zipWith toplot (ip foobar) [0..]-    }-    where ip (xs@(IPX _ _):xyss) = map (\ys -> (xs,ys)) yss ++ ip rest-              where yss = takeWhile isIPY xyss-                    rest = dropWhile isIPY xyss-          ip (_:xyss) = ip xyss-          ip [] = []-          isIPY (IPY _ _) = True-          isIPY _ = False-          toplot (IPX xs _, IPY ys yks) ind = map (\z -> (name yks, HA_Bottom, VA_Left, z)) plots-              where vs = map (\(x,y) -> Point x y) $ filter isOkay $ zip xs ys-                    plots = case catMaybes $ map plotas yks of-                            [] -> [toPlot $ defaultPlotLines-                                   { plot_lines_values = [vs],-                                     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 }-                    plotas Dashed = Just $ toPlot $ defaultPlotLines-                                   { plot_lines_values = [vs],-                                     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 }-                    plotas FilledCircle = Just $ toPlot $ defaultPlotPoints-                                          { plot_points_values = vs,-                                            plot_points_style=filledCircles 4 `styleColor` ind }-                    plotas HollowCircle = Just $ toPlot $ defaultPlotPoints-                                          { plot_points_values = vs,-                                            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 }-                    plotas DownTriangle = Just $ toPlot $ defaultPlotPoints-                                          { plot_points_values = vs,-                                            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 }-                    plotas Diamond = Just $ toPlot $ defaultPlotPoints-                                          { plot_points_values = vs,-                                            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 }-                    plotas Ex = Just $ toPlot $ defaultPlotPoints-                                          { plot_points_values = vs,-                                            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 }-                    plotas Symbols = plotas (styleSymbol ind)-                    plotas _ = Nothing-          isOkay (_,n) = not (isNaN n || isInfinite n)--name :: [PlotKind] -> String-name (Name s:_) = s-name (_:ks) = name ks-name [] = ""--str2k :: String -> [PlotKind]-str2k "" = []-str2k ". " = [Dotted]-str2k s@('?':_) = str2khelper s Symbols-str2k s@('@':_) = str2khelper s FilledCircle-str2k s@('#':_) = str2khelper s Square-str2k s@('v':_) = str2khelper s DownTriangle-str2k s@('^':_) = str2khelper s Triangle-str2k s@('o':_) = str2khelper s HollowCircle-str2k s@('+':_) = str2khelper s Plus-str2k s@('x':_) = str2khelper s Ex-str2k s@('*':_) = str2khelper s Star-str2k s@('.':_) = str2khelper s LittleDot-str2k "- " = [Dashed]-str2k "-" = [Solid]-str2k n = [Name n]--str2khelper :: String -> PlotKind -> [PlotKind]-str2khelper s@(_:r) x = case str2k r of-                        [] -> [x]-                        [Name _] -> [Name s]-                        xs -> x:xs---- | Type to define a few simple properties of each plot.-data PlotKind = Name String | FilledCircle | HollowCircle-              | Triangle | DownTriangle | Square | Diamond | Plus | Ex | Star | Symbols-              | LittleDot | Dashed | Dotted | Solid-              deriving ( Eq, Show, Ord )-data InternalPlot = IPY [Double] [PlotKind] | IPX [Double] [PlotKind]--uplot :: [UPlot] -> Layout1-uplot us = iplot $ nameDoubles $ evalfuncs us-    where nameDoubles :: [UPlot] -> [InternalPlot]-          nameDoubles (X xs:uus) = case grabName uus of-                                     (ks,uus') -> IPX xs ks : nameDoubles uus'-          nameDoubles (UDoubles xs:uus) = case grabName uus of-                                          (ks,uus') -> IPY xs ks : nameDoubles uus'-          nameDoubles (_:uus) = nameDoubles uus-          nameDoubles [] = []-          evalfuncs :: [UPlot] -> [UPlot]-          evalfuncs (UDoubles xs:uus) = X xs : map ef (takeWhile (not.isX) uus)-                                        ++ evalfuncs (dropWhile (not.isX) uus)-              where ef (UFunction f) = UDoubles (map f xs)-                    ef u = u-          evalfuncs (X xs:uus) = X xs : map ef (takeWhile (not.isX) uus)-                                 ++ evalfuncs (dropWhile (not.isX) uus)-              where ef (UFunction f) = UDoubles (map f xs)-                    ef u = u-          evalfuncs (u:uus) = u : evalfuncs uus-          evalfuncs [] = []-          grabName :: [UPlot] -> ([PlotKind],[UPlot])-          grabName (UString n:uus) = case grabName uus of-                                     (ks,uus') -> (str2k n++ks,uus')-          grabName (UKind ks:uus) = case grabName uus of-                                     (ks',uus') -> (ks++ks',uus')-          grabName uus = ([],uus)-          isX (X _) = True-          isX _ = False---- | The main plotting function.  The idea behind PlotType is shamelessly--- copied from Text.Printf (and is not exported).  All you need to know is--- that your arguments need to be in class PlotArg.  And PlotArg consists--- of functions and [Double] and String and PlotKind or [PlotKind].--plot :: PlotType a => a-plot = pl []-class PlotType t where-    pl :: [UPlot] -> t-instance (PlotArg a, PlotType r) => PlotType (a -> r) where-    pl args = \ a -> pl (toUPlot a ++ args)-instance PlotType Layout1 where-    pl args = uplot (reverse args)---- | Display a plot on the screen.--plotWindow :: PlotWindowType a => a-plotWindow = plw []-class PlotWindowType t where-    plw :: [UPlot] -> t-instance (PlotArg a, PlotWindowType r) => PlotWindowType (a -> r) where-    plw args = \ a -> plw (toUPlot a ++ args)-instance PlotWindowType (IO a) where-    plw args = do renderableToWindow (toRenderable $ uplot (reverse args)) 640 480-                  return undefined---- | Save a plot as a PDF file.--plotPDF :: PlotPDFType a => String -> a-plotPDF fn = pld fn []-class PlotPDFType t where-    pld :: FilePath -> [UPlot] -> t-instance (PlotArg a, PlotPDFType r) => PlotPDFType (a -> r) where-    pld fn args = \ a -> pld fn (toUPlot a ++ args)-instance PlotPDFType (IO a) where-    pld fn args = do renderableToPDFFile (toRenderable $ uplot (reverse args)) 640 480 fn-                     return undefined---- | Save a plot as a postscript file.--plotPS :: PlotPSType a => String -> a-plotPS fn = pls fn []-class PlotPSType t where-    pls :: FilePath -> [UPlot] -> t-instance (PlotArg a, PlotPSType r) => PlotPSType (a -> r) where-    pls fn args = \ a -> pls fn (toUPlot a ++ args)-instance PlotPSType (IO a) where-    pls fn args = do renderableToPSFile (toRenderable $ uplot (reverse args)) 640 480 fn-                     return undefined--data UPlot = UString String | UDoubles [Double] | UFunction (Double -> Double)-           | UKind [PlotKind] | X [Double]--xcoords :: [Double] -> UPlot-xcoords = X--class PlotArg a where-    toUPlot :: a -> [UPlot]--instance IsPlot p => PlotArg [p] where-    toUPlot = toUPlot'--instance (Real a, Real b, Fractional a, Fractional b) => PlotArg (a -> b) where-    toUPlot f = [UFunction (realToFrac . f . realToFrac)]--instance PlotArg UPlot where-    toUPlot = (:[])--instance PlotArg PlotKind where-    toUPlot = (:[]) . UKind . (:[])--class IsPlot c where-    toUPlot' :: [c] -> [UPlot]--instance IsPlot PlotKind where-    toUPlot' = (:[]) . UKind--instance IsPlot Double where-    toUPlot' = (:[]) . UDoubles--instance IsPlot Char where-    toUPlot' = (:[]) . UString--instance IsPlot p => IsPlot [p] where-    toUPlot' = reverse . concatMap toUPlot'--instance (IsPlot p, IsPlot q, IsPlot r) => IsPlot (p,q,r) where-    toUPlot' = reverse . concatMap f-        where f (p,q,r) = toUPlot' [p] ++ toUPlot' [q] ++ toUPlot' [r]--instance (IsPlot p, IsPlot q) => IsPlot (p,q) where-    toUPlot' = reverse . concatMap f-        where f (p,q) = toUPlot' [p] ++ toUPlot' [q]
+ Graphics/Rendering/Chart/SparkLine.hs view
@@ -0,0 +1,169 @@+---------------------------------------------------------------+-- |+-- Module      : Graphics.Rendering.Chart.Sparkline+-- Copyright   : (c) Hitesh Jasani, 2008, Malcolm Wallace 2011, Tim Docker 2014+-- License     : BSD3+--+-- Sparklines are mini graphs inspired by Edward Tufte; see+-- <http://www.edwardtufte.com/bboard/q-and-a-fetch-msg?msg_id=0001OR>+-- and+-- <http://en.wikipedia.org/wiki/Sparkline> for more information.+--+-- The original implementation (by Hitesh Jasani) used the gd+-- package as a backend renderer, and is still available at+-- <http://hackage.haskell.org/package/hsparklines>.+--+-- The present version integrates with+-- the Chart package, in the sense that Sparklines are just another+-- kind of (@ToRenderable a => a@), so they can be composed into grids+-- and used with the rest of Chart.+--+-- > dp :: [Double]+-- > dp = [24,21,32.3,24,15,34,43,55,57,72,74,75,73,72,55,44]+-- >+-- > sl = SparkLine barSpark dp+-- > fopts = FileOptions (sparkSize sl) PNG+-- > renderableToFile fopts (sparkLineToRenderable sl) "bar_spark.png" +-- >+---------------------------------------------------------------++module Graphics.Rendering.Chart.SparkLine+  ( -- * SparkLine type+    SparkLine(..)+    -- * Drawing options+  , SparkOptions(..)+  , smoothSpark+  , barSpark+    -- * Size calculation+  , sparkSize+    -- * Rendering function+  , renderSparkLine+  , sparkLineToRenderable+  , sparkWidth+  ) where++import Control.Monad+import Data.List+import Data.Ord+import Graphics.Rendering.Chart.Geometry+import Graphics.Rendering.Chart.Drawing+import Graphics.Rendering.Chart.Renderable+import Data.Colour+import Data.Colour.Names++-- | A sparkline is a single sequence of data values, treated as y-values.+--   The x-values are anonymous and implicit in the sequence.+data SparkLine = SparkLine { sl_options :: SparkOptions+                           , sl_data    :: [Double]+                           }++-- | Options to render the sparklines in different ways.+data SparkOptions = SparkOptions+  { so_smooth     :: Bool            -- ^ smooth or bars+  , so_step       :: Int             -- ^ step size+  , so_height     :: Int             -- ^ graph height (pixels)+  , so_limits     :: (Double,Double) -- ^ data point limits+  , so_bgColor    :: Colour Double   -- ^ background color+  , so_minColor   :: Colour Double   -- ^ color of minimum datapoint+  , so_maxColor   :: Colour Double   -- ^ color of maximum datapoint+  , so_lastColor  :: Colour Double   -- ^ color of last datapoint+  , so_minMarker  :: Bool            -- ^ display minimum marker+  , so_maxMarker  :: Bool            -- ^ display maximum marker+  , so_lastMarker :: Bool            -- ^ display last marker+  } deriving (Show)++-- | Default options for a smooth sparkline.+smoothSpark :: SparkOptions+smoothSpark  = SparkOptions+  { so_smooth     = True+  , so_step       = 2+  , so_height     = 20+  , so_limits     = (0,100)+  , so_bgColor    = white+  , so_minColor   = red+  , so_maxColor   = green+  , so_lastColor  = blue+  , so_minMarker  = True+  , so_maxMarker  = True+  , so_lastMarker = True+  }++-- | Default options for a barchart sparkline.+barSpark :: SparkOptions+barSpark  = smoothSpark { so_smooth=False }++-- | Create a renderable from a SparkLine.+sparkLineToRenderable :: SparkLine -> Renderable ()+sparkLineToRenderable sp = Renderable+            { minsize = let (w,h) = sparkSize sp in return (fromIntegral w , fromIntegral h)+            , render  = \_rect-> renderSparkLine sp+            }++instance ToRenderable SparkLine where+  toRenderable = sparkLineToRenderable++-- | Compute the width of a SparkLine, for rendering purposes.+sparkWidth :: SparkLine -> Int+sparkWidth SparkLine{sl_options=opt, sl_data=ds} =+  let w = 4 + (so_step opt) * (length ds - 1) + extrawidth+      extrawidth | so_smooth opt = 0+                 | otherwise  = bw * length ds+      bw | so_smooth opt = 0+         | otherwise  = 2+  in w++-- | Return the width and height of the SparkLine.+sparkSize :: SparkLine -> (Int,Int)+sparkSize s = (sparkWidth s, so_height (sl_options s))++-- | Render a SparkLine to a drawing surface.+renderSparkLine :: SparkLine -> BackendProgram (PickFn ())+renderSparkLine SparkLine{sl_options=opt, sl_data=ds} =+  let w = 4 + (so_step opt) * (length ds - 1) + extrawidth+      extrawidth | so_smooth opt = 0+                 | otherwise  = bw * length ds+      bw | so_smooth opt = 0+         | otherwise  = 2+      h = so_height opt +      dmin = fst (so_limits opt)+      dmax = snd (so_limits opt)+      coords = zipWith (\x y-> Point (fi x) y)+                       [1,(1+bw+so_step opt)..(1+(so_step opt+bw)*(length ds))]+                       [ fi h - ( (y-dmin) /+                                  ((dmax-dmin+1) / fi (h-4)) )+                         | y <- ds ]+      -- remember y increases as we go down the page+      minpt = maximumBy (comparing p_y) coords+      maxpt = minimumBy (comparing p_y) coords+      endpt = last coords+      boxpt :: Point -> Rect+      boxpt (Point x y) = Rect (Point (x-1)(y-1)) (Point (x+1)(y+1))+      fi    :: (Num b, Integral a) => a -> b+      fi    = fromIntegral+  in do++  withFillStyle (solidFillStyle (opaque (so_bgColor opt))) $ do+    fillPath (rectPath (Rect (Point 0 0) (Point (fi w) (fi h))))+  if so_smooth opt+    then do+      withLineStyle (solidLine 1 (opaque grey)) $ do+        p <- alignStrokePoints coords+        strokePointPath p+    else do+      withFillStyle (solidFillStyle (opaque grey)) $ do+        forM_ coords $ \ (Point x y) ->+          fillPath (rectPath (Rect (Point (x-1) y) (Point (x+1) (fi h))))+  when (so_minMarker opt) $ do+      withFillStyle (solidFillStyle (opaque (so_minColor opt))) $ do+        p <- alignFillPath (rectPath (boxpt minpt))+        fillPath p+  when (so_maxMarker opt) $ do+      withFillStyle (solidFillStyle (opaque (so_maxColor opt))) $ do+        p <- alignFillPath (rectPath (boxpt maxpt))+        fillPath p+  when (so_lastMarker opt) $ do+      withFillStyle (solidFillStyle (opaque (so_lastColor opt))) $ do+        p <- alignFillPath (rectPath (boxpt endpt))+        fillPath p+  return nullPickFn+
+ Graphics/Rendering/Chart/State.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE TemplateHaskell, FlexibleInstances #-}+module Graphics.Rendering.Chart.State(+  plot,+  plotLeft,+  plotRight,++  takeColor,+  takeShape,++  CState,+  colors,+  shapes,++  EC,+  execEC,+  liftEC,+  liftCState,+  ) where++import Control.Lens+import Control.Monad.State+import Data.Default.Class++import Data.Colour+import Data.Colour.Names++import Graphics.Rendering.Chart.Layout+import Graphics.Rendering.Chart.Plot+import Graphics.Rendering.Chart.Drawing+import Graphics.Rendering.Chart.Renderable++-- | The state held when monadically constructing a graphical element+data CState = CState {+  _colors :: [AlphaColour Double], -- ^ An infinite source of colors, for use in plots+  _shapes :: [PointShape]          -- ^ An infinite source of shapes, for use in plots+  }++$( makeLenses ''CState )++-- | We use nested State monads to give nice syntax. The outer state+-- is the graphical element being constructed (typically a+-- layout). The inner state contains any additional state+-- reqired. This approach means that lenses and the state monad lens+-- operators can be used directly on the value being constructed.+type EC l a = StateT l (State CState) a++instance Default CState where+  def = CState defColors defShapes+    where+      defColors = cycle (map opaque [blue,green,red,orange,yellow,violet])+      defShapes = cycle [PointShapeCircle,PointShapePlus,PointShapeCross,PointShapeStar]++instance (Default a,ToRenderable a) => ToRenderable (EC a b) where+  toRenderable = toRenderable . execEC+      +-- | Run the monadic `EC` computation, and return the graphical+-- element (ie the outer monad' state)+execEC :: (Default l) => EC l a -> l+execEC ec = evalState (execStateT ec def) def++-- | Nest the construction of a graphical element within+-- the construction of another.+liftEC :: (Default l1) => EC l1 a -> EC l2 l1+liftEC ec = do+  cs <- lift get+  let (l,cs') = runState (execStateT ec def) cs+  lift (put cs')+  return l++-- | Lift a a computation over `CState`+liftCState :: State CState a -> EC l a+liftCState = lift++-- | Add a plot to the `Layout` being constructed.+plot :: (ToPlot p) => EC (Layout x y) (p x y) -> EC (Layout x y) ()+plot pm = do+    p <- pm+    layout_plots %= (++[toPlot p])++-- | Add a plot against the left axis to the `LayoutLR` being constructed.+plotLeft :: (ToPlot p) => EC (LayoutLR x y1 y2) (p x y1) -> EC (LayoutLR x y1 y2) ()+plotLeft pm = do+  p <- pm+  layoutlr_plots %= (++[Left (toPlot p)])++-- | Add a plot against the right axis tof the `LayoutLR` being constructed.+plotRight :: (ToPlot p) => EC (LayoutLR x y1 y2) (p x y2) -> EC (LayoutLR x y1 y2) ()+plotRight pm = do+  p <- pm+  layoutlr_plots %= (++[Right (toPlot p)])++-- | Pop and return the next color from the state+takeColor :: EC l (AlphaColour Double)+takeColor = liftCState $ do+  (c,cs) <- fromInfiniteList `fmap` use colors+  colors .= cs+  return c++-- | Pop and return the next shape from the state+takeShape :: EC l PointShape+takeShape = liftCState $ do+  (c,cs) <- fromInfiniteList `fmap` use shapes+  shapes .= cs+  return c++fromInfiniteList :: [a] -> (a, [a])+fromInfiniteList []     = error "fromInfiniteList (takeColor or takeShape): empty list"+fromInfiniteList (x:xs) = (x, xs)
− Graphics/Rendering/Chart/Types.hs 
@@ -1,327 +0,0 @@--------------------------------------------------------------------------------- |--- 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--hollowCircles ::-     Double -- ^ radius of circle-  -> Double -- ^ thickness of line-  -> Double -- ^ red component of colour-  -> Double -- ^ green component of colour-  -> Double -- ^ blue component of colour-  -> CairoPointStyle-hollowCircles radius w r g b = 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--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-  -> 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-               let intToAngle n = if isrot-                                  then fromIntegral n * 2*pi / fromIntegral sides-                                  else (0.5 + fromIntegral n)*2*pi/fromIntegral sides-                   angles = map intToAngle [0 .. sides-1]-                   (p:ps) = map (\a -> Point (x + radius * sin a) (y + radius * cos a)) angles-               moveTo p-               mapM_ lineTo (ps++[p])-	       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-  -> CairoPointStyle-filledPolygon radius sides isrot r g b = CairoPointStyle rf-  where rf (Point x y) =-            do C.setSourceRGB r g b-               C.newPath-               let intToAngle n = if isrot-                                  then fromIntegral n * 2*pi / fromIntegral sides-                                  else (0.5 + fromIntegral n)*2*pi/fromIntegral sides-                   angles = map intToAngle [0 .. sides-1]-                   (p:ps) = map (\a -> Point (x + radius * sin a) (y + radius * cos a)) angles-               moveTo p-               mapM_ lineTo (ps++[p])-	       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-  -> 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--exes ::-     Double -- ^ radius of circle-  -> Double -- ^ thickness of line-  -> Double -- ^ red component of colour-  -> Double -- ^ green component of colour-  -> Double -- ^ blue component of colour-  -> CairoPointStyle-exes radius w r g b = 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--stars ::-     Double -- ^ radius of circle-  -> Double -- ^ thickness of line-  -> Double -- ^ red component of colour-  -> Double -- ^ green component of colour-  -> Double -- ^ blue component of colour-  -> CairoPointStyle-stars radius w r g b = 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--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)
+ Graphics/Rendering/Chart/Utils.hs view
@@ -0,0 +1,24 @@+-- | Non chart specific utility functions.+module Graphics.Rendering.Chart.Utils(+    isValidNumber,+    log10,+    maybeM,+    whenJust,+  ) where++-- | Checks if the given value is and actual numeric value and not+--   a concept like NaN or infinity.+isValidNumber :: (RealFloat a) => a -> Bool+isValidNumber v = not (isNaN v) && not (isInfinite v)++-- | Shorthand for the decimal logarithm+log10 :: (Floating a) => a -> a+log10 = logBase 10++-- | Version of 'Prelude.maybe' that returns a monadic value.+maybeM :: (Monad m) => b -> (a -> m b) -> Maybe a -> m b+maybeM v = maybe (return v)++-- | Specialization to ()+whenJust :: (Monad m) => Maybe a -> (a -> m ()) -> m ()+whenJust m f = maybeM () f m
+ Numeric/Histogram.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE PatternGuards #-}++module Numeric.Histogram ( Range+                         , binBounds+                         , histValues+                         , histWeightedValues+                         , histWithBins+                         ) where++import qualified Data.Vector as V+import qualified Data.Vector.Mutable as MV+import Control.Monad.ST++type Range a = (a,a)++-- | 'binBounds a b n' generates bounds for 'n' bins spaced linearly between+-- 'a' and 'b'+--+-- Examples:+--+-- >>> binBounds 0 3 4+-- [(0.0,0.75),(0.75,1.5),(1.5,2.25),(2.25,3.0)]+binBounds :: RealFrac a => a -> a -> Int -> [Range a]+binBounds a b n = map (\i->(lbound i, lbound (i+1))) [0..n-1]+        where lbound i = a + (b-a) * realToFrac i / realToFrac n++-- | 'histValues a b n vs' returns the bins for the histogram of+-- 'vs' on the range from 'a' to 'b' with 'n' bins+histValues :: RealFrac a => a -> a -> Int -> [a] -> V.Vector (Range a, Int)+histValues a b n = histWithBins (V.fromList $ binBounds a b n) . zip (repeat 1)++-- | 'histValues a b n vs' returns the bins for the weighted histogram of+-- 'vs' on the range from 'a' to 'b' with 'n' bins+histWeightedValues :: RealFrac a => a -> a -> Int -> [(Double,a)] -> V.Vector (Range a, Double)+histWeightedValues a b n = histWithBins (V.fromList $ binBounds a b n)++-- | 'histWithBins bins xs' is the histogram of weighted values 'xs' with 'bins'+--+-- Examples:+--+-- >>> :{+-- histWithBins+--     (V.fromList [(0.0, 0.75), (0.75, 1.5), (1.5, 2.25), (2.25, 3.0)])+--     [(1, 0), (1, 0), (1, 1), (1, 2), (1, 2), (1, 2), (1, 3)]+-- :}+-- [((0.0,0.75),2),((0.75,1.5),1),((1.5,2.25),3),((2.25,3.0),1)]+histWithBins :: (Num w, RealFrac a) => V.Vector (Range a) -> [(w, a)] -> V.Vector (Range a, w)+histWithBins bins xs =+    let n = V.length bins+        testBin :: RealFrac a => a -> (Int, Range a) -> Bool+        testBin x (i, (a,b)) =+            if i == n - 1+                then x >= a && x <= b+                else x >= a && x < b++        f :: (RealFrac a, Num w)+          => V.Vector (Range a) -> MV.STVector s w -> (w, a)+          -> ST s ()+        f bins1 bs (w,x) =+            case V.dropWhile (not . testBin x) $ V.indexed bins1 of+                v | V.null v  -> return ()+                v | (idx,_) <- V.head v  -> do+                    m <- MV.read bs idx+                    MV.write bs idx $! m+w++        counts = runST $ do b <- MV.replicate n 0+                            mapM_ (f bins b) xs+                            V.freeze b+    in V.zip bins counts
− tests/Prices.hs 
@@ -1,236 +0,0 @@-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)-    ]
− tests/test.hs 
@@ -1,212 +0,0 @@-import qualified Graphics.Rendering.Cairo as C-import Graphics.Rendering.Chart-import Graphics.Rendering.Chart.Simple-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{axis_title="horizontal"}),-	layout1_vertical_axes=linkedAxes' (autoScaledLogAxis defaultAxis{axis_title="vertical"}),-	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-------------------------------------------------------------------------        --- Test the Simple interface--test6 :: OutputType -> IO Layout1-test6 otype = return pp{layout1_title="Graphics.Rendering.Chart.Simple example"}-  where-    pp = plot xs sin "sin"-                 cos "cos" "o"-                 (sin.sin.cos) "sin.sin.cos" "."-                 (/3) "- "-                 (const 0.5)-                 [0.1,0.7,0.5::Double] "+"-    xs = [0,0.3..3] :: [Double]-----------------------------------------------------------------------        -allTests =-     [ ("test1",test1)-     , ("test2",test2)-     , ("test3",test3)-     , ("test4",test4)-     , ("test5",test5)-     , ("test6",test6)-     ]--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 ++ ".ps")-renderToPDF (n,t) = t PDF >>= \l -> renderableToPDFFile (toRenderable l) 640 480 (n ++ ".pdf")