packages feed

Chart 0.11 → 1.9.5

raw patch · 44 files changed

Files

Chart.cabal view
@@ -1,39 +1,78 @@ Name: Chart-Version: 0.11+Version: 1.9.5 License: BSD3 License-file: LICENSE-Copyright: Tim Docker, 2006-2009+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.6+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, time, mtl, array-  else-    Build-depends: base < 3-  Build-depends: gtk >= 0.9.11, cairo >= 0.9.11, time, mtl, array, data-accessor == 0.2.*, data-accessor-template >= 0.2.1.1 && < 0.3, colour >= 2.2.1 +  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.Legend,+        Graphics.Rendering.Chart.Grid,         Graphics.Rendering.Chart.Plot,-        Graphics.Rendering.Chart.Pie,-        Graphics.Rendering.Chart.Simple,-        Graphics.Rendering.Chart.Grid-+        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,51 +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, there are two kinds of 'Renderable' for displaying charts:+-- 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'. -----     * a standard two axes chart can be is created by applying---      'toRenderable' to a value of type 'Graphics.Rendering.Chart.Layout.Layout1'+-- Currently, there are three types of charts: -----     *  a pie chart can be is created by applying---      'toRenderable' to a value of type 'Graphics.Rendering.Chart.Pie.PieLayout'+--     * 'Layout' is a standard XY chart+-- +--     * 'LayoutLR' is an XY chart with independent left+--       and right axes ----- Multiple Renderables can be composed using the "Graphics.Rendering.Chart.Grid" module.+--     *  'PieLayout' is a pie chart ----- Many of the record structure involved in the API have a large--- number of fields For each record type X, there is generally a--- default value called defaultX with sensibly initialised fields - eg--- 'Layout1' has 'defaultLayout1' etc.+-- '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. ----- For a simpler though less flexible API, see "Graphics.Rendering.Chart.Simple".+-- 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( -    module Graphics.Rendering.Chart.Types,+    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.Pie,+    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.Pie+import Graphics.Rendering.Chart.Backend.Types
Graphics/Rendering/Chart/Axis.hs view
@@ -6,613 +6,19 @@ -- -- Code to calculate and render axes. ----- Note that template haskell is used to derive accessor functions--- (see 'Data.Accessor') for each field of the following data types:------     * 'AxisData'------     * 'Axis'------     * 'AxisStyle'------     * 'LinearAxisParams'------     * 'LogAxisParams'------ 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 :: Data.Accessor.Accessor D F--- @--- -{-# OPTIONS_GHC -XTemplateHaskell #-}- module Graphics.Rendering.Chart.Axis(-    AxisData(..),-    AxisT(..),-    LinearAxisParams(..),-    LogAxisParams(..),-    AxisStyle(..),-    PlotValue(..),-    LogValue(..),-    PlotIndex(..),-    AxisFn,--    defaultAxisLineStyle, -    defaultLinearAxis,-    defaultLogAxis,-    defaultAxisStyle,-    autoScaledAxis,-    autoScaledLogAxis,-    timeAxis,-    autoTimeAxis,-    days, months, years,-    autoIndexAxis,-    addIndexes,--    axisToRenderable,-    renderAxisGrid,-    axisOverhang,-    vmap,--    axisGridAtTicks,-    axisGridAtLabels,-    axisGridHide,-    axisTicksHide,-    axisLabelsHide,--    axis_viewport,-    axis_ticks,-    axis_labels,-    axis_grid,--    axis_line_style,-    axis_label_style,-    axis_grid_style,-    axis_label_gap,--    la_labelf,-    la_nLabels,-    la_nTicks,--    loga_labelf,-+    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 -import qualified Graphics.Rendering.Cairo as C-import Data.Time-import System.Locale (defaultTimeLocale)-import Control.Monad-import Data.List-import Data.Accessor.Template-import Data.Colour (opaque)-import Data.Colour.Names (black, lightgrey)--import Graphics.Rendering.Chart.Types-import Graphics.Rendering.Chart.Renderable---- | The basic data associated with an axis showing values of type x-data AxisData x = AxisData {--    -- | The axis_viewport_ function maps values into device-    -- cordinates.-    axis_viewport_ :: Range -> x -> Double,--    -- | The tick marks on the axis as pairs.-    -- The first element is the position on the axis-    -- (in viewport units) and the second element is the-    -- length of the tick in output coordinates.-    -- The tick starts on the axis, and positive number are drawn-    -- towards the plot area.-    axis_ticks_ :: [(x,Double)],--    -- | The labels on an axis as pairs. The first element -    -- is the position on the axis (in viewport units) and-    -- the second is the label text string.-    axis_labels_ :: [ (x, String) ],--    -- | 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 {-    axis_line_style_ :: CairoLineStyle,-    axis_label_style_ :: CairoFontStyle,-    axis_grid_style_ :: CairoLineStyle,--    -- | 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)--instance ToRenderable (AxisT x) where-  toRenderable = setPickFn nullPickFn.axisToRenderable--axisToRenderable :: AxisT x -> Renderable x-axisToRenderable at = Renderable {-     minsize=minsizeAxis at,-     render=renderAxis at-  }--axisGridHide :: AxisData x -> AxisData x-axisGridHide ad = ad{axis_grid_=[]}--axisGridAtTicks :: AxisData x -> AxisData x-axisGridAtTicks ad = ad{axis_grid_=map fst (axis_ticks_ ad)}--axisGridAtLabels :: AxisData x -> AxisData x-axisGridAtLabels ad = ad{axis_grid_=map fst (axis_labels_ ad)}--axisTicksHide :: AxisData x -> AxisData x-axisTicksHide ad = ad{axis_ticks_=[]}--axisLabelsHide :: AxisData x -> AxisData x-axisLabelsHide ad = ad{axis_labels_=[]}--minsizeAxis :: AxisT x -> CRender RectSize-minsizeAxis (AxisT at as rev ad) = do-    let labels = map snd (axis_labels_ ad)-    labelSizes <- preserveCState $ do-        setFontStyle (axis_label_style_ as)-        mapM textSize labels-    let (lw,lh) = foldl maxsz (0,0) labelSizes-    let ag = axis_label_gap_ as-    let tsize = maximum ([0] ++ [ max 0 (-l) | (v,l) <- axis_ticks_ ad ])-    let sz = case at of-		     E_Top    -> (lw,max (addIfNZ lh ag) tsize)-		     E_Bottom -> (lw,max (addIfNZ lh ag) tsize)-		     E_Left   -> (max (addIfNZ lw ag) tsize, lh)-		     E_Right  -> (max (addIfNZ lw ag) tsize, lh)-    return sz--  where-    maxsz (w1,h1) (w2,h2) = (max w1 w2, max h1 h2)-    addIfNZ a b | a == 0 = 0-                | otherwise = a+b----- | Calculate the amount by which the labels extend beyond--- the ends of the axis-axisOverhang :: Ord x => AxisT x -> CRender (Double,Double)-axisOverhang (AxisT at as rev ad) = do-    let labels = map snd (sort (axis_labels_ ad))-    labelSizes <- preserveCState $ do-        setFontStyle (axis_label_style_ as)-        mapM textSize 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 -> CRender (PickFn x)-renderAxis at@(AxisT et as rev ad) sz = do-   let ls = axis_line_style_ as-   preserveCState $ do-       setLineStyle ls{line_cap_=C.LineCapSquare}-       strokeLines [Point sx sy,Point ex ey]-   preserveCState $ do-       setLineStyle ls{line_cap_=C.LineCapButt}-       mapM_ drawTick (axis_ticks_ ad)-   preserveCState $ do-       setFontStyle (axis_label_style_ as)-       mapM_ drawLabel (axis_labels_ ad)-   return nullPickFn- where-   (sx,sy,ex,ey,tp,axisPoint) = axisMapping at sz--   drawTick (value,length) = -       let t1 = axisPoint value-	   t2 = t1 `pvadd` (vscale length tp)-       in strokeLines [t1,t2]--   (hta,vta,lp) = -       let g = axis_label_gap_ as-       in case et of-		  E_Top    -> (HTA_Centre,VTA_Bottom,(Vector 0 (-g)))-		  E_Bottom -> (HTA_Centre,VTA_Top,(Vector 0 g))-		  E_Left   -> (HTA_Right,VTA_Centre,(Vector (-g) 0))-		  E_Right  -> (HTA_Left,VTA_Centre,(Vector g 0))--   drawLabel (value,s) = do-       drawText hta vta (axisPoint value `pvadd` lp) s--axisMapping :: AxisT z -> RectSize -> (Double,Double,Double,Double,Vector,z->Point)-axisMapping (AxisT et as rev ad) (x2,y2) = case et of-    E_Top    -> (x1,y2,x2,y2, (Vector 0 1),    mapx (x1,x2) y2) -    E_Bottom -> (x1,y1,x2,y1, (Vector 0 (-1)), mapx (x1,x2) y1)-    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-    (x1,y1) = (0,0)--    mapx xr y x = Point (axis_viewport_ ad (reverse xr) x) y-    mapy (yr0,yr1) x y = Point x (axis_viewport_ ad (reverse (yr1,yr0)) y)-    reverse r@(r0,r1) = if rev then (r1,r0) else r--renderAxisGrid :: RectSize -> AxisT z -> CRender ()-renderAxisGrid sz@(w,h) at@(AxisT re as rev ad) = do-    preserveCState $ do-        setLineStyle (axis_grid_style_ as)-        mapM_ (drawGridLine re) (axis_grid_ ad)-  where-    (sx,sy,ex,ey,tp,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 strokeLines [Point v' 0,Point v' h]--    hline v = let v' = p_y (axisPoint v)-	      in strokeLines [Point 0 v',Point w v']----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')--makeAxis :: PlotValue x => (x -> String) -> ([x],[x],[x]) -> AxisData x-makeAxis labelf (labelvs, tickvs, gridvs) = AxisData {-    axis_viewport_=newViewport,-    axis_ticks_=newTicks,-    axis_grid_=gridvs,-    axis_labels_=newLabels-    }-  where-    newViewport = vmap (min',max')-    newTicks = [ (v,2) | v <- tickvs ] ++ [ (v,5) | v <- labelvs ] -    newLabels = [(v,labelf v) | v <- labelvs]-    min' = minimum labelvs-    max' = maximum labelvs--data GridMode = GridNone | GridAtMajor | GridAtMinor--data LinearAxisParams = LinearAxisParams {-    -- | The function used to show the axes labels-    la_labelf_ :: Double -> String,--    -- | The target number of labels to be shown-    la_nLabels_ :: Int,--    -- | The target number of ticks to be shown-    la_nTicks_ :: Int-}---defaultLinearAxis = LinearAxisParams {-    la_labelf_ = showD,-    la_nLabels_ = 5,-    la_nTicks_ = 50-}---- | Generate a linear axis automatically.--- The supplied axis is used as a template, with the viewport, ticks, labels--- and grid set appropriately for the data displayed against that axies.--- The resulting axis will only show a grid if the template has some grid--- values.-autoScaledAxis :: LinearAxisParams -> AxisFn Double-autoScaledAxis lap ps0 = makeAxis (la_labelf_ lap) (labelvs,tickvs,gridvs)-  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)-    labelvs = map fromRational $ steps (fromIntegral (la_nLabels_ lap)) r-    tickvs = map fromRational $ steps (fromIntegral (la_nTicks_ lap)) (minimum labelvs,maximum labelvs)-    gridvs = labelvs-    r = range ps--showD x = case reverse $ show x of-            '0':'.':r -> reverse r-            _ -> show x-    --log10 :: (Floating a) => a -> a-log10 = logBase 10--frac x | 0 <= b = (a,b)-       | otherwise = (a-1,b+1)- where-  (a,b) = properFraction x--{- - Rules: Do no subdivide between powers of 10 until all powers of 10-          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],[Rational])-logTicks (low,high) = (major,minor,major)- where-  ratio = high/low-  lower a l = let (i,r) = frac (log10 a) in-            (maximum (1:(filter (\x -> log10 (fromRational x) <= r) l)))*10^^i-  upper a l = let (i,r) = properFraction (log10 a) in-            (minimum (10:(filter (\x -> r <= log10 (fromRational x)) l)))*10^^i-  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 :: LogAxisParams -> AxisFn LogValue-autoScaledLogAxis lap ps0 = makeAxis labelf (wrap rlabelvs, wrap rtickvs, wrap rgridvs)-  where-    ps = filter (\(LogValue x) -> isValidNumber x && 0 < x) ps0-    (min, max) = (minimum ps,maximum ps)-    range [] = (3,30)-    range _  | min == max = (unLogValue min/3,unLogValue max*3)-             | otherwise = (unLogValue min,unLogValue max)-    (rlabelvs, rtickvs, rgridvs) = logTicks (range ps)-    wrap = map (LogValue . fromRational)-    unLogValue (LogValue x) = x-    labelf = loga_labelf_ lap---data LogAxisParams = LogAxisParams {-    -- | The function used to show the axes labels-    loga_labelf_ :: LogValue -> String-}--defaultLogAxis = LogAxisParams {-    loga_labelf_ = \(LogValue x) -> showD x-}--------------------------------------------------------------------------defaultAxisLineStyle = solidLine 1 $ opaque black-defaultGridLineStyle = dashedLine 1 [5,5] $ opaque lightgrey--defaultAxisStyle = AxisStyle {-    axis_line_style_ = defaultAxisLineStyle,-    axis_label_style_ = defaultFontStyle,-    axis_grid_style_ = defaultGridLineStyle,-    axis_label_gap_ = 10-}---------------------------------------------------------------------------- | Map a LocalTime value to a plot cordinate-doubleFromLocalTime :: LocalTime -> Double-doubleFromLocalTime lt = fromIntegral (toModifiedJulianDay (localDay lt)) -             + fromRational (timeOfDayToDayFraction (localTimeOfDay lt))---- | Map a plot cordinate to a LocalTime-localTimeFromDouble :: Double -> LocalTime-localTimeFromDouble v = -  LocalTime (ModifiedJulianDay i) (dayFractionToTimeOfDay (toRational d))- where-   (i,d) = properFraction v---- | TimeSeq is a (potentially infinite) set of times. When passes--- a reference time, the function returns a a pair of lists. The first--- contains all times in the set less than the reference time in--- decreasing order. The second contains all times in the set greater--- than or equal to the reference time, in increasing order.-type TimeSeq = LocalTime-> ([LocalTime],[LocalTime])--coverTS tseq min max = min' ++ enumerateTS tseq min max ++ max'-  where-    min' =  if elemTS min tseq then [] else take 1 (fst (tseq min))-    max' =  if elemTS max tseq then [] else take 1 (snd (tseq max))--enumerateTS tseq min max = reverse (takeWhile (>=min) ts1)  ++ takeWhile (<=max) ts2-  where-    (ts1,ts2) = tseq min--elemTS t tseq = case tseq t of-    (_,(t0:_)) | t == t0 -> True-    _                    -> False---- | How to display a time-type TimeLabelFn = LocalTime -> String---- | Create an 'AxisFn' to for a time axis. The first 'TimeSeq' sets the minor ticks,--- and the ultimate range will aligned to it's elements. The second 'TimeSeq' sets--- the labels and grid. The 'TimeLabelFn' is used to format LocalTimes for labels.--- The values to be plotted against this axis can be created with 'doubleFromLocalTime'-timeAxis :: TimeSeq -> TimeSeq -> TimeLabelFn -> AxisFn LocalTime-timeAxis tseq lseq labelf pts = AxisData {-    axis_viewport_=vmap(min', max'),-    axis_ticks_=[ (t,2) | t <- times] ++ [ (t,5) | t <- ltimes, visible t],-    axis_labels_=[ (t,l) | (t,l) <- labels, visible t],-    axis_grid_=[ t | t <- ltimes, visible t]-    }-  where-    (min,max) = case pts of-		[] -> (refLocalTime,refLocalTime)-		ps -> (minimum ps, maximum ps)-    refLocalTime = LocalTime (ModifiedJulianDay 0) midnight-    times = coverTS tseq min max-    ltimes = coverTS lseq min max-    min' = minimum times-    max' = maximum times-    visible t = min' <= t && t <= max'-    labels = [ (avg m1 m2, labelf m1) | (m1,m2) <- zip ltimes (tail ltimes) ]-    avg m1 m2 = localTimeFromDouble $ m1' + (m2' - m1')/2-     where-      m1' = doubleFromLocalTime m1-      m2' = doubleFromLocalTime m2---- | 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,d) = toGregorian $ localDay t in fromGregorian y m 1-        t1 = if toTime t0 < t then t0 else (rev t0)-        rev = addGregorianMonthsClip (-1)-        fwd = addGregorianMonthsClip 1-        toTime d = LocalTime d midnight---- | A 'TimeSeq' for calendar years-years :: TimeSeq-years t = (map toTime $ iterate rev t1, map toTime $ tail (iterate fwd t1))-  where t0 = let (y,m,d) = toGregorian $ localDay t in y-        t1 = if toTime t0 < t then t0 else (rev t0)-        rev = pred-        fwd = succ-        toTime y = LocalTime (fromGregorian y 1 1) midnight---- | Automatically choose a suitable time axis, based upon the time range of data.--- The values to be plotted against this axis can be created with 'doubleFromLocalTime'-autoTimeAxis :: AxisFn LocalTime-autoTimeAxis [] = timeAxis days days (formatTime defaultTimeLocale "%d-%b")  []-autoTimeAxis pts = -    if tdiff < 15-    then  timeAxis days days (ft "%d-%b")  pts-    else if tdiff < 90-         then timeAxis days months (ft "%b-%y") pts-         else if tdiff < 450-              then timeAxis months months (ft "%b-%y") pts-              else if tdiff < 1800-                   then timeAxis months years (ft "%Y") pts-                   else timeAxis years years (ft "%Y") pts-  where-    tdiff = diffDays (localDay t1) (localDay t0)-    t1 = maximum pts-    t0 = minimum pts-    ft = formatTime defaultTimeLocale---------------------------------------------------------------------------------class Ord a => PlotValue a where-    toValue :: a -> Double-    autoAxis ::AxisFn a--instance PlotValue Double where-    toValue = id-    autoAxis = autoScaledAxis defaultLinearAxis--newtype LogValue = LogValue Double-                    deriving (Eq, Ord)--instance Show LogValue where-    show (LogValue x) = show x--instance PlotValue LogValue where-    toValue (LogValue x) = log x-    autoAxis = autoScaledLogAxis defaultLogAxis--instance PlotValue LocalTime where-    toValue = doubleFromLocalTime-    autoAxis = autoTimeAxis---------------------------------------------------------------------------- | 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)--instance PlotValue PlotIndex where-    toValue (PlotIndex i)= fromIntegral i-    autoAxis = autoIndexAxis []---- | Create an axis for values indexed by position. The --- list of strings are the labels to be used.-autoIndexAxis :: [String] -> [PlotIndex] -> AxisData PlotIndex-autoIndexAxis labels vs = AxisData {-    axis_viewport_= vport,-    axis_ticks_ = [],-    axis_labels_ =  filter (\(i,l) -> i >= imin && i <= imax) (addIndexes labels),-    axis_grid_ = []-    }-  where-    vport r (PlotIndex i) = vmap (fi (plotindex_i imin) - 0.5,-                                  fi (plotindex_i imax) + 0.5) r (fi i)-    imin = minimum vs-    imax = maximum vs-    fi = fromIntegral :: Int -> Double----- | Augment a list of values with index numbers for plotting-addIndexes :: [a] -> [(PlotIndex,a)]-addIndexes as = map (\(i,a) -> (PlotIndex i,a))  (zip [0..] as)----- | A linear mapping of points in one range to another-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)--------------------------------------------------------------------------- Template haskell to derive an instance of Data.Accessor.Accessor for each field-$( deriveAccessors ''AxisData )-$( deriveAccessors ''AxisStyle )-$( deriveAccessors ''LinearAxisParams )-$( deriveAccessors ''LogAxisParams )-+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
@@ -1,5 +1,14 @@+-----------------------------------------------------------------------------+-- |+-- 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,+    Grid, Span, SpaceWeight,     tval, tspan,     empty, nullt,     (.|.), (./.),@@ -8,119 +17,169 @@     overlay,     width, height,     gridToRenderable,-    weights+    weights,+    aboveWide,+    wideAbove,+    tallBeside,+    besideTall,+    fullOverlayUnder,+    fullOverlayOver ) where -import Data.List import Data.Array--- import qualified Data.Map as Map import Control.Monad-import Numeric import Graphics.Rendering.Chart.Renderable-import Graphics.Rendering.Chart.Types---import Graphics.Rendering.Chart.Gtk-import qualified Graphics.Rendering.Cairo as C+import Graphics.Rendering.Chart.Geometry hiding (x0, y0)+import Graphics.Rendering.Chart.Drawing -type Span = (Int,Int)-type Size = (Int,Int)+type Span        = (Int,Int)+type Size        = (Int,Int)++-- | When more space is available for an item than the total width of items,+--   extra added space is proportional to 'space weight'. type SpaceWeight = (Double,Double) -type Cell a = (a,Span,SpaceWeight)+type Cell a      = (a,Span,SpaceWeight) -data Grid a = Value (a,Span,SpaceWeight)-             | Above (Grid a) (Grid a) Size -             | Beside (Grid a) (Grid a) Size-             | Overlay (Grid a) (Grid a) Size-	     | Empty-	     | Null+-- | 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,h)) = w-width (Above _ _ (w,h)) = w-width (Overlay _ _ (w,h)) = w+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 _ _ (w,h)) = h-height (Above _ _ (w,h)) = h-height (Overlay _ _ (w,h)) = h+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 span = Value (a,span,(1,1))+tspan a spn = Value (a,spn,(1,1)) -empty, nullt :: Grid a+-- | 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+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))+beside t1 t2  = Beside t1 t2 size+  where size  = (width t1 + width t2, max (height t1) (height t2))  aboveN, besideN :: [Grid a] -> Grid a-aboveN = foldl above nullt+aboveN  = foldl above nullt besideN = foldl beside nullt +-- | One grid over the other. The first argument is shallow, the second is deep.+overlay :: Grid a -> Grid a -> Grid a overlay Null t = t overlay t Null = t-overlay t1 t2 = Overlay t1 t2 size-  where size = (max (width t1) (width t2), max (height t1) (height t2))+overlay t1 t2  = Overlay t1 t2 size+  where size   = (max (width t1) (width t2), max (height t1) (height t2)) +-- | A synonym for 'beside'.+(.|.) :: Grid a -> Grid a -> Grid a (.|.) = beside++-- | A synonym for 'above'.+(./.) :: Grid a -> Grid a -> Grid a (./.) = above +-- | Sets the space weight of *every* cell of the grid to given value. weights :: SpaceWeight -> Grid a -> Grid a-weights sw Null = Null-weights sw Empty = Empty-weights sw (Value (v,sp,_)) = Value (v,sp,sw)-weights sw (Above t1 t2 sz) = Above (weights sw t1) (weights sw t2) sz-weights sw (Beside t1 t2 sz) = Beside (weights sw t1) (weights sw t2) sz+weights _  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,span,ew)) = Value (f a,span,ew)-    fmap f (Above t1 t2 s) = Above (fmap f t1) (fmap f t2) s-    fmap f (Beside t1 t2 s) = Beside (fmap f t1) (fmap f t2) s-    fmap f (Overlay t1 t2 s) = Overlay (fmap f t1) (fmap f t2) s-    fmap f Empty = Empty-    fmap f Null = Null+    fmap f (Value (a,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,span,ew)) = do -    b <- f a-    return (Value (b,span,ew))-mapGridM f (Above t1 t2 s) = do-    t1' <- mapGridM f t1-    t2' <- mapGridM f t2-    return (Above t1' t2' s)-mapGridM f (Beside t1 t2 s) = do-    t1' <- mapGridM f t1-    t2' <- mapGridM f t2-    return (Beside t1' t2' s)-mapGridM f (Overlay t1 t2 s) = do-    t1' <- mapGridM f t1-    t2' <- mapGridM f t2-    return (Overlay t1' t2' s)-mapGridM _ Empty = return Empty-mapGridM _ Null = return Null+mapGridM f (Value (a,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)]@@ -132,21 +191,21 @@ type FlatEl a = ((Int,Int),Cell a)  flatten2 :: (Int,Int) -> Grid a -> [FlatEl a] -> [FlatEl a]-flatten2 i Empty els = els-flatten2 i Null els = els+flatten2 _ Empty        els = els+flatten2 _ Null         els = els flatten2 i (Value cell) els = (i,cell):els -flatten2 i@(x,y) (Above t1 t2 size) els = (f1.f2) els+flatten2 i@(x,y) (Above t1 t2 _) els   = (f1.f2) els   where     f1 = flatten2 i t1     f2 = flatten2 (x,y + height t1) t2 -flatten2 i@(x,y) (Beside t1 t2 size) els = (f1.f2) els+flatten2 i@(x,y) (Beside t1 t2 _) els  = (f1.f2) els   where     f1 = flatten2 i t1     f2 = flatten2 (x + width t1, y) t2 -flatten2 i@(x,y) (Overlay t1 t2 size) els = (f1.f2) els+flatten2 i (Overlay t1 t2 _) els = (f1.f2) els   where     f1 = flatten2 i t1     f2 = flatten2 i t2@@ -154,91 +213,108 @@ 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 (\cell -> f i cell) r vs  +    f' (i,vs) r = foldr (f i) r vs  ---------------------------------------------------------------------- type DArray = Array Int Double -gridToRenderable :: Grid (Renderable a) -> Renderable a-gridToRenderable t = Renderable minsizef renderf+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-    getSizes :: CRender (DArray, DArray, DArray, DArray)-    getSizes = do-        szs <- mapGridM minsize t :: CRender (Grid RectSize)-        let szs' = flatten szs-        let widths = accumArray max 0 (0, width t - 1) (foldT (ef wf) [] szs')-        let heights  = accumArray max 0 (0, height t - 1) (foldT (ef hf) [] szs')-        let xweights = accumArray max 0 (0, width t - 1) (foldT (ef xwf) [] szs')-        let yweights = accumArray max 0 (0, height t - 1) (foldT (ef ywf) [] szs')-        return (widths,heights,xweights,yweights)+      wf  (x,_) (w,_) _      = (x,w)+      hf  (_,y) (_,h) _      = (y,h)+      xwf (x,_) _     (xw,_) = (x,xw)+      ywf (_,y) _     (_,yw) = (y,yw) -    wf  (x,y) (w,h) (ww,wh) = (x,w)-    hf  (x,y) (w,h) (ww,wh) = (y,h)-    xwf (x,y) (w,h) (xw,yw) = (x,xw)-    ywf (x,y) (w,h) (xw,yw) = (y,yw)+      ef f ds loc (size,spn,ew) r | ds spn == 1 = f loc size ew:r+                                  | otherwise    = r -    ef f loc (size,span,ew) | span == (1,1) = (f loc size ew:)-                            | otherwise = id-                                        +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, xweights, yweights) <- getSizes+        (widths, heights, _, _) <- getSizes gt         return (sum (elems widths), sum (elems heights))      renderf (w,h)  = do-        (widths, heights, xweights, yweights) <- getSizes-        let widths' = addExtraSpace w widths xweights+        (widths, heights, xweights, yweights) <- getSizes gt+        let widths'  = addExtraSpace w widths xweights         let heights' = addExtraSpace h heights yweights-        let csizes = (ctotal widths',ctotal heights')-        rf1 csizes (0,0) t+        let borders  = (ctotal widths',ctotal heights')+        rf1 borders (0,0) gt -    rf1 csizes loc@(i,j) t = case t of-        Null -> return nullPickFn+    -- (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,span,_)) -> do-            let (Rect p0 p1) = mkRect csizes loc span-            p0'@(Point x0 y0) <- alignc p0-            p1'@(Point x1 y1) <- alignc p1-            preserveCState $ do-                c $ C.translate x0 y0-                render r (x1-x0,y1-y0)+        (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 csizes (i,j) t1-             pf2 <- rf1 csizes (i,j+height t1) t2-             let pf p@(Point x y) = if y < (snd csizes ! (j + height t1)) then pf1 p-                                                                          else pf2 p+             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 csizes (i,j) t1-             pf2 <- rf1 csizes (i+width t1,j) t2-             let pf p@(Point x y) = if x < (fst csizes ! (i + width t1)) then pf1 p-                                                                         else pf2 p+             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 csizes (i,j) t2-             pf1 <- rf1 csizes (i,j) t1+             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+        x1 = cwidths  ! x         y1 = cheights ! y-        x2 = cwidths ! min (x+w) (snd $ bounds cwidths) +        x2 = cwidths  ! min (x+w) (snd $ bounds cwidths)         y2 = cheights ! min (y+h) (snd $ bounds cheights)-        mx = fst (bounds cwidths)-        my = fst (bounds cheights)+        -- 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 = +    addExtraSpace size sizes weights' =         if totalws == 0 then sizes                         else listArray (bounds sizes) sizes'       where-        ws = elems weights+        ws      = elems weights'         totalws = sum ws-        extra = size - sum (elems sizes)-        extras =  map (*(extra/totalws)) ws-        sizes' = zipWith (+) extras (elems sizes)+        extra   = size - sum (elems sizes)+        extras  = map (*(extra/totalws)) ws+        sizes'  = zipWith (+) extras (elems sizes) +    -- [1,2,3] -> [0,1,3,6].     ctotal :: DArray -> DArray-    ctotal a = listArray (let (i,j) = bounds a in (i,j+1)) (scanl (+) 0 (elems a))+    ctotal a = listArray (let (i,j) = bounds a in (i,j+1))+                         (scanl (+) 0 (elems a))
− Graphics/Rendering/Chart/Gtk.hs 
@@ -1,50 +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.UI.Gtk.Gdk.Events as G-import qualified Graphics.Rendering.Cairo as C-import Graphics.Rendering.Chart-import Graphics.Rendering.Chart.Renderable-import Graphics.Rendering.Chart.Types-import Data.List (isPrefixOf)---- do action m for any keypress (except meta keys)-anyKey :: (Monad m) => m a -> G.Event -> m Bool-anyKey m (G.Key {G.eventKeyName=key})-    | any (`isPrefixOf` key) ignores = return True-    | otherwise                      = m >> return True-  where ignores = ["Shift","Control","Alt",-                   "Super","Meta","Hyper"]--renderableToWindow :: Renderable a -> 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 $ anyKey (G.widgetDestroy window)-    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 a -> G.DrawingArea  -> IO Bool-updateCanvas chart canvas = do-    win <- G.widgetGetDrawWindow canvas-    (width, height) <- G.widgetGetSize canvas-    let sz = (fromIntegral width,fromIntegral height)-    G.renderWithDrawable win $ runCRender (render chart sz) bitmapEnv-    return True
Graphics/Rendering/Chart/Layout.hs view
@@ -1,344 +1,855 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Graphics.Rendering.Chart.Layout--- Copyright   :  (c) Tim Docker 2006--- 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 'Data.Accessor') for each field of the following data types:------     * 'Layout1'------     * 'LayoutAxis'------ 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 :: Data.Accessor.Accessor D F--- @-----{-# OPTIONS_GHC -XTemplateHaskell #-}--module Graphics.Rendering.Chart.Layout(-    Layout1(..),-    LayoutAxis(..),-    MAxisFn,--    defaultLayout1,-    linkAxes,-    independentAxes,--    updateAllAxesStyles,-    setLayout1Foreground,--    defaultLayoutAxis,-    laxis_title_style,-    laxis_title,-    laxis_style,-    laxis_visible,-    laxis_generate,-    laxis_override,-    laxis_reverse,--    layout1_background,-    layout1_plot_background,-    layout1_title,-    layout1_title_style,-    layout1_left_axis,-    layout1_right_axis,-    layout1_top_axis,-    layout1_bottom_axis,-    layout1_yaxes_control,-    layout1_margin,-    layout1_plots,-    layout1_legend,-    layout1_grid_last-  ) where--import qualified Graphics.Rendering.Cairo as C--import Graphics.Rendering.Chart.Axis-import Graphics.Rendering.Chart.Types-import Graphics.Rendering.Chart.Plot-import Graphics.Rendering.Chart.Legend-import Graphics.Rendering.Chart.Renderable-import Graphics.Rendering.Chart.Grid-import Control.Monad-import Control.Monad.Reader (local)-import Data.Accessor.Template-import Data.Accessor-import Data.Colour-import Data.Colour.Names (white)---- | A @MAxisFn@ is a function that generates an (optional) axis--- given the points plotted against that axis.-type MAxisFn t = [t] -> Maybe (AxisData t)--data LayoutAxis x = LayoutAxis {-   laxis_title_style_ :: CairoFontStyle,-   laxis_title_ :: String,-   laxis_style_ :: AxisStyle,--   -- | function that determines whether an axis should be visible,-   -- based upon the points plotted on this axis. The default value-   -- is 'not.null'-   laxis_visible_ :: [x] -> Bool,--   -- | function that generates the axis data, based upon the-   -- points plotted. The default value is 'autoAxis'.-   laxis_generate_ :: AxisFn x,--   -- | function that can be used to override the generated axis data.-   -- The default value is 'id'.-   laxis_override_ :: AxisData x -> AxisData x,--   -- | True if left to right (bottom to top) is to show descending values-   laxis_reverse_ :: Bool--}---- | A Layout1 value is a single plot area, with optional: axes on--- each of the 4 sides; title at the top; legend at the bottom. It's--- parameterised by the types of values to be plotted on the horizonal--- and vertical axes.-data Layout1 x y = Layout1 {--    layout1_background_ :: CairoFillStyle,-    layout1_plot_background_ :: Maybe CairoFillStyle,--    layout1_title_ :: String,-    layout1_title_style_ :: CairoFontStyle,--    layout1_bottom_axis_ :: LayoutAxis x,-    layout1_top_axis_ :: LayoutAxis x,-    layout1_left_axis_ :: LayoutAxis y,-    layout1_right_axis_ :: LayoutAxis y,--    -- | function to map points from the left/right plot-    -- to the left/right axes. The default value is 'id'-    layout1_yaxes_control_ :: ([y],[y]) -> ([y],[y]),--    layout1_margin_ :: Double,-    layout1_plots_ :: [Either (Plot x y) (Plot x y)],-    layout1_legend_ :: Maybe(LegendStyle),--    -- | True if the grid is to be rendered on top of the Plots-    layout1_grid_last_ :: Bool-}--data Layout1Pick x y = L1P_Legend String-                     | L1P_PlotArea x y y-                     | L1P_BottomAxis x-                     | L1P_TopAxis x-                     | L1P_LeftAxis y-                     | L1P_RightAxis y--instance (Ord x, Ord y) => ToRenderable (Layout1 x y) where-    toRenderable = setPickFn nullPickFn.layout1ToRenderable--layout1ToRenderable :: (Ord x, Ord y) => Layout1 x y -> Renderable (Layout1Pick x y)-layout1ToRenderable l =-   fillBackground (layout1_background_ l) (-       gridToRenderable $ aboveN [-          tval $ addMargins (lm/2,0,0,0) title,-          weights (1,1) $ tval $ addMargins (lm,lm,lm,lm) plotArea,-          tval $ legends-       ] )-  where-    title = label (layout1_title_style_ l) HTA_Centre VTA_Centre (layout1_title_ l)--    plotArea = gridToRenderable (layer2 `overlay` layer1)--    layer1 = aboveN [-         besideN [er,     er,    er   ],-         besideN [er,     er,    er   ],-         besideN [er,     er,    weights (1,1) plots ]-         ]--    layer2 = aboveN [-         besideN [er,     er,    ttitle, er,    er       ],-         besideN [er,     tl,    taxis,  tr,    er       ],-         besideN [ltitle, laxis, er,     raxis, rtitle   ],-         besideN [er,     bl,    baxis,  br,    er       ],-         besideN [er,     er,    btitle, er,    er       ]-         ]--    ttitle = atitle HTA_Centre VTA_Bottom  0 layout1_top_axis_-    btitle = atitle HTA_Centre VTA_Top     0 layout1_bottom_axis_-    ltitle = atitle HTA_Right  VTA_Centre 90 layout1_left_axis_-    rtitle = atitle HTA_Left   VTA_Centre 90 layout1_right_axis_--    er = tval $ emptyRenderable--    atitle ha va rot af = if ttext == "" then er else tval $ rlabel tstyle ha va rot ttext-      where-        tstyle = laxis_title_style_ (af l)-        ttext = laxis_title_ (af l)--    plots = tval $ mfill (layout1_plot_background_ l) $ plotsToRenderable l-      where-        mfill Nothing = id-        mfill (Just fs) = fillBackground fs--    (ba,la,ta,ra) = getAxes l-    baxis = tval $ maybe emptyRenderable (mapPickFn L1P_BottomAxis . axisToRenderable) ba-    taxis = tval $ maybe emptyRenderable (mapPickFn L1P_TopAxis . axisToRenderable)   ta-    laxis = tval $ maybe emptyRenderable (mapPickFn L1P_LeftAxis . axisToRenderable)  la-    raxis = tval $ maybe emptyRenderable (mapPickFn L1P_RightAxis . axisToRenderable) ra--    tl = tval $ axesSpacer fst ta fst la-    bl = tval $ axesSpacer fst ba snd la-    tr = tval $ axesSpacer snd ta fst ra-    br = tval $ axesSpacer snd ba snd ra--    legends = gridToRenderable (besideN [ tval $ mkLegend lefts,-                                          weights (1,1) $ tval $ emptyRenderable,-                                          tval $ mkLegend rights ])-    lefts = concat [ plot_legend_ p | (Left p) <- (layout1_plots_ l) ] -    rights = concat [ plot_legend_ p | (Right p) <- (layout1_plots_ l) ] --    mkLegend vals = case (layout1_legend_ l) of-        Nothing -> emptyRenderable-        (Just ls) ->  case filter ((/="").fst) vals of-             [] -> emptyRenderable-	     lvs -> addMargins (0,lm,lm,lm)-                      (mapPickFn  L1P_Legend $ legendToRenderable (Legend True ls lvs))--    lm = layout1_margin_ l--plotsToRenderable :: Layout1 x y -> Renderable (Layout1Pick x y)-plotsToRenderable l = Renderable {-        minsize=return (0,0),-        render= renderPlots l-    }--renderPlots :: Layout1 x y -> RectSize -> CRender (PickFn (Layout1Pick x y))-renderPlots l sz@(w,h) = do-    when (not (layout1_grid_last_ l)) renderGrids-    preserveCState $ do-      -- render the plots-      setClipRegion (Point 0 0) (Point w h)-      mapM_ rPlot (layout1_plots_ l)-    when (layout1_grid_last_ l) renderGrids-    return nullPickFn--  where-    (bAxis,lAxis,tAxis,rAxis) = getAxes l--    rPlot (Left p) = rPlot1 bAxis lAxis p-    rPlot (Right p) = rPlot1 bAxis rAxis p--    rPlot1 (Just (AxisT _ xs xrev xaxis)) (Just (AxisT _ ys yrev yaxis)) p = -	let xrange = if xrev then (w, 0) else (0,w)-	    yrange  = if yrev then (0, h) else (h, 0)-	    pmfn (x,y) = Point (mapv xrange (axis_viewport_ xaxis xrange) x)-                               (mapv yrange (axis_viewport_ yaxis yrange) y)-            mapv (min,max) _ LMin = min-            mapv (min,max) _ LMax = max-            mapv _ f (LValue v) = f v-	in plot_render_ p pmfn-    rPlot1 _ _ _ = return ()--    renderGrids = do-      maybeM () (renderAxisGrid sz) tAxis-      maybeM () (renderAxisGrid sz) bAxis-      maybeM () (renderAxisGrid sz) lAxis-      maybeM () (renderAxisGrid sz) rAxis--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))--getAxes :: Layout1 x y -> (Maybe (AxisT x), Maybe (AxisT y), Maybe (AxisT x), Maybe (AxisT y))-getAxes l = (bAxis,lAxis,tAxis,rAxis)-  where -    (xvals0,xvals1,yvals0,yvals1) = allPlottedValues (layout1_plots_ l)-    xvals = xvals0 ++ xvals1-    (yvals0',yvals1') = layout1_yaxes_control_ l (yvals0,yvals1)--    bAxis = mkAxis E_Bottom (layout1_bottom_axis_ l) xvals-    tAxis = mkAxis E_Top    (layout1_top_axis_ l) xvals-    lAxis = mkAxis E_Left   (layout1_left_axis_ l) yvals0'-    rAxis = mkAxis E_Right  (layout1_right_axis_ l) yvals1'--    mkAxis t laxis vals = case laxis_visible_ laxis vals of-        False -> Nothing-        True -> Just (AxisT t style rev adata) -      where-        style = laxis_style_ laxis-        rev = laxis_reverse_ laxis-        adata = (laxis_override_ laxis) (laxis_generate_ laxis vals)--allPlottedValues :: [(Either (Plot x y) (Plot x' y'))] -> ( [x], [x'], [y], [y'] )-allPlottedValues plots = (xvals0,xvals1,yvals0,yvals1)-  where-    xvals0 = [ x | (Left p) <- plots, x <- fst $ plot_all_points_ p]-    yvals0 = [ y | (Left p) <- plots, y <- snd $ plot_all_points_ p]-    xvals1 = [ x | (Right p) <- plots, x <- fst $ plot_all_points_ p]-    yvals1 = [ y | (Right p) <- plots, y <- snd $ plot_all_points_ p]--defaultLayout1 :: (PlotValue x,PlotValue y) => Layout1 x y-defaultLayout1 = Layout1 {-    layout1_background_ = solidFillStyle $ opaque white,-    layout1_plot_background_ = Nothing,--    layout1_title_ = "",-    layout1_title_style_ = defaultFontStyle{font_size_=15, font_weight_=C.FontWeightBold},--    layout1_top_axis_ = defaultLayoutAxis {-                          laxis_visible_ = const False -                        },-    layout1_bottom_axis_ = defaultLayoutAxis,-    layout1_left_axis_ = defaultLayoutAxis,-    layout1_right_axis_ = defaultLayoutAxis,--    layout1_yaxes_control_ = id,--    layout1_margin_ = 10,-    layout1_plots_ = [],-    layout1_legend_ = Just defaultLegendStyle,-    layout1_grid_last_ = False-}--defaultLayoutAxis :: PlotValue t => LayoutAxis t-defaultLayoutAxis = LayoutAxis {-   laxis_title_style_ = defaultFontStyle{font_size_=10},-   laxis_title_ = "",-   laxis_style_ = defaultAxisStyle,-   laxis_visible_ = not.null,               -   laxis_generate_ = autoAxis,-   laxis_override_ = id,-   laxis_reverse_ = False-}--------------------------------------------------------------------------- Template haskell to derive an instance of Data.Accessor.Accessor for each field-$( deriveAccessors ''Layout1 )-$( deriveAccessors ''LayoutAxis )---- | Helper to update all axis styles on a Layout1 simultaneously-updateAllAxesStyles :: (AxisStyle -> AxisStyle) -> Layout1 x y -> Layout1 x y-updateAllAxesStyles uf = (layout1_top_axis .> laxis_style ^: uf) .-                         (layout1_bottom_axis .> laxis_style ^: uf) .-                         (layout1_left_axis .> laxis_style ^: uf) .-                         (layout1_right_axis .> laxis_style ^: uf)---- | Helper to set the forground color uniformly on a Layout1-setLayout1Foreground :: AlphaColour Double -> Layout1 x y -> Layout1 x y-setLayout1Foreground fg = updateAllAxesStyles  (-                       (axis_line_style .> line_color ^= fg).-                       (axis_label_style .> font_color ^= fg)-                       )-                 . (layout1_title_style .> font_color ^= fg)-                 . (layout1_legend ^: fmap (legend_label_style .> font_color ^= fg))---linkAxes (ys1,ys2) = (ys1++ys2,ys1++ys2)-independentAxes (ys1,ys2) = (ys1,ys2)+-- 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+  ( -- * Types+    Layout(..)+  , LayoutLR(..)+  , LayoutAxis(..)+  , LayoutPick(..)+  , StackedLayouts(..)+  , StackedLayout(..)+  -- , LegendItem  haddock complains about this being missing, but from what?+  , MAxisFn++    -- * 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.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++-- | A @MAxisFn@ is a function that generates an (optional) axis+--   given the points plotted against that axis.+type MAxisFn t = [t] -> Maybe (AxisData t)++-- | 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.++  , _laxis_generate    :: AxisFn x+    -- ^ Function that generates the axis data, based upon the+    --   points plotted. The default value is 'autoAxis'.++  , _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+    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 = 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++getLayoutXVals :: Layout x y -> [x]+getLayoutXVals l = concatMap (fst . _plot_all_points) (_layout_plots l)++-- | 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 ]++-- | 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 ]++-- | 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+    }++    -- | 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++        xr = (0, w)+        yr = (h, 0)++        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)++-- | 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++    , _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+    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++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))++-- | 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++-- | 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++-- | 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 }++    , _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
@@ -1,28 +1,32 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Graphics.Rendering.Chart.Legend--- Copyright   :  (c) Tim Docker 2006+-- Copyright   :  (c) Tim Docker 2006, 2014 -- License     :  BSD-style (see chart/COPYRIGHT)--{-# OPTIONS_GHC -XTemplateHaskell #-}+-- +-- 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(..),-    defaultLegendStyle,+    LegendOrientation(..),+    LegendPosition(..),     legendToRenderable,     legend_label_style,     legend_margin,     legend_plot_size,+    legend_orientation,+    legend_position ) where -import qualified Graphics.Rendering.Cairo as C-import Control.Monad-import Data.List (nub, partition,intersperse)-import Data.Accessor.Template+import Data.List (partition,intersperse)+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.Renderable import Graphics.Rendering.Chart.Grid @@ -30,51 +34,92 @@ -- Legend  data LegendStyle = LegendStyle {-   legend_label_style_ :: CairoFontStyle,-   legend_margin_ :: Double,-   legend_plot_size_ :: Double+   _legend_label_style :: FontStyle,+   _legend_margin      :: Double,+   _legend_plot_size   :: Double,+   _legend_orientation :: LegendOrientation,+   _legend_position    :: LegendPosition } -data Legend x y = Legend Bool LegendStyle [(String, Rect -> CRender ())]+-- | Legends can be constructed in two orientations: in rows+-- (where we specify the maximum number of columns), and in+-- columns (where we specify the maximum number of rows)+data LegendOrientation = LORows Int+                       | LOCols Int +-- | 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+  toRenderable = setPickFn nullPickFn . legendToRenderable  legendToRenderable :: Legend x y -> Renderable String-legendToRenderable (Legend _ ls lvs) = gridToRenderable grid+legendToRenderable (Legend ls lvs) = gridToRenderable grid   where-    grid = besideN $ intersperse ggap1 (map (tval.rf) ps)+    grid :: Grid (Renderable String)+    grid = case _legend_orientation ls of+        LORows n -> mkGrid n aboveG besideG+        LOCols n -> mkGrid n besideG aboveG  -    ps :: [(String, [Rect -> CRender ()])]-    ps = join_nub lvs+    aboveG, besideG :: [Grid (Renderable String)] -> Grid (Renderable String)+    aboveG = aboveN.intersperse ggap1+    besideG = besideN.intersperse ggap1 -    rf (title,rfs) = gridToRenderable grid1+    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-        grid1 = besideN $ intersperse ggap2 (map rp rfs) ++ [ggap2,gtitle]+        gpic :: Grid (Renderable String)+        gpic = besideN $ intersperse ggap2 (map rp rfs)++        gtitle :: Grid (Renderable String)         gtitle = tval $ lbl title-        rp rfn = tval $ Renderable {-               minsize = return (legend_plot_size_ ls, 0),-               render = \(w,h) -> do -                 rfn (Rect (Point 0 0) (Point w h))-                 return nullPickFn-             } -    ggap1 = tval $ spacer (legend_margin_ ls,0)+        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 s = label (legend_label_style_ ls) HTA_Centre VTA_Centre s +    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 [] = []+join_nub []          = [] -defaultLegendStyle = LegendStyle {-    legend_label_style_=defaultFontStyle,-    legend_margin_=20,-    legend_plot_size_=20-}+instance Default LegendStyle where+  def = LegendStyle+    { _legend_label_style = def+    , _legend_margin      = 20+    , _legend_plot_size   = 20+    , _legend_orientation = LORows 4+    , _legend_position    = LegendBelow+    } -------------------------------------------------------------------------- Template haskell to derive an instance of Data.Accessor.Accessor for each field-$( deriveAccessors ''LegendStyle )+$( makeLenses ''LegendStyle )
− Graphics/Rendering/Chart/Pie.hs 
@@ -1,219 +0,0 @@-{-# OPTIONS_GHC -XTemplateHaskell #-}
------------------------------------------------------------------------------
--- |
--- Module      :  Graphics.Rendering.Chart.Layout
--- Copyright   :  (c) Tim Docker 2008
--- License     :  BSD-style (see chart/COPYRIGHT)
---
--- A  basic pie chart.
---
--- Note that template haskell is used to derive accessor functions
--- (see 'Data.Accessor') for each field of the following data types:
---
---     * 'PieLayout'
---
---     * 'PieChart'
---
---     * 'PieItem'
---
--- 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 :: Data.Accessor.Accessor D F
--- @
---
-
-
-module Graphics.Rendering.Chart.Pie(
-    PieLayout(..),
-    PieChart(..),
-    PieItem(..),
-    defaultPieLayout,
-    defaultPieChart,
-    defaultPieItem,
-
-    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
-
-import qualified Graphics.Rendering.Cairo as C
-
-import Data.List
-import Data.Bits
-import Data.Accessor.Template
-import Data.Colour
-import Data.Colour.Names (black, white)
-import Control.Monad
-
-import Graphics.Rendering.Chart.Types
-import Graphics.Rendering.Chart.Legend
-import Graphics.Rendering.Chart.Renderable
-import Graphics.Rendering.Chart.Grid
-
-data PieLayout = PieLayout {
-   pie_title_ :: String,
-   pie_title_style_ :: CairoFontStyle,
-   pie_plot_ :: PieChart,
-   pie_background_ :: CairoFillStyle,
-   pie_margin_ :: Double
-}
-
-data PieChart = PieChart {
-   pie_data_  :: [PieItem],
-   pie_colors_ :: [AlphaColour Double],
-   pie_label_style_ :: CairoFontStyle,
-   pie_label_line_style_ :: CairoLineStyle, 
-   pie_start_angle_ :: Double
-
-}
-
-data PieItem = PieItem {
-   pitem_label_ :: String,
-   pitem_offset_ :: Double,
-   pitem_value_ :: Double
-}
-
-defaultPieChart = PieChart {
-    pie_data_ = [], 
-    pie_colors_ = defaultColorSeq,
-    pie_label_style_ = defaultFontStyle,
-    pie_label_line_style_ = solidLine 1 $ opaque black,
-    pie_start_angle_ = 0
-}
-
-defaultPieItem = PieItem "" 0 0
-
-defaultPieLayout = PieLayout {
-    pie_background_ = solidFillStyle $ opaque white,
-    pie_title_ = "",
-    pie_title_style_ = defaultFontStyle{font_size_=15, font_weight_=C.FontWeightBold},
-    pie_plot_ = defaultPieChart,
-    pie_margin_ = 10
-}
-
-instance ToRenderable PieLayout where
-    toRenderable p = fillBackground (pie_background_ p) (
-       gridToRenderable $ aboveN [
-       tval $ addMargins (lm/2,0,0,0) title,
-       weights (1,1) $ tval $ addMargins (lm,lm,lm,lm) (toRenderable $ pie_plot_ p)
-       ] )
-      where
-        title = label (pie_title_style_ p) HTA_Centre VTA_Top (pie_title_ p)
-        lm = pie_margin_ p
-
-instance ToRenderable PieChart where
-    toRenderable p = Renderable {
-      minsize=minsizePie p,
-      render=renderPie p
-    }
-
-extraSpace p = do
-    textSizes <- mapM textSize (map pitem_label_ (pie_data_ p))
-    let maxw = foldr (max.fst) 0 textSizes
-    let maxh = foldr (max.snd) 0 textSizes
-    let maxo = foldr (max.pitem_offset_) 0 (pie_data_ p)
-    let extra = label_rgap + label_rlength + maxo
-    return (extra + maxw, extra + maxh )
-
-minsizePie p = do
-    (extraw,extrah) <- extraSpace p
-    return (extraw * 2, extrah * 2)
-
-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 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 [ pi{pitem_value_=pitem_value_ pi/total} | pi <- pie_data_ p ]
-
-        paint :: Point -> Double -> Double -> (AlphaColour Double, PieItem) -> CRender Double
-        paint center radius a1 (color,pitem) = do
-            let ax = 360.0 * (pitem_value_ pitem)
-            let a2 = a1 + (ax / 2)
-            let a3 = a1 + ax
-            let offset = pitem_offset_ pitem
-
-            pieSlice (ray a2 offset) a1 a3 color
-            pieLabel (pitem_label_ pitem) a2 offset
-
-            return a3
-
-            where
-                pieLabel :: String -> Double -> Double -> CRender ()
-                pieLabel name angle offset = do
-                    setFontStyle (pie_label_style_ p)
-                    setLineStyle (pie_label_line_style_ p)
-
-                    moveTo (ray angle (radius + label_rgap+offset))
-                    let p1 = (ray angle (radius + label_rgap + label_rlength+offset))
-                    lineTo p1
-                    (tw,th) <- textSize name
-                    let (offset,anchor) = if angle < 90 || angle > 270 
-                                          then ((0+),HTA_Left)
-                                          else ((0-),HTA_Right)
-                    c $ C.relLineTo (offset (tw + label_rgap))  0
-                    c $ C.stroke
-
-                    let p2 = p1 `pvadd` (Vector (offset label_rgap) 0)
-                    drawText anchor VTA_Bottom p2 name
-
-                pieSlice :: Point -> Double -> Double -> AlphaColour Double -> CRender ()
-                pieSlice (Point x y) a1 a2 color = c $ do
-                    C.newPath
-                    C.arc x y radius (radian a1) (radian a2)
-                    C.lineTo x y
-                    C.lineTo x y
-                    C.closePath
-
-                    setSourceColor color
-                    C.fillPreserve
-                    C.setSourceRGBA 1 1 1 0.1
-
-                    C.stroke
-
-                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
-                    x''  = ((x + r) - x)
-                    x    = p_x center
-                    y    = p_y center
-
-                radian = (*(pi / 180.0))
-
-
-label_rgap = 5
-label_rlength = 15
-
-----------------------------------------------------------------------
--- Template haskell to derive an instance of Data.Accessor.Accessor for each field
-$( deriveAccessors ''PieLayout )
-$( deriveAccessors ''PieChart )
-$( deriveAccessors ''PieItem )
-
Graphics/Rendering/Chart/Plot.hs view
@@ -4,525 +4,35 @@ -- Copyright   :  (c) Tim Docker 2006 -- License     :  BSD-style (see chart/COPYRIGHT) ----- Definitions of various types of Plots we can put on a 2D Chart.------ Note that template haskell is used to derive accessor functions--- (see 'Data.Accessor') for each field of the following data types:------     * 'Plot'------     * 'PlotLines'------     * 'PlotPoints'------     * 'PlotFillBetween'------     * 'PlotErrBars'---     ---     * 'PlotBars'------ 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 :: Data.Accessor.Accessor D F--- @+-- Code to calculate and render various types of plots. -- --{-# OPTIONS_GHC -XTemplateHaskell #-}- module Graphics.Rendering.Chart.Plot(-    Plot(..),-    ToPlot(..),-    PlotPoints(..),-    PlotErrBars(..),-    PlotLines(..),-    PlotFillBetween(..),-    ErrPoint(..),-    PlotBars(..),-    PlotBarsStyle(..),-    PlotBarsSpacing(..),--    symErrPoint,--    defaultPlotLineStyle,-    defaultPlotPoints,-    defaultPlotErrBars,-    defaultPlotFillBetween,-    defaultPlotLines,-    defaultPlotBars,--    plot_lines_title,-    plot_lines_style,-    plot_lines_values,-    plot_lines_limit_values,--    hlinePlot,-    vlinePlot,--    plot_render,-    plot_legend,-    plot_all_points,--    plot_points_title,-    plot_points_style,-    plot_points_values,--    plot_fillbetween_title,-    plot_fillbetween_style,-    plot_fillbetween_values,--    plot_errbars_title,-    plot_errbars_line_style,-    plot_errbars_tick_length,-    plot_errbars_overhang,-    plot_errbars_values,--    plotBars,-    plot_bars_style,-    plot_bars_item_styles,-    plot_bars_titles,-    plot_bars_spacing,-    plot_bars_reference,-    plot_bars_values,--    ) where--import qualified Graphics.Rendering.Cairo as C-import Graphics.Rendering.Chart.Types-import Graphics.Rendering.Chart.Axis-import Control.Monad-import Data.List-import Data.Accessor.Template-import Data.Colour-import Data.Colour.SRGB (sRGB)-import Data.Colour.Names---- | Interface to control plotting on a 2D area.-data Plot x y = Plot {--    -- | Given the mapping between model space coordinates and device coordinates,-    -- render this plot into a chart.-    plot_render_ :: PointMapFn x y -> CRender (),--    -- | Details for how to show this plot in a legend. For each item-    -- the string is the text to show, and the function renders a-    -- graphical sample of the plot-    plot_legend_ :: [ (String, Rect -> CRender ()) ],--    -- | 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--------------------------------------------------------------------------mapXY :: PointMapFn x y -> ((x,y) -> Point)-mapXY f (x,y) = f (LValue x, LValue y)---------------------------------------------------------------------------- | Value defining a series of (possibly disjointed) lines,--- and a style in which to render them-data PlotLines x y = PlotLines {-    plot_lines_title_ :: String,-    plot_lines_style_ :: CairoLineStyle,-    plot_lines_values_ :: [[(x,y)]],-    plot_lines_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 -> CRender ()-renderPlotLines p pmap = preserveCState $ do-    setLineStyle (plot_lines_style_ p)-    mapM_ (drawLines (mapXY pmap)) (plot_lines_values_ p)-    mapM_ (drawLines pmap) (plot_lines_limit_values_ p)-  where-    drawLines pmap (p:ps) = do-	moveTo (pmap p)-	mapM_ (\p -> lineTo (pmap p)) ps-	c $ C.stroke--renderPlotLegendLines :: PlotLines x y -> Rect -> CRender ()-renderPlotLegendLines p r@(Rect p1 p2) = preserveCState $ do-    setLineStyle (plot_lines_style_ p)-    let y = (p_y p1 + p_y p2) / 2-    moveTo (Point (p_x p1) y)-    lineTo (Point (p_x p2) y)-    c $ C.stroke--defaultPlotLineStyle = (solidLine 1 $ opaque blue){-     line_cap_ = C.LineCapRound,-     line_join_ = C.LineJoinRound- }--defaultPlotLines = 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 -> CairoLineStyle -> b -> Plot a b-hlinePlot t ls v = toPlot defaultPlotLines {-    plot_lines_title_=t,-    plot_lines_style_=ls,-    plot_lines_limit_values_=[[(LMin, LValue v),(LMax, LValue v)]]-    }---- | Helper function to plot a single vertical line-vlinePlot :: String -> CairoLineStyle -> a -> Plot a b-vlinePlot t ls v = toPlot defaultPlotLines {-    plot_lines_title_=t,-    plot_lines_style_=ls,-    plot_lines_limit_values_=[[(LValue v,LMin),(LValue v,LMax)]]-    }---------------------------------------------------------------------------- | Value defining a series of datapoints, and a style in--- which to render them-data PlotPoints x y = PlotPoints {-    plot_points_title_ :: String,-    plot_points_style_ :: CairoPointStyle,-    plot_points_values_ :: [(x,y)]-}---instance ToPlot PlotPoints where-    toPlot p = Plot {-        plot_render_ = renderPlotPoints p,-	plot_legend_ = [(plot_points_title_ p, renderPlotLegendPoints p)],-	plot_all_points_ = (map fst pts, map snd pts)-    }-      where-        pts = plot_points_values_ p--renderPlotPoints :: PlotPoints x y -> PointMapFn x y -> CRender ()-renderPlotPoints p pmap = preserveCState $ do-    mapM_ (drawPoint.pmap') (plot_points_values_ p)-  where-    pmap' = mapXY pmap-    (CairoPointStyle drawPoint) = (plot_points_style_ p)---renderPlotLegendPoints :: PlotPoints x y -> Rect -> CRender ()-renderPlotLegendPoints p r@(Rect p1 p2) = preserveCState $ do-    drawPoint (Point (p_x p1) ((p_y p1 + p_y p2)/2))-    drawPoint (Point ((p_x p1 + p_x p2)/2) ((p_y p1 + p_y p2)/2))-    drawPoint (Point (p_x p2) ((p_y p1 + p_y p2)/2))--  where-    (CairoPointStyle drawPoint) = (plot_points_style_ p)--defaultPlotPoints = PlotPoints {-    plot_points_title_ = "",-    plot_points_style_ =defaultPointStyle,-    plot_points_values_ = []-}-------------------------------------------------------------------------- | Value specifying a plot filling the area between two sets of Y--- coordinates, given common X coordinates.--data PlotFillBetween x y = PlotFillBetween {-    plot_fillbetween_title_ :: String,-    plot_fillbetween_style_ :: CairoFillStyle,-    plot_fillbetween_values_ :: [ (x, (y,y))]-}---instance ToPlot PlotFillBetween where-    toPlot p = Plot {-        plot_render_ = renderPlotFillBetween p,-	plot_legend_ = [(plot_fillbetween_title_ p, renderPlotLegendFill p)],-	plot_all_points_ = plotAllPointsFillBetween p-    }--renderPlotFillBetween :: PlotFillBetween x y -> PointMapFn x y -> CRender ()-renderPlotFillBetween p pmap = renderPlotFillBetween' p (plot_fillbetween_values_ p) pmap--renderPlotFillBetween' p [] _ = return ()-renderPlotFillBetween' p vs pmap  = preserveCState $ do-    setFillStyle (plot_fillbetween_style_ p)-    moveTo p0-    mapM_ lineTo p1s-    mapM_ lineTo (reverse p2s)-    lineTo p0-    c $ C.fill-  where-    pmap' = mapXY pmap-    (p0:p1s) = map pmap' [ (x,y1) | (x,(y1,y2)) <- vs ]-    p2s = map pmap' [ (x,y2) | (x,(y1,y2)) <- vs ]--renderPlotLegendFill :: PlotFillBetween x y -> Rect -> CRender ()-renderPlotLegendFill p r = preserveCState $ do-    setFillStyle (plot_fillbetween_style_ p)-    rectPath r-    c $ C.fill--plotAllPointsFillBetween :: PlotFillBetween x y -> ([x],[y])-plotAllPointsFillBetween p = ([x|(x,(_,_)) <- pts], concat [[y1,y2]|(_,(y1,y2)) <- pts])-  where-    pts = plot_fillbetween_values_ p---defaultPlotFillBetween = PlotFillBetween {-    plot_fillbetween_title_ = "",-    plot_fillbetween_style_ = solidFillStyle (opaque $ sRGB 0.5 0.5 1.0),-    plot_fillbetween_values_= []-}---------------------------------------------------------------------------- | 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 symetric, we can simply pass in dx for the error-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_ :: CairoLineStyle,-    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 -> CRender ()-renderPlotErrBars p pmap = preserveCState $ do-    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 ps (ErrPoint (ErrValue xl x xh) (ErrValue yl y yh)) = do-        let tl = plot_errbars_tick_length_ ps-        let oh = plot_errbars_overhang_ ps-        setLineStyle (plot_errbars_line_style_ ps)-        c $ C.newPath-        c $ C.moveTo (xl-oh) y-        c $ C.lineTo (xh+oh) y-        c $ C.moveTo x (yl-oh)-        c $ C.lineTo x (yh+oh)-        c $ C.moveTo xl (y-tl)-        c $ C.lineTo xl (y+tl)-        c $ C.moveTo (x-tl) yl-        c $ C.lineTo (x+tl) yl-        c $ C.moveTo xh (y-tl)-        c $ C.lineTo xh (y+tl)-        c $ C.moveTo (x-tl) yh-        c $ C.lineTo (x+tl) yh-	c $ C.stroke--renderPlotLegendErrBars :: PlotErrBars x y -> Rect -> CRender ()-renderPlotLegendErrBars p r@(Rect p1 p2) = preserveCState $ do-    drawErrBar (symErrPoint (p_x p1) ((p_y p1 + p_y p2)/2) dx dx )-    drawErrBar (symErrPoint ((p_x p1 + p_x p2)/2) ((p_y p1 + p_y p2)/2) dx dx)-    drawErrBar (symErrPoint (p_x p2) ((p_y p1 + p_y p2)/2) dx dx)--  where-    drawErrBar = drawErrBar0 p-    dx = min ((p_x p2 - p_x p1)/6) ((p_y p2 - p_y p1)/2)--defaultPlotErrBars = PlotErrBars {-    plot_errbars_title_ = "",-    plot_errbars_line_style_ = solidLine 1 $ opaque blue,-    plot_errbars_tick_length_ = 3,-    plot_errbars_overhang_ = 0,-    plot_errbars_values_ = []-}--------------------------------------------------------------------------class PlotValue a => BarsPlotValue a where-    barsReference :: a-    barsAdd :: a -> a -> a--instance BarsPlotValue Double where-    barsReference = 0-    barsAdd = (+)--data PlotBarsStyle = BarsStacked | BarsClustered-data PlotBarsSpacing = BarsFixWidth Double-                     | BarsFixGap Double---- | 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 PlotBars x y = PlotBars {-   -- | This value specifies whether each value from [y] should be-   -- shown beside or above the previous value.-   plot_bars_style_ :: PlotBarsStyle,--   -- | The style in which to draw each element of [y]. A fill style-   -- is required, and if a linestyle is given, each bar will be-   -- outlined.-   plot_bars_item_styles_ :: [ (CairoFillStyle,Maybe CairoLineStyle) ],--   -- | The title of each element of [y]. These will be shown in the-   -- legend.-   plot_bars_titles_ :: [String],--   -- | This value controls how the widths of the bars are-   -- calculated. Either the widths of the bars, or the gaps between-   -- them can be fixed.-   plot_bars_spacing_ :: PlotBarsSpacing,--   -- | The starting level for the chart (normally 0).-   plot_bars_reference_ :: y,--   -- | The actual points to be plotted-   plot_bars_values_ :: [ (x,[y]) ]-}--defaultPlotBars :: BarsPlotValue y => PlotBars x y-defaultPlotBars = PlotBars {-   plot_bars_style_ = BarsClustered,-   plot_bars_item_styles_ = cycle istyles,-   plot_bars_titles_ = [],-   plot_bars_spacing_ = BarsFixGap 10,-   plot_bars_values_ = [],-   plot_bars_reference_ = barsReference-   }-  where-    istyles = map mkstyle defaultColorSeq-    mkstyle c = (solidFillStyle c,Just (solidLine 1.0 $ opaque black))--plotBars :: (BarsPlotValue y) => PlotBars x y -> Plot x y-plotBars p = Plot {-        plot_render_ = renderPlotBars p,-	plot_legend_ = zip (plot_bars_titles_ p) (map renderPlotLegendBars (plot_bars_item_styles_ p)),-	plot_all_points_ = allBarPoints p-    }--renderPlotBars :: BarsPlotValue y => PlotBars x y -> PointMapFn x y -> CRender ()-renderPlotBars p pmap = case (plot_bars_style_ p) of-      BarsClustered -> do forM_ vals clusteredBars-      BarsStacked -> forM_ vals stackedBars-  where-    clusteredBars (x,ys) = preserveCState $ do-       forM_ (zip3 [0,1..] ys styles) $ \(i, y, (fstyle,_)) -> do-           setFillStyle fstyle-           barPath (offset i) x yref0 y-           c $ C.fill-       forM_ (zip3 [0,1..] ys styles) $ \(i, y, (_,mlstyle)) -> do-           whenJust mlstyle $ \lstyle -> do-             setLineStyle lstyle-             barPath (offset i) x yref0 y-             c $ C.stroke--    offset i = fromIntegral (2*i-nys) * width/2--    stackedBars (x,ys) =  preserveCState $ do-       let y2s = zip (yref0:stack ys) (stack ys)-       forM_ (zip y2s styles) $ \((y0,y1), (fstyle,_)) -> do-           setFillStyle fstyle-           barPath (-width/2) x y0 y1-           c $ C.fill-       forM_ (zip y2s styles) $ \((y0,y1), (_,mlstyle)) -> do-           whenJust mlstyle $ \lstyle -> do-               setLineStyle lstyle-               barPath (-width/2) x y0 y1-               c $ C.stroke--    barPath xos x y0 y1 = do-      let (Point x' y') = pmap' (x,y1)-      let (Point _ y0') = pmap' (x,y0)-      rectPath (Rect (Point (x'+xos) y0') (Point (x'+xos+width) y'))--    yref0 = plot_bars_reference_ p-    vals = plot_bars_values_ p-    width = case plot_bars_spacing_ p of-        BarsFixGap gap -> case (plot_bars_style_ p) of-            BarsClustered -> (minXInterval - gap) / fromIntegral nys-            BarsStacked -> (minXInterval - gap)-        BarsFixWidth width -> width-    styles = plot_bars_item_styles_ p--    minXInterval = minimum $ zipWith (-) (tail xs) xs-      where               -        xs = nub $ sort $ map (\x-> p_x (pmap' (x,barsReference))) (fst (allBarPoints p))--    nys = maximum [ length ys | (x,ys) <- vals ]-          -    pmap' = mapXY pmap--whenJust :: (Monad m) => Maybe a -> (a -> m ()) -> m ()-whenJust (Just a) f = f a-whenJust _ _ = return ()--allBarPoints :: (BarsPlotValue y) => PlotBars x y -> ([x],[y])-allBarPoints p = case (plot_bars_style_ p) of-    BarsClustered -> ( [x| (x,_) <- pts], concat [ys| (_,ys) <- pts] )-    BarsStacked -> ( [x| (x,_) <- pts], concat [stack ys | (_,ys) <- pts] )-  where-    pts = plot_bars_values_ p-    y0 = plot_bars_reference_ p--stack :: (BarsPlotValue y) => [y] -> [y]-stack ys = scanl1 barsAdd ys-             --renderPlotLegendBars :: (CairoFillStyle,Maybe CairoLineStyle) -> Rect -> CRender ()-renderPlotLegendBars (fstyle,mlstyle) r@(Rect p1 p2) = do-    setFillStyle fstyle-    rectPath r-    c $ C.fill+    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 -------------------------------------------------------------------------- Template haskell to derive an instance of Data.Accessor.Accessor for each field-$( deriveAccessors ''Plot )-$( deriveAccessors ''PlotLines )-$( deriveAccessors ''PlotPoints )-$( deriveAccessors ''PlotFillBetween )-$( deriveAccessors ''PlotErrBars )-$( deriveAccessors ''PlotBars )+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,26 +1,25 @@ ----------------------------------------------------------------------------- -- | -- 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(     Renderable(..),     ToRenderable(..),     PickFn,--    renderableToPNGFile,-    renderableToPDFFile,-    renderableToPSFile,-    renderableToSVGFile,+    Rectangle(..),+    RectCornerStyle(..), -    vectorEnv,-    bitmapEnv,+    rectangleToRenderable,+    drawRectangle,      fillBackground,     addMargins,@@ -31,6 +30,7 @@     spacer,     spacer1,     setPickFn,+    mapMaybePickFn,     mapPickFn,     nullPickFn, @@ -40,82 +40,77 @@     rect_cornerStyle, ) where -import qualified Graphics.Rendering.Cairo as C import Control.Monad-import Data.Accessor-import Data.List ( nub, transpose, sort )+import Control.Lens+import Data.Default.Class -import Graphics.Rendering.Chart.Types+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.+-- | 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)+--   Perhaps it might be generalised from Maybe a to+--   (MonadPlus m ) => m a in the future.+type PickFn a = Point -> Maybe a  nullPickFn :: PickFn a nullPickFn = const Nothing  -- | A Renderable is a record of functions required to layout a--- graphic element.+--   graphic element. data Renderable a = Renderable { -   -- | a Cairo action to calculate a minimum size,-   minsize :: CRender RectSize,+   -- | Calculate the minimum size of the renderable.+   minsize :: BackendProgram RectSize, -   -- | a Cairo action for drawing it within a rectangle.-   -- The rectangle is from the origin to the given point.+   -- | 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 -> CRender (PickFn a)+   --   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) --- | Create a blank renderable with a specified minimum size-spacer :: RectSize -> Renderable a -spacer sz = Renderable {+-- | Create a blank renderable with a specified minimum size.+spacer :: RectSize -> Renderable a+spacer sz  = Renderable {    minsize = return sz,    render  = \_ -> return nullPickFn }   -- | Create a blank renderable with a minimum size the same as--- some other renderable.+--   some other renderable. spacer1 :: Renderable a -> Renderable b-spacer1 r = Renderable {-   minsize = minsize r,-   render  = \_ -> return nullPickFn-}+spacer1 r  = r{ render  = \_ -> return nullPickFn } --- | Replace the pick function of a renderable with another+-- | Replace the pick function of a renderable with another. setPickFn :: PickFn b -> Renderable a -> Renderable b-setPickFn pickfn r = Renderable {-    minsize=minsize r,-    render = \sz -> do { render r sz; return pickfn; }-    }+setPickFn pickfn r = r{ render  = \sz -> render r sz >> return pickfn } --- | Map a function over result of a renderables pickfunction.+-- | 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 r = Renderable {-    minsize=minsize r,-    render = \sz -> do {-        pf <- render r sz;-        return (\p -> fmap f (pf p));-        }-    }+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+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@@ -123,122 +118,78 @@         (w,h) <- minsize rd         return (w+l+r,h+t+b) -    rf (w,h) = do-        preserveCState $ do-            c $ C.translate l t-            pickf <- render rd (w-l-r,h-t-b)-            mtx <- c $ C.getMatrix-            return (mkpickf pickf (w,h) mtx)--    mkpickf pickf (w,h) mtx pt | within pt' rect = pickf pt'-                               | otherwise = Nothing-      where-        pt' = transform mtx pt-        rect = (Rect (Point 0 0) (Point w h))+    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)) -transform :: C.Matrix -> Point -> Point-transform = undefined+    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  -- | Overlay a renderable over a solid background fill.-fillBackground :: CairoFillStyle -> Renderable a -> Renderable a-fillBackground fs r = Renderable { minsize = minsize r, render = rf }+fillBackground :: FillStyle -> Renderable a -> Renderable a+fillBackground fs r = r{ render = rf }   where     rf rsize@(w,h) = do-        preserveCState $ do-            setClipRegion (Point 0 0) (Point w h)-            setFillStyle fs-            c $ C.paint-	render r rsize---- | Output the given renderable to a PNG file of the specifed size--- (in pixels), to the specified file.-renderableToPNGFile :: Renderable a -> Int -> Int -> FilePath -> IO ()-renderableToPNGFile chart width height path = -    C.withImageSurface C.FormatARGB32 width height $ \result -> do-    C.renderWith result $ runCRender rfn bitmapEnv-    C.surfaceWriteToPNG result path-  where-    rfn = do-	render chart (fromIntegral width, fromIntegral height)--renderableToFile withSurface chart width height path = -    withSurface path (fromIntegral width) (fromIntegral height) $ \result -> do-    C.renderWith result $ runCRender rfn vectorEnv-    C.surfaceFinish result-  where-    rfn = do-        render chart (fromIntegral width, fromIntegral height)-        c $ C.showPage---- | Output the given renderable to a PDF file of the specifed size--- (in points), to the specified file.-renderableToPDFFile :: Renderable a -> Int -> Int -> FilePath -> IO ()-renderableToPDFFile = renderableToFile C.withPDFSurface---- | Output the given renderable to a postscript file of the specifed size--- (in points), to the specified file.-renderableToPSFile :: Renderable a -> Int -> Int -> FilePath -> IO ()-renderableToPSFile = renderableToFile C.withPSSurface---- | Output the given renderable to an SVG file of the specifed size--- (in points), to the specified file.-renderableToSVGFile :: Renderable a -> Int -> Int -> FilePath -> IO ()-renderableToSVGFile = renderableToFile C.withSVGSurface--bitmapEnv = CEnv (adjfn 0.5) (adjfn 0.0)-  where-    adjfn offset (Point x y) = Point (adj x) (adj y)-      where-        adj v = (fromIntegral.round) v +offset--vectorEnv = CEnv id id+      withFillStyle fs $ do+        p <- alignFillPath $ rectPath (Rect (Point 0 0) (Point w h))+        fillPath p+      render r rsize  -- | Helper function for using a renderable, when we generate it--- in the CRender monad.-embedRenderable :: CRender (Renderable a) -> Renderable a+--   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 }+   render  = \ r -> do { a <- ca; render a r } }   ---------------------------------------------------------------------- -- Labels --- | Construct a renderable from a text string, aligned with the axes-label :: CairoFontStyle -> HTextAnchor -> VTextAnchor -> String -> Renderable a+-- | 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  -- | Construct a renderable from a text string, rotated wrt to axes. The angle--- of rotation is in degrees.-rlabel :: CairoFontStyle -> HTextAnchor -> VTextAnchor -> Double -> String -> Renderable a+--   of rotation is in degrees, 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-    mf = preserveCState $ do-       setFontStyle fs-       (w,h) <- textSize s-       return (w*acr+h*asr,w*asr+h*acr)-    rf (w0,h0) = preserveCState $ do-       setFontStyle fs-       sz@(w,h) <- textSize s-       fe <- c $ C.fontExtents-       c $ C.translate 0 (-C.fontExtentsDescent fe)-       c $ C.translate (xadj sz hta 0 w0) (yadj sz vta 0 h0)-       c $ C.rotate rot'-       c $ C.moveTo (-w/2) (h/2)-       c $ C.showText s-       return nullPickFn-    xadj (w,h) HTA_Left x1 x2 =  x1 +(w*acr+h*asr)/2-    xadj (w,h) HTA_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+    mf = withFontStyle fs $ do+       ts <- textSize s+       let sz = (textSizeWidth ts, textSizeHeight ts)+       return (xwid sz, ywid sz) -    rot' = rot / 180 * pi-    (cr,sr) = (cos rot', sin rot')+    rf (w0,h0) = withFontStyle fs $ do+      ts <- textSize s+      let sz@(w,h) = (textSizeWidth ts, textSizeHeight ts)+          descent = textSizeDescent ts++          xadj HTA_Left   = xwid sz/2+          xadj HTA_Centre = w0/2+          xadj HTA_Right  = w0 - xwid sz/2++          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++      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++    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+ ---------------------------------------------------------------------- -- Rectangles @@ -247,80 +198,74 @@                      | RCornerRounded Double  data Rectangle = Rectangle {-  rect_minsize_ :: RectSize,-  rect_fillStyle_ :: Maybe CairoFillStyle,-  rect_lineStyle_ :: Maybe CairoLineStyle,-  rect_cornerStyle_ :: RectCornerStyle+  _rect_minsize     :: RectSize,+  _rect_fillStyle   :: Maybe FillStyle,+  _rect_lineStyle   :: Maybe LineStyle,+  _rect_cornerStyle :: RectCornerStyle } --- | Accessor for field rect_minsize_-rect_minsize = accessor (\v->rect_minsize_ v) (\a v -> v{rect_minsize_=a})---- | Accessor for field rect_fillStyle_-rect_fillStyle = accessor (\v->rect_fillStyle_ v) (\a v -> v{rect_fillStyle_=a})---- | Accessor for field rect_lineStyle_-rect_lineStyle = accessor (\v->rect_lineStyle_ v) (\a v -> v{rect_lineStyle_=a})+instance Default Rectangle where+  def = Rectangle+    { _rect_minsize     = (0,0)+    , _rect_fillStyle   = Nothing+    , _rect_lineStyle   = Nothing+    , _rect_cornerStyle = RCornerSquare+    } --- | Accessor for field rect_cornerStyle_-rect_cornerStyle = accessor (\v->rect_cornerStyle_ v) (\a v -> v{rect_cornerStyle_=a})+instance ToRenderable Rectangle where+  toRenderable = rectangleToRenderable +rectangleToRenderable :: Rectangle -> Renderable a+rectangleToRenderable rectangle = Renderable mf rf+  where+    mf = return (_rect_minsize rectangle)+    rf = \rectSize -> drawRectangle (Point 0 0)+                                    rectangle{ _rect_minsize = rectSize } -defaultRectangle = Rectangle {-  rect_minsize_ = (0,0),-  rect_fillStyle_ = Nothing,-  rect_lineStyle_ = Nothing,-  rect_cornerStyle_ = RCornerSquare-}+-- | 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 -instance ToRenderable Rectangle where-   toRenderable rectangle = Renderable mf rf-     where-      mf = return (rect_minsize_ rectangle)-      rf sz = preserveCState $ do-        maybeM () (fill sz) (rect_fillStyle_ rectangle)-        maybeM () (stroke sz) (rect_lineStyle_ rectangle)-        return nullPickFn+      fill p sz fs =+          withFillStyle fs $+            fillPath $ strokeRectangleP p sz (_rect_cornerStyle rectangle) -      fill sz fs = do-          setFillStyle fs-          strokeRectangle sz (rect_cornerStyle_ rectangle)-          c $ C.fill+      stroke p sz ls =+          withLineStyle ls $+            strokePath $ strokeRectangleP p sz (_rect_cornerStyle rectangle) -      stroke sz ls = do-          setLineStyle ls-          strokeRectangle sz (rect_cornerStyle_ rectangle)-          c $ C.stroke+      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 -      strokeRectangle (x2,y2) RCornerSquare = c $ do-          let (x1,y1) = (0,0)-          C.moveTo x1 y1-          C.lineTo x1 y2-          C.lineTo x2 y2-          C.lineTo x2 y1-          C.lineTo x1 y1-          C.lineTo x1 y2-                                  -      strokeRectangle (x2,y2) (RCornerBevel s) = c $ do-          let (x1,y1) = (0,0)-          C.moveTo x1 (y1+s)-          C.lineTo x1 (y2-s)-          C.lineTo (x1+s) y2-          C.lineTo (x2-s) y2-          C.lineTo x2 (y2-s)-          C.lineTo x2 (y1+s)-          C.lineTo (x2-s) y1-          C.lineTo (x1+s) y1-          C.lineTo x1 (y1+s)-          C.lineTo x1 (y2-s)+      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) -      strokeRectangle (x2,y2) (RCornerRounded s) = c $ do-          let (x1,y1) = (0,0)-          C.arcNegative (x1+s) (y2-s) s (pi2*2) pi2 -          C.arcNegative (x2-s) (y2-s) s pi2 0-          C.arcNegative (x2-s) (y1+s) s 0 (pi2*3)-          C.arcNegative (x1+s) (y1+s) s (pi2*3) (pi2*2)-          C.lineTo x1 (y2-s)+      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)        pi2 = pi / 2 +$( makeLenses ''Rectangle )
− Graphics/Rendering/Chart/Simple.hs 
@@ -1,304 +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 $ plotLayout $ 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,-                                        plotLayout-                                      ) where--import Data.Maybe ( catMaybes )-import Data.Colour-import Data.Colour.Names--import Graphics.Rendering.Chart-import Graphics.Rendering.Chart.Gtk--styleColor :: Int -> AlphaColour Double-styleColor ind = colorSequence !! ind-    where colorSequence = cycle $ map opaque [blue, red, green, yellow, cyan, magenta, black]--styleSymbol :: Int -> PlotKind-styleSymbol ind = symbolSequence !! ind-    where symbolSequence = cycle [ Ex, HollowCircle, Square, Diamond,-                                   Triangle, DownTriangle, Plus, Star, FilledCircle ]---- When defaultLayout1 has been generalized, change this signature to --- [InternalPlot x y] -> Layout1 x y z-iplot :: [InternalPlot Double Double] -> Layout1 Double Double-iplot foobar = defaultLayout1 {-        layout1_plots_ = concat $ zipWith toplot (ip foobar) [0..]-    }-    where ip (xs@(IPX _ _):xyss) = map (\ys -> (xs,ys)) yss ++ ip rest-              where yss = takeWhile isIPY xyss-                    rest = dropWhile isIPY xyss-          ip (_:xyss) = ip xyss-          ip [] = []-          isIPY (IPY _ _) = True-          isIPY _ = False-          toplot (IPX xs _, IPY ys yks) ind = map Left plots-              where vs = zip xs ys-                    plots = case catMaybes $ map plotas yks of-                           [] -> [toPlot $ defaultPlotLines-                                   { plot_lines_title_ = name yks,-                                     plot_lines_values_ = [vs],-                                     plot_lines_style_ = solidLine 1 (styleColor ind) }]-                           xs -> xs-                    plotas Solid = Just $ toPlot $ defaultPlotLines-                                   { plot_lines_title_ = name yks,-                                     plot_lines_values_ = [vs],-                                     plot_lines_style_ = solidLine 1 (styleColor ind) }-                    plotas Dashed = Just $ toPlot $ defaultPlotLines-                                   { plot_lines_title_ = name yks,-                                     plot_lines_values_ = [vs],-                                     plot_lines_style_ = dashedLine 1 [10,10] (styleColor ind) }-                    plotas Dotted = Just $ toPlot $ defaultPlotLines-                                   { plot_lines_title_ = name yks,-                                     plot_lines_values_ = [vs],-                                     plot_lines_style_ = dashedLine 1 [1,11] (styleColor ind) }-                    plotas FilledCircle = Just $ toPlot $ defaultPlotPoints-                                          { plot_points_title_ = name yks,-                                            plot_points_values_ = vs,-                                            plot_points_style_=filledCircles 4 (styleColor ind) }-                    plotas HollowCircle = Just $ toPlot $ defaultPlotPoints-                                          { plot_points_title_ = name yks,-                                            plot_points_values_ = vs,-                                            plot_points_style_=hollowCircles 5 1 (styleColor ind) }-                    plotas Triangle = Just $ toPlot $ defaultPlotPoints-                                          { plot_points_title_ = name yks,-                                            plot_points_values_ = vs,-                                            plot_points_style_=hollowPolygon 7 1 3 False (styleColor ind) }-                    plotas DownTriangle = Just $ toPlot $ defaultPlotPoints-                                          { plot_points_title_ = name yks,-                                            plot_points_values_ = vs,-                                            plot_points_style_=hollowPolygon 7 1 3 True (styleColor ind) }-                    plotas Square = Just $ toPlot $ defaultPlotPoints-                                          { plot_points_title_ = name yks,-                                            plot_points_values_ = vs,-                                            plot_points_style_=hollowPolygon 7 1 4 False (styleColor ind) }-                    plotas Diamond = Just $ toPlot $ defaultPlotPoints-                                          { plot_points_title_ = name yks,-                                            plot_points_values_ = vs,-                                            plot_points_style_=hollowPolygon 7 1 4 True (styleColor ind) }-                    plotas Plus = Just $ toPlot $ defaultPlotPoints-                                          { plot_points_title_ = name yks,-                                            plot_points_values_ = vs,-                                            plot_points_style_=plusses 7 1 (styleColor ind) }-                    plotas Ex = Just $ toPlot $ defaultPlotPoints-                                          { plot_points_title_ = name yks,-                                            plot_points_values_ = vs,-                                            plot_points_style_=exes 7 1 (styleColor ind) }-                    plotas Star = Just $ toPlot $ defaultPlotPoints-                                          { plot_points_title_ = name yks,-                                            plot_points_values_ = vs,-                                            plot_points_style_=stars 7 1 (styleColor ind) }-                    plotas Symbols = plotas (styleSymbol ind)-                    plotas _ = Nothing--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 x y = IPY [y] [PlotKind] | IPX [x] [PlotKind]--newtype Layout1DDD = Layout1DDD { plotLayout :: Layout1 Double Double }-instance ToRenderable Layout1DDD where- toRenderable = toRenderable . plotLayout--uplot :: [UPlot] -> Layout1DDD-uplot us = Layout1DDD $ iplot $ nameDoubles $ evalfuncs us-    where nameDoubles :: [UPlot] -> [InternalPlot Double Double]-          nameDoubles (X xs:uus) = case grabName uus of-                                     (ks,uus') -> IPX (filter isValidNumber xs) ks : nameDoubles uus'-          nameDoubles (UDoubles xs:uus) = case grabName uus of-                                          (ks,uus') -> IPY (filter isValidNumber xs) ks : nameDoubles uus'-          nameDoubles (_:uus) = nameDoubles uus-          nameDoubles [] = []-          evalfuncs :: [UPlot] -> [UPlot]-          evalfuncs (UDoubles xs:uus) = X xs : map ef (takeWhile (not.isX) uus)-                                        ++ evalfuncs (dropWhile (not.isX) uus)-              where ef (UFunction f) = UDoubles (map f xs)-                    ef u = u-          evalfuncs (X xs:uus) = X xs : map ef (takeWhile (not.isX) uus)-                                 ++ evalfuncs (dropWhile (not.isX) uus)-              where ef (UFunction f) = UDoubles (map f xs)-                    ef u = u-          evalfuncs (u:uus) = u : evalfuncs uus-          evalfuncs [] = []-          grabName :: [UPlot] -> ([PlotKind],[UPlot])-          grabName (UString n:uus) = case grabName uus of-                                     (ks,uus') -> (str2k n++ks,uus')-          grabName (UKind ks:uus) = case grabName uus of-                                     (ks',uus') -> (ks++ks',uus')-          grabName uus = ([],uus)-          isX (X _) = True-          isX _ = False---- | 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 Layout1DDD 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---- | Save a plot as a png file-plotPNG :: PlotPNGType a => String -> a-plotPNG fn = plp fn []--class PlotPNGType t where-    plp :: FilePath -> [UPlot] -> t-instance (PlotArg a, PlotPNGType r) => PlotPNGType (a -> r) where-    plp fn args = \ a -> plp fn (toUPlot a ++ args)-instance PlotPNGType (IO a) where-    plp fn args = do renderableToPNGFile (toRenderable $ uplot (reverse args)) 640 480 fn-                     return undefined----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 x = [UFunction (realToFrac . x . realToFrac)]--instance (Real a, Real b, Fractional a, Fractional b) => IsPlot (a -> b) where-    toUPlot' = reverse . concatMap f-        where f x = [UFunction (realToFrac . x . realToFrac)]--instance PlotArg UPlot where-    toUPlot = (:[])--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,507 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# OPTIONS_GHC -XTemplateHaskell #-}---------------------------------------------------------------------------------- |--- Module      :  Graphics.Rendering.Chart.Types--- Copyright   :  (c) Tim Docker 2006--- 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 'Data.Accessor') for each field of the following data types:------    * 'CairoLineStyle'------    * 'CairoFontStyle'------ 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 :: Data.Accessor.Accessor D F--- @-----module Graphics.Rendering.Chart.Types(-    Rect(..),-    Point(..),-    Vector(..),--    RectSize,-    Range,--    mkrect,-    pvadd,-    pvsub,-    psub,-    vscale,-    within,--    RectEdge(..),-    Limit(..),-    PointMapFn,--    preserveCState,-    setClipRegion,-    strokeLines,-    moveTo,-    lineTo,-    rectPath,--    isValidNumber,-    maybeM,--    defaultColorSeq,--    setSourceColor,--    CairoLineStyle(..),-    solidLine,-    dashedLine,-    setLineStyle,--    CairoFillStyle(..),-    defaultPointStyle,-    solidFillStyle,-    setFillStyle,--    CairoFontStyle(..),-    defaultFontStyle,-    setFontStyle,--    CairoPointStyle(..),-    filledPolygon,-    hollowPolygon,-    filledCircles,-    hollowCircles,-    plusses,-    exes,-    stars,--    HTextAnchor(..),-    VTextAnchor(..),-    drawText,-    textSize,--    CRender(..),-    CEnv(..),-    runCRender,-    c,-    alignp,-    alignc,-    -    line_width,-    line_color,-    line_dashes,-    line_cap,-    line_join,--    font_name,-    font_size,-    font_slant,-    font_weight,-    font_color,--) where--import qualified Graphics.Rendering.Cairo as C-import Control.Monad.Reader-import Data.Accessor-import Data.Accessor.Template-import Data.Colour-import Data.Colour.SRGB-import Data.Colour.Names---- | A point in two dimensions-data Point = Point {-    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))--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--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----------------------------------------------------------------------------- | The environment present in the CRender Monad.-data CEnv = CEnv {-    -- | 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.-    cenv_point_alignfn :: Point -> Point,--    -- | A adjustment applied immediately prior to coordinates-    -- being transformed-    cenv_coord_alignfn :: Point -> Point-}---- | The reader monad containing context information to control--- the rendering process.-newtype CRender a = DR (ReaderT CEnv C.Render a)-  deriving (Functor, Monad, MonadReader CEnv)--runCRender :: CRender a -> CEnv -> C.Render a-runCRender (DR m) e = runReaderT m e--c :: C.Render a -> CRender a-c = DR . lift- --------------------------------------------------------------------------- | Abstract data type for the style of a plotted point------ The contained Cairo action draws a point in the desired--- style, at the supplied device coordinates.-newtype CairoPointStyle = CairoPointStyle (Point -> CRender ())---- | Data type for the style of a line-data CairoLineStyle = CairoLineStyle {-   line_width_ :: Double,-   line_color_ :: AlphaColour Double,-   line_dashes_ :: [Double],-   line_cap_ :: C.LineCap,-   line_join_ :: C.LineJoin-}---- | Abstract data type for a fill style------ The contained Cairo action sets the required fill--- style in the Cairo rendering state.-newtype CairoFillStyle = CairoFillStyle (CRender ())---- | Data type for a font-data CairoFontStyle = CairoFontStyle {-      font_name_ :: String,-      font_size_ :: Double,-      font_slant_ :: C.FontSlant,-      font_weight_ :: C.FontWeight,-      font_color_ :: AlphaColour Double-}--type Range = (Double,Double)-type RectSize = (Double,Double)--defaultColorSeq :: [AlphaColour Double]-defaultColorSeq = cycle $ map opaque [blue, red, green, yellow, cyan, magenta]--------------------------------------------------------------------------- Assorted helper functions in Cairo Usage--moveTo, lineTo :: Point -> CRender ()-moveTo p  = do-    p' <- alignp p-    c $ C.moveTo (p_x p') (p_y p')--alignp :: Point -> CRender Point-alignp p = do -    alignfn <- fmap cenv_point_alignfn ask-    return (alignfn p)--alignc :: Point -> CRender Point-alignc p = do -    alignfn <- fmap cenv_coord_alignfn ask-    return (alignfn p)--lineTo p = do-    p' <- alignp p-    c $ C.lineTo (p_x p') (p_y p')--setClipRegion p2 p3 = do    -    c $ C.moveTo (p_x p2) (p_y p2)-    c $ C.lineTo (p_x p2) (p_y p3)-    c $ C.lineTo (p_x p3) (p_y p3)-    c $ C.lineTo (p_x p3) (p_y p2)-    c $ C.lineTo (p_x p2) (p_y p2)-    c $ C.clip---- | stroke the lines between successive points-strokeLines :: [Point] -> CRender ()-strokeLines (p1:ps) = do-    c $ C.newPath-    moveTo p1-    mapM_ lineTo ps-    c $ C.stroke-strokeLines _ = return ()---- | make a path from a rectangle-rectPath :: Rect -> CRender ()-rectPath (Rect p1@(Point x1 y1) p3@(Point x2 y2)) = do-    c $ C.newPath-    moveTo p1 >> lineTo p2 >> lineTo p3 >> lineTo p4 >> lineTo p1-  where-    p2 = (Point x1 y2)-    p4 = (Point x2 y1)--setFontStyle f = do-    c $ C.selectFontFace (font_name_ f) (font_slant_ f) (font_weight_ f)-    c $ C.setFontSize (font_size_ f)-    c $ setSourceColor (font_color_ f)--setLineStyle ls = do-    c $ C.setLineWidth (line_width_ ls)-    c $ setSourceColor (line_color_ ls)-    c $ C.setLineCap (line_cap_ ls)-    c $ C.setLineJoin (line_join_ ls)-    case line_dashes_ ls of-      [] -> return ()-      ds -> c $ C.setDash ds 0--setFillStyle (CairoFillStyle s) = s--colourChannel :: (Floating a, Ord a) => AlphaColour a -> Colour a-colourChannel c = darken (recip (alphaChannel c)) (c `over` black)--setSourceColor c = let (RGB r g b) = toSRGB $ colourChannel c-                   in C.setSourceRGBA r g b (alphaChannel c)---- | Return the bounding rectancgle for a text string rendered--- in the current context.-textSize :: String -> CRender RectSize-textSize s = c $ 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 -> CRender ()-drawText hta vta (Point x y) s = c $ do-    te <- C.textExtents s-    fe <- C.fontExtents-    let lx = xadj hta (C.textExtentsWidth te)-    let ly = yadj vta te fe-    C.moveTo (x+lx) (y+ly)-    C.showText s-  where-    xadj HTA_Left   w = 0-    xadj HTA_Centre w = (-w/2)-    xadj HTA_Right  w = (-w)-    yadj VTA_Top    te fe = C.fontExtentsAscent fe-    yadj VTA_Centre te fe = - (C.textExtentsYbearing te) / 2-    yadj VTA_BaseLine te fe = 0-    yadj VTA_Bottom te fe = -(C.fontExtentsDescent fe)---- | Execute a rendering action in a saved context (ie bracketed--- between C.save and C.restore)-preserveCState :: CRender a -> CRender a-preserveCState a = do -  c $ C.save-  v <- a-  c $ C.restore-  return v--------------------------------------------------------------------------filledCircles ::-     Double -- ^ radius of circle-  -> AlphaColour Double -- ^ colour-  -> CairoPointStyle-filledCircles radius cl = CairoPointStyle rf-  where-    rf p = do-        (Point x y) <- alignp p-	c $ setSourceColor cl-        c $ C.newPath-	c $ C.arc x y radius 0 (2*pi)-	c $ C.fill--hollowCircles ::-     Double -- ^ radius of circle-  -> Double -- ^ thickness of line-  -> AlphaColour Double-  -> CairoPointStyle-hollowCircles radius w cl = CairoPointStyle rf-  where-    rf p = do-        (Point x y) <- alignp p-        c $ C.setLineWidth w-	c $ setSourceColor cl-        c $ C.newPath-	c $ C.arc x y radius 0 (2*pi)-	c $ C.stroke--hollowPolygon ::-     Double -- ^ radius of circle-  -> Double -- ^ thickness of line-  -> Int    -- ^ Number of vertices-  -> Bool   -- ^ Is right-side-up?-  -> AlphaColour Double-  -> CairoPointStyle-hollowPolygon radius w sides isrot cl = CairoPointStyle rf-  where rf p =-            do (Point x y ) <- alignp p-               c $ C.setLineWidth w-	       c $ setSourceColor cl-               c $ C.newPath-               let intToAngle n = if isrot-                                  then fromIntegral n * 2*pi / fromIntegral sides-                                  else (0.5 + fromIntegral n)*2*pi/fromIntegral sides-                   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 $ C.stroke--filledPolygon ::-     Double -- ^ radius of circle-  -> Int    -- ^ Number of vertices-  -> Bool   -- ^ Is right-side-up?-  -> AlphaColour Double-  -> CairoPointStyle-filledPolygon radius sides isrot cl = CairoPointStyle rf-  where rf p =-            do (Point x y ) <- alignp p-               c $ setSourceColor cl-               c $ C.newPath-               let intToAngle n = if isrot-                                  then fromIntegral n * 2*pi / fromIntegral sides-                                  else (0.5 + fromIntegral n)*2*pi/fromIntegral sides-                   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 $ C.fill--plusses ::-     Double -- ^ radius of circle-  -> Double -- ^ thickness of line-  -> AlphaColour Double-  -> CairoPointStyle-plusses radius w cl = CairoPointStyle rf-  where rf p = do (Point x y ) <- alignp p-                  c $ C.setLineWidth w-	          c $ setSourceColor cl-                  c $ C.newPath-                  c $ C.moveTo (x+radius) y-                  c $ C.lineTo (x-radius) y-                  c $ C.moveTo x (y-radius)-                  c $ C.lineTo x (y+radius)-	          c $ C.stroke--exes ::-     Double -- ^ radius of circle-  -> Double -- ^ thickness of line-  -> AlphaColour Double-  -> CairoPointStyle-exes radius w cl = CairoPointStyle rf-  where rad = radius / sqrt 2-        rf p = do (Point x y ) <- alignp p-                  c $ C.setLineWidth w-	          c $ setSourceColor cl-                  c $ C.newPath-                  c $ C.moveTo (x+rad) (y+rad)-                  c $ C.lineTo (x-rad) (y-rad)-                  c $ C.moveTo (x+rad) (y-rad)-                  c $ C.lineTo (x-rad) (y+rad)-	          c $ C.stroke--stars ::-     Double -- ^ radius of circle-  -> Double -- ^ thickness of line-  -> AlphaColour Double-  -> CairoPointStyle-stars radius w cl = CairoPointStyle rf-  where rad = radius / sqrt 2-        rf p = do (Point x y ) <- alignp p-                  c $ C.setLineWidth w-	          c $ setSourceColor cl-                  c $ C.newPath-                  c $ C.moveTo (x+radius) y-                  c $ C.lineTo (x-radius) y-                  c $ C.moveTo x (y-radius)-                  c $ C.lineTo x (y+radius)-                  c $ C.moveTo (x+rad) (y+rad)-                  c $ C.lineTo (x-rad) (y-rad)-                  c $ C.moveTo (x+rad) (y-rad)-                  c $ C.lineTo (x-rad) (y+rad)-	          c $ C.stroke--solidLine ::-     Double -- ^ width of line-  -> AlphaColour Double-  -> CairoLineStyle-solidLine w cl = CairoLineStyle w cl [] C.LineCapButt C.LineJoinMiter--dashedLine ::-     Double   -- ^ width of line-  -> [Double] -- ^ the dash pattern in device coordinates-  -> AlphaColour Double-  -> CairoLineStyle-dashedLine w ds cl = CairoLineStyle w cl ds C.LineCapButt C.LineJoinMiter--solidFillStyle ::-     AlphaColour Double-  -> CairoFillStyle-solidFillStyle cl = CairoFillStyle fn-   where fn = c $ setSourceColor cl--defaultPointStyle = filledCircles 1 $ opaque white--defaultFontStyle = CairoFontStyle {-   font_name_ = "sans",-   font_size_ = 10,-   font_slant_ = C.FontSlantNormal,-   font_weight_ = C.FontWeightNormal,-   font_color_ = opaque black-}--isValidNumber v = not (isNaN v) && not (isInfinite v)--maybeM v = maybe (return v)--------------------------------------------------------------------------- Template haskell to derive an instance of Data.Accessor.Accessor for each field-$( deriveAccessors ''CairoLineStyle )-$( deriveAccessors ''CairoFontStyle )-
+ 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,296 +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),-    (03,01,2007, 23.18, 69.90),-    (04,01,2007, 23.85, 71.06),-    (05,01,2007, 23.60, 69.80),-    (06,01,2007, 23.35, 68.80),-    (09,01,2007, 24.06, 70.18),-    (10,01,2007, 23.85, 69.15),-    (11,01,2007, 23.88, 69.35),-    (12,01,2007, 23.80, 70.19),-    (13,01,2007, 23.73, 70.50),-    (16,01,2007, 23.74, 71.05),-    (17,01,2007, 23.96, 71.94),-    (18,01,2007, 23.73, 70.25),-    (19,01,2007, 24.45, 72.50),-    (20,01,2007, 24.66, 74.00),-    (23,01,2007, 24.47, 73.25),-    (24,01,2007, 24.84, 74.25),-    (25,01,2007, 25.08, 73.96),-    (27,01,2007, 26.05, 76.10),-    (30,01,2007, 26.58, 78.45),-    (31,01,2007, 25.80, 75.82),-    (01,02,2007, 25.99, 75.21),-    (02,02,2007, 25.50, 74.98),-    (03,02,2007, 25.53, 74.75),-    (06,02,2007, 25.85, 75.57),-    (07,02,2007, 25.70, 75.06),-    (08,02,2007, 24.37, 72.75),-    (09,02,2007, 24.68, 72.77),-    (13,02,2007, 23.88, 70.95),-    (14,02,2007, 24.16, 72.37),-    (15,02,2007, 24.35, 71.84),-    (16,02,2007, 24.29, 71.89),-    (17,02,2007, 23.88, 71.65),-    (20,02,2007, 24.54, 74.90),-    (21,02,2007, 24.98, 75.50),-    (22,02,2007, 24.90, 73.24),-    (23,02,2007, 25.28, 74.69),-    (24,02,2007, 24.55, 72.20),-    (27,02,2007, 24.66, 73.00),-    (28,02,2007, 24.25, 71.20),-    (01,03,2007, 24.03, 70.25),-    (02,03,2007, 24.45, 70.50),-    (03,03,2007, 24.34, 70.35),-    (06,03,2007, 24.51, 70.85),-    (08,03,2007, 23.60, 67.95),-    (09,03,2007, 23.70, 68.65),-    (10,03,2007, 23.37, 67.50),-    (13,03,2007, 23.93, 70.36),-    (14,03,2007, 23.64, 69.45),-    (15,03,2007, 23.90, 69.40),-    (16,03,2007, 24.46, 70.90),-    (17,03,2007, 24.70, 71.25),-    (20,03,2007, 25.24, 72.85),-    (21,03,2007, 25.32, 73.08),-    (22,03,2007, 25.18, 72.99),-    (23,03,2007, 25.57, 74.34),-    (24,03,2007, 25.92, 75.23),-    (27,03,2007, 26.78, 77.05),-    (28,03,2007, 26.85, 77.13),-    (30,03,2007, 27.60, 77.96),-    (31,03,2007, 28.00, 78.85)-    ]
− tests/test.hs 
@@ -1,456 +0,0 @@-import qualified Graphics.Rendering.Cairo as C-import Graphics.Rendering.Chart-import Graphics.Rendering.Chart.Simple-import Graphics.Rendering.Chart.Gtk-import Graphics.Rendering.Chart.Grid--import System.Environment(getArgs)-import System.Time-import System.Random-import Data.Time.Calendar-import Data.Time.LocalTime-import Data.Accessor-import Data.Accessor.Tuple-import Data.Colour-import Data.Colour.Names-import Data.Colour.SRGB-import Data.List(sort,nub,scanl1)-import qualified Data.Map as Map-import Control.Monad-import Prices--data OutputType = Window | PNG | PS | PDF | SVG--chooseLineWidth Window = 1.0-chooseLineWidth PNG = 1.0-chooseLineWidth PDF = 0.25-chooseLineWidth PS = 0.25-chooseLineWidth SVG = 0.25--green1 = opaque $ sRGB 0.5 1 0.5-red1 = opaque $ sRGB 0.5 0.5 1-fwhite = solidFillStyle $ opaque white-fparchment = solidFillStyle $ opaque $ sRGB 1.0 0.99 0.90-------------------------------------------------------------------------test1Layout otype = layout-  where-    am :: Double -> Double-    am x = (sin (x*pi/45) + 1) / 2 * (sin (x*pi/5))--    sinusoid1 = plot_lines_values ^= [[ (x,(am x)) | x <- [0,(0.5)..400]]]-              $ plot_lines_style  ^= solidLine lineWidth (opaque blue)-              $ plot_lines_title ^="am"-              $ defaultPlotLines--    sinusoid2 = plot_points_style ^= filledCircles 2 (opaque red)-              $ plot_points_values ^= [ (x,(am x)) | x <- [0,7..400]]-              $ plot_points_title ^="am points"-              $ defaultPlotPoints--    layout = layout1_plots ^= [Left (toPlot sinusoid1),-			       Left (toPlot sinusoid2)]-           $ layout1_background ^= fparchment-           $ layout1_plot_background ^= Just fwhite-           $ defaultLayout1--    lineWidth = chooseLineWidth otype--test1 :: OutputType -> Renderable ()-test1 otype = toRenderable layout-  where-    layout = layout1_title ^= "Amplitude Modulation"-           $ (test1Layout otype)--test1a :: OutputType -> Renderable ()-test1a otype = fillBackground fwhite $ (gridToRenderable t)-  where-    t = weights (1,1) $ aboveN [ besideN [rf g1, rf g2, rf g3], -                                 besideN [rf g4, rf g5, rf g6] ]--    g1 = layout1_title ^= "minimal"-       $ layout1_bottom_axis ^: laxis_override ^= (axisGridHide.axisTicksHide)-       $ layout1_left_axis ^: laxis_override ^= (axisGridHide.axisTicksHide)-       $ test1Layout otype--    g2 = layout1_title ^= "with borders"-       $ layout1_bottom_axis ^: laxis_override ^= (axisGridHide.axisTicksHide)-       $ layout1_left_axis ^: laxis_override ^= (axisGridHide.axisTicksHide)-       $ layout1_top_axis ^: axisBorderOnly-       $ layout1_right_axis ^: axisBorderOnly-       $ test1Layout otype--    g3 = layout1_title ^= "default"-       $ test1Layout otype--    g4 = layout1_title ^= "tight grid"-       $ layout1_left_axis ^: laxis_generate ^= axis-       $ layout1_left_axis ^: laxis_override ^= axisGridAtTicks-       $ layout1_bottom_axis ^: laxis_generate ^= axis-       $ layout1_bottom_axis ^: laxis_override ^= axisGridAtTicks-       $ test1Layout otype-      where-        axis = autoScaledAxis (-            la_nLabels ^= 5 -          $ la_nTicks ^= 20-          $ defaultLinearAxis-          )--    g5 = layout1_title ^= "y linked"-       $ layout1_yaxes_control ^= linkAxes-       $ test1Layout otype--    g6 = layout1_title ^= "everything"-       $ layout1_yaxes_control ^= linkAxes-       $ layout1_top_axis ^: laxis_visible ^= const True-       $ test1Layout otype--    rf = tval.toRenderable--    axisBorderOnly = (laxis_visible ^= const True)-                   . (laxis_override ^=  (axisGridHide.axisTicksHide.axisLabelsHide))-------------------------------------------------------------------------test2 :: [(Int,Int,Int,Double,Double)] -> Bool -> OutputType -> Renderable ()-test2 prices showMinMax otype = toRenderable layout-  where--    lineStyle c = line_width ^= 3 * chooseLineWidth otype-                $ line_color ^= c-                $ defaultPlotLines ^. plot_lines_style--    limitLineStyle c = line_width ^= chooseLineWidth otype-                $ line_color ^= opaque c-                $ line_dashes ^= [5,10]-                $ defaultPlotLines ^. plot_lines_style--    price1 = plot_lines_style ^= lineStyle (opaque blue)-           $ plot_lines_values ^= [[ ((date d m y), v) | (d,m,y,v,_) <- prices]]-           $ plot_lines_title ^= "price 1"-           $ defaultPlotLines--    price2 = plot_lines_style ^= lineStyle (opaque green)-	   $ plot_lines_values ^= [[ ((date d m y), v) | (d,m,y,_,v) <- prices]]-           $ plot_lines_title ^= "price 2"-           $ defaultPlotLines--    (min1,max1) = (minimum [v | (_,_,_,v,_) <- prices],maximum [v | (_,_,_,v,_) <- prices])-    (min2,max2) = (minimum [v | (_,_,_,_,v) <- prices],maximum [v | (_,_,_,_,v) <- prices])-    limits | showMinMax = [ Left $ hlinePlot "min/max" (limitLineStyle blue) min1,-                            Left $ hlinePlot "" (limitLineStyle blue) max1,-                            Right $ hlinePlot "min/max" (limitLineStyle green) min2,-                            Right $ hlinePlot "" (limitLineStyle green) max2 ]-           | otherwise  = []--    bg = opaque $ sRGB 0 0 0.25-    fg = opaque white-    fg1 = opaque $ sRGB 0.0 0.0 0.15--    layout = layout1_title ^="Price History"-           $ layout1_background ^= solidFillStyle bg-           $ updateAllAxesStyles (axis_grid_style ^= solidLine 1 fg1)-           $ layout1_left_axis ^: laxis_override ^= axisGridHide-           $ layout1_right_axis ^: laxis_override ^= axisGridHide-           $ layout1_bottom_axis ^: laxis_override ^= axisGridHide- 	   $ layout1_plots ^= ([Left (toPlot price1), Right (toPlot price2)] ++ limits)-           $ layout1_grid_last ^= False-           $ setLayout1Foreground fg-           $ defaultLayout1--date dd mm yyyy = (LocalTime (fromGregorian (fromIntegral yyyy) mm dd) midnight)-------------------------------------------------------------------------test3 :: OutputType -> Renderable ()-test3 otype = toRenderable layout-  where--    price1 = plot_fillbetween_style ^= solidFillStyle green1-           $ plot_fillbetween_values ^= [ (date d m y,(0,v2)) | (d,m,y,v1,v2) <- prices]-           $ plot_fillbetween_title ^= "price 1"-           $ defaultPlotFillBetween --    price2 = plot_fillbetween_style ^= solidFillStyle red1-           $ plot_fillbetween_values ^= [ (date d m y,(0,v1)) | (d,m,y,v1,v2) <- prices]-           $ plot_fillbetween_title ^= "price 2"-           $ defaultPlotFillBetween--    layout = layout1_title ^= "Price History"-           $ layout1_grid_last ^= True- 	   $ layout1_plots ^= [Left (toPlot price1),-                               Left (toPlot price2)]-           $ defaultLayout1------------------------------------------------------------------------        -test4 :: Bool -> Bool -> OutputType -> Renderable ()-test4 xrev yrev otype = toRenderable layout-  where--    points = plot_points_style ^= filledCircles 3 (opaque red)-           $ plot_points_values ^= [ (x, LogValue (10**x)) | x <- [0.5,1,1.5,2,2.5] ]-           $ plot_points_title ^= "values"-           $ defaultPlotPoints--    lines = plot_lines_values ^= [ [(x, LogValue (10**x)) | x <- [0,3]] ]-          $ plot_lines_title ^= "values"-          $ defaultPlotLines--    layout = layout1_title ^= "Log/Linear Example"-           $ layout1_bottom_axis ^: laxis_title ^= "horizontal"-           $ layout1_bottom_axis ^: laxis_reverse ^= xrev-           $ layout1_left_axis ^: laxis_title ^= "vertical"-           $ layout1_left_axis ^: laxis_reverse ^= yrev-	   $ layout1_plots ^= [Left (toPlot points), Left (toPlot lines) ]-           $ defaultLayout1--------------------------------------------------------------------------- Example thanks to Russell O'Connor--test5 :: OutputType -> Renderable ()-test5 otype = toRenderable (layout 1001 (trial bits) :: Layout1 Double LogValue)-  where-    bits = randoms $ mkStdGen 0--    layout n t = layout1_title ^= "Simulation of betting on a biased coin"-               $ layout1_plots ^= [-                      Left (toPlot (plot "f=0.05" s1 n 0 (t 0.05))),-                      Left (toPlot (plot "f=0.1" s2 n 0 (t 0.1)))-                     ]-               $ defaultLayout1--    plot tt s n m t = plot_lines_style ^= s-                 $ plot_lines_values ^=-                       [[(fromIntegral x, LogValue y) | (x,y) <--                         filter (\(x,_)->x `mod` (m+1)==0) $ take n $ zip [0..] t]]-                 $ plot_lines_title ^= tt-                 $ defaultPlotLines --    b = 0.1--    trial bits frac = scanl (*) 1 (map f bits)-      where -        f True = (1+frac*(1+b))-        f False = (1-frac)--    s1 = solidLine lineWidth $ opaque green-    s2 = solidLine lineWidth $ opaque blue--    lineWidth = chooseLineWidth otype-------------------------------------------------------------------------        --- Test the Simple interface--test6 :: OutputType -> Renderable ()-test6 otype = toRenderable (plotLayout pp){layout1_title_="Graphics.Rendering.Chart.Simple example"}-  where-    pp = plot xs sin "sin"-                 cos "cos" "o"-                 (sin.sin.cos) "sin.sin.cos" "."-                 (/3) "- "-                 (const 0.5)-                 [0.1,0.7,0.5::Double] "+"-    xs = [0,0.3..3] :: [Double]-------------------------------------------------------------------------test7 :: OutputType -> Renderable ()-test7 otype = toRenderable layout-  where-    vals :: [(Double,Double,Double,Double)]-    vals = [ (x,sin (exp x),sin x/2,cos x/10) | x <- [1..20]]-    bars = plot_errbars_values ^= [symErrPoint x y dx dy | (x,y,dx,dy) <- vals]-         $ plot_errbars_title ^="test"-         $ defaultPlotErrBars--    points = plot_points_style ^= filledCircles 2 (opaque red)-	   $ plot_points_values ^= [(x,y) |  (x,y,dx,dy) <- vals]-           $ plot_points_title ^= "test"-           $ defaultPlotPoints--    layout = layout1_title ^= "errorbars example"-           $ layout1_plots ^= [Left (toPlot bars),-                               Left (toPlot points)]-           $ defaultLayout1--------------------------------------------------------------------------test8 :: OutputType -> Renderable ()-test8 otype = toRenderable layout-  where-    values = [ ("eggs",38,e), ("milk",45,e), ("bread",11,e1), ("salmon",8,e) ]-    e = 0-    e1 = 25-    layout = pie_title ^= "Pie Chart Example"-           $ pie_plot ^: pie_data ^= [ defaultPieItem{pitem_value_=v,pitem_label_=s,pitem_offset_=o} -                                       | (s,v,o) <- values ]-           $ defaultPieLayout---------------------------------------------------------------------------test9 :: OutputType -> Renderable ()-test9 otype = fillBackground fwhite $ (gridToRenderable t)-  where-    t = weights (1,1) $ aboveN [ besideN [rf g0, rf g1, rf g2],-                                 besideN [rf g3, rf g4, rf g5] ]--    g0 = layout "clustered 1"-       $ plot_bars_style ^= BarsClustered-       $ plot_bars_spacing ^= BarsFixWidth 25-       $ bars1--    g1 = layout "clustered / fix width "-       $ plot_bars_style ^= BarsClustered-       $ plot_bars_spacing ^= BarsFixWidth 25-       $ bars2--    g2 = layout "clustered / fix gap "-       $ plot_bars_style ^= BarsClustered-       $ plot_bars_spacing ^= BarsFixGap 10-       $ bars2--    g3 = layout "stacked 1"-       $ plot_bars_style ^= BarsStacked-       $ plot_bars_spacing ^= BarsFixWidth 25-       $ bars1--    g4 = layout "stacked / fix width"-       $ plot_bars_style ^= BarsStacked-       $ plot_bars_spacing ^= BarsFixWidth 25-       $ bars2--    g5 = layout "stacked / fix gap"-       $ plot_bars_style ^= BarsStacked-       $ plot_bars_spacing ^= BarsFixGap 10-       $ bars2--    rf = tval.toRenderable--    alabels = [ "Jun", "Jul", "Aug", "Sep", "Oct" ]---    layout title bars = layout1_title ^= title-           $ layout1_bottom_axis ^: laxis_generate ^= autoIndexAxis alabels-           $ layout1_left_axis ^: laxis_override ^= (axisGridHide.axisTicksHide)-           $ layout1_plots ^= [ Left (plotBars bars) ]-           $ defaultLayout1 :: Layout1 PlotIndex Double--    bars1 = plot_bars_titles ^= ["Cash"]-          $ plot_bars_values ^= addIndexes [[20],[45],[30],[70]]-          $ defaultPlotBars--    bars2 = plot_bars_titles ^= ["Cash","Equity"]-          $ plot_bars_values ^= addIndexes [[20,45],[45,30],[30,20],[70,25]]-          $ defaultPlotBars-----------------------------------------------------------------------------------test10 :: [(Int,Int,Int,Double,Double)] -> OutputType -> Renderable ()-test10 prices otype = toRenderable layout-  where--    lineStyle c = line_width ^= 3 * chooseLineWidth otype-                $ line_color ^= c-                $ defaultPlotLines ^. plot_lines_style--    price1 = plot_lines_style ^= lineStyle (opaque blue)-           $ plot_lines_values ^= [[ ((date d m y), v) | (d,m,y,v,_) <- prices]]-           $ plot_lines_title ^= "price 1"-           $ defaultPlotLines--    price1_area = plot_fillbetween_values ^= [((date d m y), (v * 0.95, v * 1.05)) | (d,m,y,v,_) <- prices]-                $ plot_fillbetween_style  ^= solidFillStyle (withOpacity blue 0.2)-                $ defaultPlotFillBetween--    price2 = plot_lines_style ^= lineStyle (opaque red)-	   $ plot_lines_values ^= [[ ((date d m y), v) | (d,m,y,_,v) <- prices]]-           $ plot_lines_title ^= "price 2"-           $ defaultPlotLines--    price2_area = plot_fillbetween_values ^= [((date d m y), (v * 0.95, v * 1.05)) | (d,m,y,_,v) <- prices]-                $ plot_fillbetween_style  ^= solidFillStyle (withOpacity red 0.2)-                $ defaultPlotFillBetween--    fg = opaque black-    fg1 = opaque $ sRGB 0.0 0.0 0.15--    layout = layout1_title ^="Price History"-           $ layout1_background ^= solidFillStyle (opaque white)-           $ layout1_right_axis ^: laxis_override ^= axisGridHide- 	   $ layout1_plots ^= [ Left (toPlot price1_area), Right (toPlot price2_area)-                              , Left (toPlot price1),      Right (toPlot price2)-                              ]-           $ setLayout1Foreground fg-           $ defaultLayout1--------------------------------------------------------------------------- a quick test to display labels with all combinations--- of anchors-misc1 rot otype = fillBackground fwhite $ (gridToRenderable t)-  where-    t = weights (1,1) $ aboveN [ besideN [tval (lb h v) | h <- hs] | v <- vs ]-    lb h v = addMargins (20,20,20,20) $ fillBackground fblue $ crossHairs $ rlabel fs h v rot s-    s = "Labelling"-    hs = [HTA_Left, HTA_Centre, HTA_Right]-    vs = [VTA_Top, VTA_Centre, VTA_Bottom]-    fwhite = solidFillStyle $ opaque white-    fblue = solidFillStyle $ opaque $ sRGB 0.8 0.8 1-    fs = defaultFontStyle{font_size_=20,font_weight_=C.FontWeightBold}-    crossHairs r =Renderable {-      minsize = minsize r,-      render = \sz@(w,h) -> do-          let xa = w / 2-          let ya = h / 2-          strokeLines [Point 0 ya,Point w ya]-          strokeLines [Point xa 0,Point xa h]-          render r sz-    }------------------------------------------------------------------------        -allTests :: [ (String, OutputType -> Renderable ()) ]-allTests =-     [ ("test1",  test1)-     , ("test1a", test1a)-     , ("test2a", test2 prices False)-     , ("test2b", test2 (filterPrices (date 1 1 2005) (date 31 12 2005)) False)-     , ("test2c", test2 (filterPrices (date 1 5 2005) (date 1 7 2005)) False)-     , ("test2d", test2 (filterPrices (date 1 1 2006) (date 10 1 2006)) False)-     , ("test2e", test2 (filterPrices (date 1 8 2005) (date 31 8 2005)) True)-     , ("test3", test3)-     , ("test4a", test4 False False)-     , ("test4b", test4 True False)-     , ("test4c", test4 False True)-     , ("test5", test5)-     , ("test6", test6)-     , ("test7", test7)-     , ("test8", test8)-     , ("test9", test9)-     , ("test10", test10 (filterPrices (date 1 1 2005) (date 31 12 2005)))-     , ("misc1", misc1 0)-     , ("misc1a", misc1 45)-     ]--filterPrices t1 t2 = [ v | v@(d,m,y,_,_) <- prices, let t = date d m y in t >= t1 && t <= t2]--main = do-    args <- getArgs-    main1 args--main1 :: [String] -> IO ()-main1 ("--png":tests) = showTests tests renderToPNG-main1 ("--pdf":tests) = showTests tests renderToPDF-main1 ("--svg":tests) = showTests tests renderToSVG-main1 ("--ps":tests) = showTests tests renderToPS-main1 tests = showTests tests renderToWindow--showTests :: [String] -> ((String,OutputType -> Renderable ()) -> IO()) -> IO ()-showTests tests ofn = mapM_ ofn (filter (match tests) allTests)--match :: [String] -> (String,a) -> Bool-match [] t = True-match ts t = (fst t) `elem` ts--renderToWindow (n,ir) = renderableToWindow (ir Window) 640 480-renderToPNG (n,ir) = renderableToPNGFile (ir PNG) 640 480 (n ++ ".png")-renderToPS (n,ir) = renderableToPSFile (ir PS) 640 480 (n ++ ".ps")-renderToPDF (n,ir) = renderableToPDFFile (ir PDF) 640 480 (n ++ ".pdf")-renderToSVG (n,ir) = renderableToSVGFile (ir SVG) 640 480 (n ++ ".svg")