packages feed

Chart 1.1 → 1.9.5

raw patch · 40 files changed

Files

Chart.cabal view
@@ -1,26 +1,40 @@ Name: Chart-Version: 1.1+Version: 1.9.5 License: BSD3 License-file: LICENSE-Copyright: Tim Docker, 2006-2010+Copyright: Tim Docker, 2006-2014 Author: Tim Docker <tim@dockerz.net> Maintainer: Tim Docker <tim@dockerz.net> 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  library+  default-language: Haskell98   Build-depends: base >= 3 && < 5                , old-locale-               , time, mtl, array-               , lens >= 3.9 && < 3.11+               , time, array+               , lens >= 3.9 && < 5.3                , colour >= 2.2.1 && < 2.4-               , data-default-class < 0.1+               , data-default-class < 0.2+               , mtl >= 2.0 && < 2.4                , operational >= 0.2.2 && < 0.3+               , vector >=0.9 && <0.14 +  if !impl(ghc >= 8.0)+    build-depends: semigroups >= 0.18.4 && <0.19+++  Ghc-options: -Wall -fno-warn-orphans+   Exposed-modules:         Graphics.Rendering.Chart,         Graphics.Rendering.Chart.Drawing,@@ -31,13 +45,12 @@         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.Simple,-        Graphics.Rendering.Chart.Simple.Internal,         Graphics.Rendering.Chart.Grid,         Graphics.Rendering.Chart.Plot,         Graphics.Rendering.Chart.Plot.Types,@@ -49,13 +62,17 @@         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.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,32 +1,40 @@ ---------------------------------------------------------------------------- -- | -- 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 '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 'Layout1'+-- Currently, there are three types of charts: -----     *  a pie chart can be is created by applying---      'toRenderable' to a value of type '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.--- For example, '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. -- ----------------------------------------------------------------------------- @@ -39,6 +47,7 @@     module Graphics.Rendering.Chart.Axis,     module Graphics.Rendering.Chart.Plot,     module Graphics.Rendering.Chart.Legend,+    module Graphics.Rendering.Chart.Backend.Types  ) where @@ -49,3 +58,4 @@ import Graphics.Rendering.Chart.Axis import Graphics.Rendering.Chart.Plot import Graphics.Rendering.Chart.Legend+import Graphics.Rendering.Chart.Backend.Types
Graphics/Rendering/Chart/Axis.hs view
@@ -11,7 +11,7 @@     module Graphics.Rendering.Chart.Axis.Types,     module Graphics.Rendering.Chart.Axis.Floating,     module Graphics.Rendering.Chart.Axis.Int,-    module Graphics.Rendering.Chart.Axis.LocalTime,+    module Graphics.Rendering.Chart.Axis.Time,     module Graphics.Rendering.Chart.Axis.Unit,     module Graphics.Rendering.Chart.Axis.Indexed, ) where@@ -19,6 +19,6 @@ import Graphics.Rendering.Chart.Axis.Types import Graphics.Rendering.Chart.Axis.Floating import Graphics.Rendering.Chart.Axis.Int-import Graphics.Rendering.Chart.Axis.LocalTime+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
@@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Graphics.Rendering.Chart.Axis.Floating--- Copyright   :  (c) Tim Docker 2010+-- Copyright   :  (c) Tim Docker 2010, 2014 -- License     :  BSD-style (see chart/COPYRIGHT) -- -- Calculate and render floating value axes@@ -10,14 +10,14 @@  {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}  module Graphics.Rendering.Chart.Axis.Floating(     Percent(..),     LinearAxisParams(..),     LogValue(..),     LogAxisParams(..),-    defaultLinearAxis,-    defaultLogAxis,     scaledAxis,     autoScaledAxis,     autoScaledLogAxis,@@ -30,22 +30,29 @@     loga_labelf ) where -import Data.List(minimumBy)+import Data.List(minimumBy, nub) import Data.Ord (comparing) import Data.Default.Class-import Numeric (showFFloat)+import Numeric (showEFloat, showFFloat)  import Control.Lens import Graphics.Rendering.Chart.Geometry-import Graphics.Rendering.Chart.Drawing 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 defaultLinearAxis+    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}@@ -57,11 +64,11 @@ instance PlotValue Percent where     toValue  = unPercent     fromValue= Percent-    autoAxis = autoScaledAxis defaultLinearAxis{-_la_labelf=-}+    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 Double+newtype LogValue = LogValue {unLogValue :: Double}     deriving (Eq, Ord, Num, Real, Fractional, RealFrac, Floating, RealFloat)  instance Show LogValue where@@ -70,8 +77,98 @@ instance PlotValue LogValue where     toValue (LogValue x) = log x     fromValue d          = LogValue (exp d)-    autoAxis             = autoScaledLogAxis defaultLogAxis+    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@@ -79,7 +176,7 @@  data LinearAxisParams a = LinearAxisParams {     -- | The function used to show the axes labels.-    _la_labelf  :: a -> String,+    _la_labelf  :: [a] -> [String],      -- | The target number of labels to be shown.     _la_nLabels :: Int,@@ -88,27 +185,23 @@     _la_nTicks  :: Int } -{-# DEPRECATED defaultLinearAxis "Use the according Data.Default instance!" #-}-defaultLinearAxis :: (Show a, RealFloat a) => LinearAxisParams a-defaultLinearAxis = def- instance (Show a, RealFloat a) => Default (LinearAxisParams a) where-  def = LinearAxisParams -    { _la_labelf    = showD+  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 (min,max) ps0 = makeAxis' realToFrac realToFrac+scaledAxis lap rs@(minV,maxV) ps0 = makeAxis' realToFrac realToFrac                                          (_la_labelf lap) (labelvs,tickvs,gridvs)   where     ps        = filter isValidNumber ps0     range []  = (0,1)-    range _   | min == max = if min==0 then (-1,1) else-                             let d = abs (min * 0.01) in (min-d,max+d)-              | otherwise  = (min,max)+    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)@@ -118,25 +211,26 @@ -- | Generate a linear axis automatically, scaled appropriately for the -- input data. autoScaledAxis :: RealFloat a => LinearAxisParams a -> AxisFn a-autoScaledAxis lap ps0 = scaledAxis lap (min,max) ps0+autoScaledAxis lap ps0 = scaledAxis lap rs ps   where-    (min,max) = (minimum ps0,maximum ps0)+    ps = filter isValidNumber ps0+    rs = (minimum ps,maximum ps)  steps :: RealFloat a => a -> (a,a) -> [Rational]-steps nSteps (min,max) = map ((s*) . fromIntegral) [min' .. max']+steps nSteps rs@(minV,maxV) = map ((s*) . fromIntegral) [min' .. max']   where-    s    = chooseStep nSteps (min,max)-    min' = floor   $ realToFrac min / s-    max' = ceiling $ realToFrac max / s-    n    = (max' - min')-+    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) steps+chooseStep nsteps (x1,x2) = minimumBy (comparing proximity) stepVals   where     delta = x2 - x1-    mult  = 10 ^^ (floor $ log10 $ delta / nsteps)-    steps = map (mult*) [0.1,0.2,0.25,0.5,1.0,2.0,2.5,5.0,10,20,25,50]+    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,@@ -146,99 +240,101 @@ autoSteps nSteps vs = map fromRational $ steps (fromIntegral nSteps) r   where     range []  = (0,1)-    range _   | min == max = (min-0.5,min+0.5)-              | otherwise  = (min,max)-    (min,max) = (minimum ps,maximum ps)+    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  ---------------------------------------------------------------------- -{-# DEPRECATED defaultLogAxis "Use the according Data.Default instance!" #-}-defaultLogAxis :: (Show a, RealFloat a) => LogAxisParams a-defaultLogAxis = def- instance (Show a, RealFloat a) => Default (LogAxisParams a) where-  def = LogAxisParams -    { _loga_labelf = showD+  def = LogAxisParams+    { _loga_labelf = showDs     } --- | Generate a log axis automatically, scaled appropriate for the+-- | 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 rgridvs)+              (_loga_labelf lap) (wrap rlabelvs, wrap rtickvs, wrap rlabelvs)         where           ps        = filter (\x -> isValidNumber x && 0 < x) ps0-          (min,max) = (minimum ps,maximum ps)+          (minV,maxV) = (minimum ps,maximum ps)           wrap      = map fromRational           range []  = (3,30)-          range _   | min == max = (realToFrac $ min/3, realToFrac $ max*3)-                    | otherwise  = (realToFrac $ min,   realToFrac $ max)-          (rlabelvs, rtickvs, rgridvs) = logTicks (range ps)+          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+    _loga_labelf :: [a] -> [String] }  {-  Rules: Do not subdivide between powers of 10 until all powers of 10-          get a major ticks.+          get 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)+          5 gets a major tick+          (i.e. the major ticks need to be a subset of the minor ticks) -}-logTicks :: Range -> ([Rational],[Rational],[Rational])-logTicks (low,high) = (major,minor,major)+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) = properFraction (log10 a) in-               (minimum (10:filter (\x -> r <= log10 (fromRational x)) l))*10^^i+               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))]+  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)-  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)++  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'    = 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')--log10 :: (Floating a) => a -> a-log10 = logBase 10+  ratio' :: Double+  ratio' = fromRational (h'/l')+  filterX = filter (\x -> l'<=x && x <=h') . powers (dl',dh') -frac x | 0 <= b    = (a,b)-       | otherwise = (a-1,b+1)- where-  (a,b) = properFraction x+  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
@@ -1,19 +1,21 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Graphics.Rendering.Chart.Axis.Unit--- Copyright   :  (c) Tim Docker 2010+-- 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@@ -30,23 +32,26 @@  -- | 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)+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 => [String] -> [i] -> AxisData i-autoIndexAxis labels vs = AxisData {+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    = [],-    _axis_labels   = [filter (\(i,l) -> i >= imin && i <= imax)-                            (zip [0..] labels)],+    _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 r z = invLinMap round fromIntegral (imin, imax) r z+    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
@@ -1,10 +1,11 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Graphics.Rendering.Chart.Axis.Int--- Copyright   :  (c) Tim Docker 2010+-- 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,@@ -13,8 +14,9 @@ ) 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.Drawing import Graphics.Rendering.Chart.Axis.Types import Graphics.Rendering.Chart.Axis.Floating @@ -23,6 +25,51 @@     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@@ -30,25 +77,25 @@  defaultIntAxis :: (Show a) => LinearAxisParams a defaultIntAxis  = LinearAxisParams {-    _la_labelf  = show,+    _la_labelf  = map show,     _la_nLabels = 5,     _la_nTicks  = 10 }  autoScaledIntAxis :: (Integral i, PlotValue i) =>                      LinearAxisParams i -> AxisFn i-autoScaledIntAxis lap ps = scaledIntAxis lap (min,max) ps+autoScaledIntAxis lap ps = scaledIntAxis lap rs ps   where-    (min,max) = (minimum ps,maximum ps)+    rs = (minimum ps,maximum ps)  scaledIntAxis :: (Integral i, PlotValue i) =>                  LinearAxisParams i -> (i,i) -> AxisFn i-scaledIntAxis lap (min,max) ps =+scaledIntAxis lap (minI,maxI) ps =     makeAxis (_la_labelf lap) (labelvs,tickvs,gridvs)   where     range []  = (0,1)-    range _   | min == max = (fromIntegral $ min-1, fromIntegral $ min+1)-              | otherwise  = (fromIntegral $ min,   fromIntegral $ max)+    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)@@ -62,16 +109,25 @@   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+    (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 (min,max) = takeWhile (<b) [a,a+size..] ++ [b]+    steps size (minV,maxV) = takeWhile (<b) [a,a+size..] ++ [b]       where-        a = (floor   (min / fromIntegral size)) * size-        b = (ceiling (max / fromIntegral size)) * size+        a = (floor   (minV / fromIntegral size)) * size+        b = (ceiling (maxV / fromIntegral size)) * size
Graphics/Rendering/Chart/Axis/LocalTime.hs view
@@ -1,37 +1,43 @@+{-# LANGUAGE CPP #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Graphics.Rendering.Chart.Axis.LocalTime--- Copyright   :  (c) Tim Docker 2010+-- Copyright   :  (c) Tim Docker 2010, 2014 -- License     :  BSD-style (see chart/COPYRIGHT) -- -- Calculate and render time axes -module Graphics.Rendering.Chart.Axis.LocalTime(+module Graphics.Rendering.Chart.Axis.LocalTime+    {-# DEPRECATED "Use Graphics.Rendering.Chart.Axis.Time module" #-}+    (+    TimeSeq,+    TimeLabelFn,+    TimeLabelAlignment(..),+     timeAxis,     autoTimeAxis,-    days, months, years-) where- ++    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 Data.Fixed import System.Locale (defaultTimeLocale)-import Control.Monad-import Data.List+#endif+import Data.Fixed import Control.Lens-import Data.Colour (opaque)-import Data.Colour.Names (black, lightgrey)-import Data.Ord (comparing) -import Graphics.Rendering.Chart.Geometry-import Graphics.Rendering.Chart.Drawing-import Graphics.Rendering.Chart.Renderable import Graphics.Rendering.Chart.Axis.Types--instance PlotValue LocalTime where-    toValue    = doubleFromLocalTime-    fromValue  = localTimeFromDouble-    autoAxis   = autoTimeAxis+import Graphics.Rendering.Chart.Axis.Time ()  ---------------------------------------------------------------------- @@ -55,21 +61,21 @@ type TimeSeq = LocalTime-> ([LocalTime],[LocalTime])  coverTS :: TimeSeq -> LocalTime -> LocalTime -> [LocalTime]-coverTS tseq min max = min' ++ enumerateTS tseq min max ++ max'+coverTS tseq minT maxT = min' ++ enumerateTS tseq minT maxT ++ 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))+    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 min max =-    reverse (takeWhile (>=min) ts1)  ++ takeWhile (<=max) ts2+enumerateTS tseq minT maxT =+    reverse (takeWhile (>=minT) ts1)  ++ takeWhile (<=maxT) ts2   where-    (ts1,ts2) = tseq min+    (ts1,ts2) = tseq minT  elemTS :: LocalTime -> TimeSeq -> Bool elemTS t tseq = case tseq t of-    (_,(t0:_)) | t == t0 -> True-    _                    -> False+    (_,t0:_) | t == t0 -> True+    _                  -> False  -- | How to display a time type TimeLabelFn = LocalTime -> String@@ -78,15 +84,24 @@                         | BetweenTicks                         deriving (Show) --- | Create an 'AxisFn' to for a time axis.  The first 'TimeSeq' sets the---   minor ticks, and the ultimate range will be aligned to its elements.---   The second 'TimeSeq' sets the labels and grid.  The third 'TimeSeq'---   sets the second line of labels.  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 -> TimeLabelAlignment -> -                       TimeSeq -> TimeLabelFn -> TimeLabelAlignment -> -            AxisFn LocalTime+-- | 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'),@@ -94,28 +109,28 @@     _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-    (min,max)    = case pts of+    (minT,maxT)  = 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-    ctimes       = coverTS cseq min max+    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)+    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 m2 = m1+    align UnderTicks   m1 _  = m1      avg m1 m2    = localTimeFromDouble $ m1' + (m2' - m1')/2      where@@ -146,28 +161,27 @@ secondSeq step t = (iterate rev t1, tail (iterate fwd t1))   where h0       = todHour (localTimeOfDay t)         m0       = todMin  (localTimeOfDay t)-        s0       = todSec  (localTimeOfDay t) `truncateTo` (fromIntegral 1 / 1000)+        s0       = todSec  (localTimeOfDay t) `truncateTo` (1 / 1000)         t0       = LocalTime (localDay t) (TimeOfDay h0 m0 s0)-        t1       = if t0 < t then t0 else (rev t0)+        t1       = if t0 < t then t0 else rev t0         rev      = addTod 0 0 (negate step)-        fwd      = addTod 0 0 (step)+        fwd      = addTod 0 0 step  millis1, millis10, millis100, seconds, fiveSeconds  :: TimeSeq-millis1 = secondSeq (fromIntegral 1 / 1000)-millis10 = secondSeq (fromIntegral 1 / 100)-millis100 = secondSeq (fromIntegral 1 / 10)-seconds = secondSeq (fromIntegral 1)-fiveSeconds = secondSeq (fromIntegral 5)+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) (fromIntegral 0)-        fwd      = addTod 0 step    (fromIntegral 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@@ -178,15 +192,15 @@ 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 (fromIntegral 0)-        fwd      = addTod 1    0 (fromIntegral 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)+        t1       = if toTime t0 < t then t0 else rev t0         rev      = pred         fwd      = succ         toTime d = LocalTime d midnight@@ -194,8 +208,8 @@ -- | 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)+  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@@ -203,15 +217,15 @@ -- | 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)+  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 t = ([],[])+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@@ -220,9 +234,9 @@ 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 +    | 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 +    | 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
+ 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
@@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Graphics.Rendering.Chart.Axis.Types--- Copyright   :  (c) Tim Docker 2006+-- Copyright   :  (c) Tim Docker 2006, 2014 -- License     :  BSD-style (see chart/COPYRIGHT) -- -- Type definitions for Axes@@ -18,7 +18,6 @@     AxisFn,      defaultAxisLineStyle,-    defaultAxisStyle,     defaultGridLineStyle,      makeAxis,@@ -57,13 +56,9 @@  ) where -import Data.Time-import Data.Fixed-import Data.Maybe-import System.Locale (defaultTimeLocale) import Control.Monad import Data.List(sort,intersperse)-import Control.Lens+import Control.Lens hiding (at, re) import Data.Colour (opaque) import Data.Colour.Names (black, lightgrey) import Data.Default.Class@@ -182,17 +177,17 @@ axisLabelsOverride  :: [(x,String)] -> AxisData x -> AxisData x axisLabelsOverride o ad = ad{ _axis_labels = [o] } -minsizeAxis :: AxisT x -> ChartBackend RectSize-minsizeAxis (AxisT at as rev ad) = do-    let labelVis = _axis_show_labels $ _axis_visibility $ ad-        tickVis  = _axis_show_ticks  $ _axis_visibility $ ad+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) $ do+    labelSizes <- withFontStyle (_axis_label_style as) $                     mapM (mapM textDimension) labels      let ag      = _axis_label_gap as-    let tsize   = maximum ([0] ++ [ max 0 (-l) | (v,l) <- ticks ])+    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)@@ -201,24 +196,25 @@     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)+                    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 -> ChartBackend (Double,Double)-axisOverhang (AxisT at as rev ad) = do+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) $ do+    labelSizes <- withFontStyle (_axis_label_style as) $       mapM textDimension labels     case labelSizes of       []  -> return (0,0)@@ -232,18 +228,18 @@                  E_Left   -> ohangv                  E_Right  -> ohangh -renderAxis :: AxisT x -> RectSize -> ChartBackend (PickFn x)-renderAxis at@(AxisT et as rev ad) sz = do+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) $ do +  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) $ do-    withLineStyle (ls {_line_cap = LineCapButt}) $ do+  when (_axis_show_ticks vis) $ +    withLineStyle (ls {_line_cap = LineCapButt}) $        mapM_ drawTick (_axis_ticks ad)-  when (_axis_show_labels vis) $ do+  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@@ -253,24 +249,24 @@  where    (sx,sy,ex,ey,tp,axisPoint,invAxisPoint) = axisMapping at sz -   drawTick (value,length) =+   drawTick (value,len) =        let t1 = axisPoint value-           t2 = t1 `pvadd` (vscale length tp)+           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))+       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 (\n -> eachNth n rects) [0 .. length rects]+              $ map (`eachNth` rects) [0 .. length rects]     labelDrawRect (value,s) = do-       let pt = axisPoint value `pvadd` (awayFromAxis ag)+       let pt = axisPoint value `pvadd` awayFromAxis ag        r <- textDrawRect hta vta pt s        return (hBufferRect r,(value,s)) @@ -279,7 +275,7 @@         mapM_ drawLabel labels'      where        drawLabel (value,s) = do-           drawTextA hta vta (axisPoint value `pvadd` (awayFromAxis offset)) s+           drawTextA hta vta (axisPoint value `pvadd` awayFromAxis offset) s            textDimension s     ag = _axis_label_gap as@@ -288,7 +284,7 @@ hBufferRect :: Rect -> Rect hBufferRect (Rect p (Point x y)) = Rect p $ Point x' y   where x' = x + w/2-        w = x - (p_x p)+        w = x - p_x p  noOverlaps :: [Rect] -> Bool noOverlaps [] = True@@ -304,6 +300,7 @@         p4 = Point x2 y1         ps = [p1,p2,p3,p4] +eachNth :: Int -> [a] -> [a] eachNth n = skipN   where     n' = n - 1@@ -317,15 +314,15 @@  axisMapping :: AxisT z -> RectSize                -> (Double,Double,Double,Double,Vector,z->Point,Point->z)-axisMapping (AxisT et as 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)+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 = reverse (x1,x2)-    yr = reverse (y2,y1)+    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)@@ -333,15 +330,15 @@     imapx (Point x _) = _axis_tropweiv ad xr x     imapy (Point _ y) = _axis_tropweiv ad yr y -    reverse r@(r0,r1)  = if rev then (r1,r0) else r+    reverseR r@(r0,r1)  = if rev then (r1,r0) else r  -- -renderAxisGrid :: RectSize -> AxisT z -> ChartBackend ()-renderAxisGrid sz@(w,h) at@(AxisT re as rev ad) = do-    withLineStyle (_axis_grid_style as) $ do+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-    (sx,sy,ex,ey,tp,axisPoint,invAxisPoint) = axisMapping at sz+    (_,_,_,_,_,axisPoint,_) = axisMapping at sz      drawGridLine E_Top    = vline     drawGridLine E_Bottom = vline@@ -357,7 +354,7 @@  -- | 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 :: PlotValue x => ([x] -> [String]) -> ([x],[x],[x]) -> AxisData x makeAxis labelf (labelvs, tickvs, gridvs) = AxisData {     _axis_visibility = def,     _axis_viewport = newViewport,@@ -370,13 +367,19 @@     newViewport = vmap (min',max')     newTropweiv = invmap (min',max')     newTicks    = [ (v,2)        | v <- tickvs  ] ++ [ (v,5) | v <- labelvs ]-    newLabels   = [ (v,labelf v) | 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)+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,@@ -384,7 +387,12 @@     _axis_tropweiv = invLinMap f t (minimum labelvs, maximum labelvs),     _axis_ticks    = zip tickvs (repeat 2)  ++  zip labelvs (repeat 5),     _axis_grid     = gridvs,-    _axis_labels   = [[ (v,labelf v) | v <- labelvs ]]+    _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)]     }  @@ -397,10 +405,6 @@ -- | The default 'LineStyle' of a plot area grid. defaultGridLineStyle :: LineStyle defaultGridLineStyle = dashedLine 1 [5,5] $ opaque lightgrey--{-# DEPRECATED defaultAxisStyle "Use the according Data.Default instance!" #-}-defaultAxisStyle :: AxisStyle-defaultAxisStyle = def  instance Default AxisStyle where   def = AxisStyle
Graphics/Rendering/Chart/Axis/Unit.hs view
@@ -5,6 +5,7 @@ -- License     :  BSD-style (see chart/COPYRIGHT) -- -- Calculate and render unit indexed axes+{-# OPTIONS_GHC -fno-warn-orphans #-}  module Graphics.Rendering.Chart.Axis.Unit(     unitAxis,
Graphics/Rendering/Chart/Backend.hs view
@@ -1,10 +1,16 @@--- | This module provides the API for drawing operations abstracted--- to arbitrary 'ChartBackend's.+-----------------------------------------------------------------------------+-- |+-- 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-    ChartBackend(..)-  , CRender+    BackendProgram      -- * Backend Operations   , fillPath@@ -42,8 +48,6 @@   , FontSlant(..)   , FontStyle(..) -  , defaultFontStyle-     , HTextAnchor(..)   , VTextAnchor(..)
Graphics/Rendering/Chart/Backend/Impl.hs view
@@ -1,18 +1,18 @@ {-# LANGUAGE GADTs #-} --- | This module provides the implementation details common to all 'ChartBackend's.+-----------------------------------------------------------------------------+-- |+-- 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 Data.Monoid-import Control.Applicative-import Control.Monad.Reader+import Control.Monad import Control.Monad.Operational -import Data.Default.Class--import Data.Colour-import Data.Colour.Names- import Graphics.Rendering.Chart.Geometry import Graphics.Rendering.Chart.Backend.Types @@ -22,20 +22,20 @@  -- | 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 ()@@ -48,31 +48,27 @@   WithLineStyle  :: LineStyle -> Program ChartBackendInstr a -> ChartBackendInstr a   WithClipRegion :: Rect -> Program ChartBackendInstr a -> ChartBackendInstr a --- | A 'ChartBackend' provides the capability to render a chart somewhere.---   +-- | 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 +--   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 +--+--   The line, fill and font style are set to their default values --   initially.---   ---   Information about the semantics of the instructions can be +--+--   Information about the semantics of the instructions can be --   found in the documentation of 'ChartBackendInstr'.-type ChartBackend a = Program ChartBackendInstr a--{-# DEPRECATED CRender  "Use the new name ChartBackend!" #-}--- | Alias so the old name for rendering code still works.-type CRender a = ChartBackend a+type BackendProgram a = Program ChartBackendInstr a --- | Stroke the outline of the given path using the +-- | 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 -> ChartBackend ()+strokePath :: Path -> BackendProgram () strokePath p = singleton (StrokePath p)  -- | Fill the given path using the current 'FillStyle'.@@ -80,53 +76,53 @@ --   This function does /not/ perform --   alignment operations on the path. --   See 'Path' for the exact semantic of paths.-fillPath :: Path -> ChartBackend ()+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 -> ChartBackend TextSize+textSize :: String -> BackendProgram TextSize textSize text = singleton (GetTextSize text) --- | Draw a single-line textual label anchored by the baseline (vertical) +-- | Draw a single-line textual label anchored by the baseline (vertical) --   left (horizontal) point. Uses the current 'FontStyle' for drawing.-drawText :: Point -> String -> ChartBackend ()+drawText :: Point -> String -> BackendProgram () drawText p text = singleton (DrawText p text)  -- | Apply the given transformation in this local---   environment when drawing. The given transformation +--   environment when drawing. The given transformation --   is applied after the current transformation. This --   means both are combined.-withTransform :: Matrix -> ChartBackend a -> ChartBackend a+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 guarentee+--+--   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 +--+--   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 -> ChartBackend a -> ChartBackend a+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 -> ChartBackend a -> ChartBackend a+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 -> ChartBackend a -> ChartBackend a+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 +--   is intersected with the given clip region. You cannot --   escape the clip!-withClipRegion :: Rect -> ChartBackend a -> ChartBackend a+withClipRegion :: Rect -> BackendProgram a -> BackendProgram a withClipRegion c p = singleton (WithClipRegion c p)  -- -----------------------------------------------------------------------@@ -134,10 +130,10 @@ -- -----------------------------------------------------------------------  -- | Get the point alignment function-getPointAlignFn :: ChartBackend (Point->Point)+getPointAlignFn :: BackendProgram (Point->Point) getPointAlignFn = liftM afPointAlignFn (singleton GetAlignments)  -- | Get the coordinate alignment function-getCoordAlignFn :: ChartBackend (Point->Point)+getCoordAlignFn :: BackendProgram (Point->Point) getCoordAlignFn = liftM afCoordAlignFn (singleton GetAlignments)
Graphics/Rendering/Chart/Backend/Types.hs view
@@ -1,5 +1,12 @@ {-# 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@@ -98,11 +105,6 @@     , _font_color  = opaque black     } -{-# DEPRECATED defaultFontStyle  "Use the according Data.Default instance!" #-}--- | The default font style.-defaultFontStyle :: FontStyle-defaultFontStyle = def- -- | Possible horizontal anchor points for text. data HTextAnchor = HTA_Left                   | HTA_Centre @@ -131,15 +133,15 @@  -- | Abstract data type for a fill style. -----   The contained Cairo action sets the required fill---   style in the Cairo rendering state.+--   The contained action sets the required fill+--   style in the rendering state. newtype FillStyle = FillStyleSolid -  { _fill_colour :: AlphaColour Double +  { _fill_color :: AlphaColour Double    } deriving (Show, Eq)  -- | The default fill style. instance Default FillStyle where-  def = FillStyleSolid { _fill_colour = opaque white }+  def = FillStyleSolid { _fill_color = opaque white }  ------------------------------------------------------------------------- @@ -159,25 +161,29 @@   --      --   This is usually used to align prior to stroking. -  -- | A adjustment applied immediately prior to coordinates+  -- | The adjustment applied immediately prior to coordinates   --   being transformed.   --      --   This is usually used to align prior to filling.   afCoordAlignFn :: AlignmentFn   } --- | Alignment to render good on raster based graphics.+-- | 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-        adj v = (fromIntegral.round) v +offset+        -- avoid messages about Integer default+        rnd :: Double -> Integer+        rnd = round+        adj v = (fromIntegral.rnd) v +offset --- | Alignment to render good on vector based graphics.+-- | 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
@@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Graphics.Rendering.Chart.Drawing--- Copyright   :  (c) Tim Docker 2006+-- Copyright   :  (c) Tim Docker 2006, 2014 -- License     :  BSD-style (see chart/COPYRIGHT) -- -- This module contains basic types and functions used for drawing.@@ -13,7 +13,7 @@ -- -- 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+-- dropped. Hence for data field @f_::F@ in type @D@, they have type -- -- @ --   f :: Control.Lens.Lens' D F@@ -27,21 +27,20 @@     PointShape(..)   , PointStyle(..)   , drawPoint-  , defaultPointStyle-  +   -- * Alignments and Paths   , alignPath   , alignFillPath   , alignStrokePath   , alignFillPoints   , alignStrokePoints-  +   , alignFillPoint   , alignStrokePoint-  +   , strokePointPath   , fillPointPath-  +   -- * Transformation and Style Helpers   , withRotation   , withTranslation@@ -49,17 +48,17 @@   , withScaleX, withScaleY   , withPointStyle   , withDefaultStyle-  +   -- * Text Drawing   , drawTextA   , drawTextR   , drawTextsR   , textDrawRect   , textDimension-  +   -- * Style Helpers   , defaultColorSeq-    +   , solidLine   , dashedLine @@ -70,12 +69,13 @@   , plusses   , exes   , stars-    +  , arrows+   , solidFillStyle-  +   -- * Backend and general Types   , module Graphics.Rendering.Chart.Backend-  +   -- * Accessors   , point_color   , point_border_color@@ -85,50 +85,53 @@ ) where  import Data.Default.Class-import Control.Lens hiding (moveTo)+-- 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.SRGB import Data.Colour.Names import Data.List (unfoldr)-import Data.Monoid -import Control.Monad.Reader- import Graphics.Rendering.Chart.Backend-import Graphics.Rendering.Chart.Geometry+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 -> ChartBackend a -> ChartBackend a+withRotation :: Double -> BackendProgram a -> BackendProgram a withRotation angle = withTransform (rotate angle 1)  -- | Apply a local translation.-withTranslation :: Point -> ChartBackend a -> ChartBackend a+withTranslation :: Point -> BackendProgram a -> BackendProgram a withTranslation p = withTransform (translate (pointToVec p) 1)  -- | Apply a local scale.-withScale :: Vector -> ChartBackend a -> ChartBackend a+withScale :: Vector -> BackendProgram a -> BackendProgram a withScale v = withTransform (scale v 1)  -- | Apply a local scale on the x-axis.-withScaleX :: Double -> ChartBackend a -> ChartBackend a+withScaleX :: Double -> BackendProgram a -> BackendProgram a withScaleX x = withScale (Vector x 1)  -- | Apply a local scale on the y-axis.-withScaleY :: Double -> ChartBackend a -> ChartBackend a+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 -> ChartBackend a -> ChartBackend a-withPointStyle (PointStyle cl bcl bw _ _) m = do-  withLineStyle (def { _line_color = bcl, _line_width = bw }) $ do+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 :: ChartBackend a -> ChartBackend a+withDefaultStyle :: BackendProgram a -> BackendProgram a withDefaultStyle = withLineStyle def . withFillStyle def . withFontStyle def  -- -----------------------------------------------------------------------@@ -137,24 +140,24 @@  -- | Align the path by applying the given function on all points. alignPath :: (Point -> Point) -> Path -> Path-alignPath f = foldPath (\p -> moveTo $ f p)-                       (\p -> lineTo $ f p)-                       (\p -> arc $ f p)-                       (\p -> arcNeg $ f p)-                       (close)+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. +--   This is generally useful when stroking. --   See 'alignPath' and 'getPointAlignFn'.-alignStrokePath :: Path -> ChartBackend Path+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. +--   This is generally useful when filling. --   See 'alignPath' and 'getCoordAlignFn'.-alignFillPath :: Path -> ChartBackend Path+alignFillPath :: Path -> BackendProgram Path alignFillPath p = do   f <- getCoordAlignFn   return $ alignPath f p@@ -162,7 +165,7 @@ -- | 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] -> ChartBackend [Point]+alignStrokePoints :: [Point] -> BackendProgram [Point] alignStrokePoints p = do   f <- getPointAlignFn   return $ fmap f p@@ -170,38 +173,38 @@ -- | The points will be aligned by the 'getCoordAlignFn', so that --   when drawing bitmaps, the edges of the region will fall between --   pixels.-alignFillPoints :: [Point] -> ChartBackend [Point]+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 -> ChartBackend Point-alignStrokePoint p = do +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 -> ChartBackend Point-alignFillPoint p = do +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) = moveTo p+stepPath (p:ps) = G.moveTo p                <> mconcat (map lineTo ps) stepPath [] = mempty  -- | Draw lines between the specified points.-strokePointPath :: [Point] -> ChartBackend ()+strokePointPath :: [Point] -> BackendProgram () strokePointPath pts = strokePath $ stepPath pts  -- | Fill the region with the given corners.-fillPointPath :: [Point] -> ChartBackend ()+fillPointPath :: [Point] -> BackendProgram () fillPointPath pts = fillPath $ stepPath pts  -- -----------------------------------------------------------------------@@ -210,14 +213,27 @@  -- | Draw a line of text that is aligned at a different anchor point. --   See 'drawText'.-drawTextA :: HTextAnchor -> VTextAnchor -> Point -> String -> ChartBackend ()-drawTextA hta vta p s = drawTextR hta vta 0 p s+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 -> ChartBackend ()+drawTextR :: HTextAnchor -> VTextAnchor -> Double -> Point -> String -> BackendProgram () drawTextR hta vta angle p s =   withTranslation p $     withRotation theta $ do@@ -230,17 +246,17 @@ --   or edges, with rotation. Rotation angle is given in degrees, --   rotation is performed around anchor point. --   See 'drawText'.-drawTextsR :: HTextAnchor -> VTextAnchor -> Double -> Point -> String -> ChartBackend ()+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-      _ -> do+      _ ->         withTranslation p $           withRotation theta $ do             tss <- mapM textSize ss             let ts = head tss-            let widths = map textSizeWidth tss-                maxw   = maximum widths+            let -- widths = map textSizeWidth tss+                -- maxw   = maximum widths                 maxh   = maximum (map textSizeYBearing tss)                 gap    = maxh / 2 -- half-line spacing                 totalHeight = fromIntegral num*maxh +@@ -253,11 +269,11 @@       ss   = lines s       num  = length ss -      drawT x y s = drawText (Point x y) s+      drawT x y = drawText (Point x y)       theta = angle*pi/180.0 -      yinit VTA_Top      ts height = textSizeAscent ts-      yinit VTA_BaseLine ts height = 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 @@ -268,37 +284,42 @@ -- | 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)+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_Centre   ts = - textSizeYBearing ts / 2 adjustTextY VTA_BaseLine _  = 0-adjustTextY VTA_Bottom   ts = -(textSizeDescent ts)+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 -> ChartBackend Rect+textDrawRect :: HTextAnchor -> VTextAnchor -> Point -> String -> BackendProgram Rect textDrawRect hta vta (Point x y) s = do   ts <- textSize s-  let (w,h) = (textSizeWidth ts, textSizeHeight ts)-  let lx = adjustTextX hta ts-  let ly = adjustTextY vta ts-  let (x',y') = (x + lx, y + ly)-  let p1 = Point x' y'-  let p2 = Point (x' + w) (y' + h)+  -- 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 -> ChartBackend RectSize+textDimension :: String -> BackendProgram RectSize textDimension s = do   ts <- textSize s   return (textSizeWidth ts, textSizeHeight ts)-  + -- ----------------------------------------------------------------------- -- Point Types and Drawing -- -----------------------------------------------------------------------@@ -309,6 +330,8 @@                 | 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@@ -326,7 +349,7 @@  -- | Default style to use for points. instance Default PointStyle where-  def = PointStyle +  def = PointStyle     { _point_color        = opaque black     , _point_border_color = transparent     , _point_border_width = 0@@ -334,16 +357,11 @@     , _point_shape        = PointShapeCircle     } -{-# DEPRECATED defaultPointStyle "Use the according Data.Default instance!" #-}--- | Default style for points.-defaultPointStyle :: PointStyle-defaultPointStyle = def- -- | Draw a single point at the given location. drawPoint :: PointStyle  -- ^ Style to use when rendering the point.           -> Point       -- ^ Position of the point to render.-          -> ChartBackend ()-drawPoint ps@(PointStyle cl bcl bw r shape) p = withPointStyle ps $ do+          -> BackendProgram ()+drawPoint ps@(PointStyle cl _ _ r shape) p = withPointStyle ps $ do   p'@(Point x y) <- alignStrokePoint p   case shape of     PointShapeCircle -> do@@ -356,12 +374,15 @@             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 + r * sin a)-                                    (y + r * cos a)) angles-      let path = moveTo p <> mconcat (map lineTo ps) <> lineTo p+          (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-    PointShapePlus -> do+    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)@@ -382,6 +403,11 @@                 <> 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@@ -409,7 +435,7 @@ filledCircles :: Double             -- ^ Radius of circle.               -> AlphaColour Double -- ^ Fill colour.               -> PointStyle-filledCircles radius cl = +filledCircles radius cl =   PointStyle cl transparent 0 radius PointShapeCircle  -- | Style for stroked circle points.@@ -417,7 +443,7 @@               -> Double -- ^ Thickness of line.               -> AlphaColour Double -- Colour of line.               -> PointStyle-hollowCircles radius w cl = +hollowCircles radius w cl =   PointStyle transparent cl w radius PointShapeCircle  -- | Style for stroked polygon points.@@ -427,7 +453,7 @@               -> Bool   -- ^ Is right-side-up?               -> AlphaColour Double -- ^ Colour of line.               -> PointStyle-hollowPolygon radius w sides isrot cl = +hollowPolygon radius w sides isrot cl =   PointStyle transparent cl w radius (PointShapePolygon sides isrot)  -- | Style for filled polygon points.@@ -436,7 +462,7 @@               -> Bool   -- ^ Is right-side-up?               -> AlphaColour Double -- ^ Fill color.               -> PointStyle-filledPolygon radius sides isrot cl = +filledPolygon radius sides isrot cl =   PointStyle cl transparent 0 radius (PointShapePolygon sides isrot)  -- | Plus sign point style.@@ -444,7 +470,7 @@         -> Double -- ^ Thickness of line.         -> AlphaColour Double -- ^ Color of line.         -> PointStyle-plusses radius w cl = +plusses radius w cl =   PointStyle transparent cl w radius PointShapePlus  -- | Cross point style.@@ -463,8 +489,16 @@ 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 cl = FillStyleSolid cl+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
@@ -1,3 +1,9 @@+-----------------------------------------------------------------------------+-- |+-- 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(..)@@ -6,7 +12,7 @@    , RectSize   , Range-  +   , pointToVec    , mkrect@@ -14,6 +20,8 @@   , pvadd   , pvsub   , psub+  , vangle+  , vlen   , vscale   , within   , intersectRect@@ -21,7 +29,7 @@   , RectEdge(..)   , Limit(..)   , PointMapFn-  +   -- * Paths   , Path(..)   , lineTo, moveTo@@ -29,10 +37,10 @@   , arc, arc'   , arcNeg, arcNeg'   , close-  +   , foldPath   , makeLinesExplicit-  +   -- * Matrices   , transformP, scaleP, rotateP, translateP   , Matrix(..)@@ -43,8 +51,13 @@   , invert   ) where -import Data.Monoid+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,@@ -61,21 +74,32 @@ 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))+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))+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))+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))+psub (Point x1 y1) (Point x2 y2) = Vector (x1-x2) (y1-y2)  data Limit a = LMin | LValue a | LMax    deriving Show@@ -109,11 +133,11 @@ intersectRect r LMax = r intersectRect LMin _ = LMin intersectRect _ LMin = LMin-intersectRect (LValue (Rect (Point x11 y11) (Point x12 y12))) +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 +  in if x2 < x1 || y2 < y1         then LMin         else LValue $ Rect p1 p2 @@ -124,16 +148,16 @@ -- | 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    +  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)+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  -- -----------------------------------------------------------------------@@ -141,44 +165,47 @@ -- -----------------------------------------------------------------------  -- | 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 +data Path = MoveTo Point Path           | LineTo Point Path           | Arc Point Double Double Double Path           | ArcNeg Point Double Double Double Path-          | End +          | End           | Close  -- | Paths are monoids. After a path is closed you can not append---   anything to it anymore. The empty path is open. +--   anything to it anymore. The empty path is open. --   Use 'close' to close a path.-instance Monoid Path where-  mappend p1 p2 = case p1 of-    MoveTo p path -> MoveTo p $ mappend path p2-    LineTo p path -> LineTo p $ mappend path p2-    Arc    p r a1 a2 path -> Arc p r a1 a2 $ mappend path p2-    ArcNeg p r a1 a2 path -> ArcNeg p r a1 a2 $ mappend path p2+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.@@ -189,7 +216,7 @@ moveTo' :: Double -> Double -> Path moveTo' x y = moveTo $ Point x y --- | Move the paths pointer to the given location and draw a straight +-- | Move the paths pointer to the given location and draw a straight --   line while doing so. lineTo :: Point -> Path lineTo p = LineTo p mempty@@ -205,7 +232,7 @@ --   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 -- ^ Redius of the circle.+    -> Double -- ^ Radius of the circle.     -> Double -- ^ Angle to start drawing at, in radians.     -> Double -- ^ Angle to stop drawing at, in radians.     -> Path@@ -237,23 +264,23 @@          -> 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 <> restF rest-    LineTo p rest -> lineTo p <> restF rest-    Arc    p r a1 a2 rest -> arc    p r a1 a2 <> restF rest-    ArcNeg p r a1 a2 rest -> arcNeg p r a1 a2 <> restF rest+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+    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) = +makeLinesExplicit (Arc c r s e rest) =   Arc c r s e $ makeLinesExplicit' rest-makeLinesExplicit (ArcNeg c r s e rest) = +makeLinesExplicit (ArcNeg c r s e rest) =   ArcNeg c r s e $ makeLinesExplicit' rest makeLinesExplicit path = makeLinesExplicit' path @@ -261,15 +288,15 @@ makeLinesExplicit' :: Path -> Path makeLinesExplicit' End   = End makeLinesExplicit' Close = Close-makeLinesExplicit' (Arc c r s e rest) = +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) = +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) = +makeLinesExplicit' (MoveTo p0 rest) =   MoveTo p0 $ makeLinesExplicit' rest-makeLinesExplicit' (LineTo p0 rest) = +makeLinesExplicit' (LineTo p0 rest) =   LineTo p0 $ makeLinesExplicit' rest  -- -----------------------------------------------------------------------@@ -303,13 +330,16 @@  -- | Copied from Graphics.Rendering.Cairo.Matrix instance Num Matrix where-  (*) (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')+  -- 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 (-)@@ -317,18 +347,20 @@   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 f (Matrix xx yx xy yy x0 y0) =-  Matrix (f xx) (f yx) (f xy) (f yy) (f x0) (f y0)+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 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')+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@@ -336,16 +368,16 @@  -- | 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))+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)+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)+rotate r m = m * Matrix c s (-s) c 0 0   where s = sin r         c = cos r @@ -360,17 +392,5 @@  -- | 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------------+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,14 +1,14 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Graphics.Rendering.Chart.Grid--- Copyright   :  (c) Tim Docker 2010+-- Copyright   :  (c) Tim Docker 2010, 2014 -- License     :  BSD-style (see chart/COPYRIGHT) -- -- A container type for values that can be composed by horizonal -- and vertical layout.  module Graphics.Rendering.Chart.Grid (-    Grid, Span,+    Grid, Span, SpaceWeight,     tval, tspan,     empty, nullt,     (.|.), (./.),@@ -26,18 +26,12 @@     fullOverlayOver ) where -import Data.List import Data.Array import Control.Monad-import Control.Monad.Trans-import Numeric import Graphics.Rendering.Chart.Renderable-import Graphics.Rendering.Chart.Geometry+import Graphics.Rendering.Chart.Geometry hiding (x0, y0) import Graphics.Rendering.Chart.Drawing -import Data.Colour-import Data.Colour.Names- type Span        = (Int,Int) type Size        = (Int,Int) @@ -67,17 +61,17 @@ 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 (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 (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@@ -85,7 +79,7 @@  -- | 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))  -- | A 1x1 empty grid. empty :: Grid a@@ -103,30 +97,30 @@  -- | 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+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))+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+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))+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))+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+fullOverlayOver  a g = tspan a (width g,height g) `overlay` g  beside Null t = t beside t Null = t@@ -154,8 +148,8 @@  -- | 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 _  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@@ -165,27 +159,27 @@ -- than ./. and .//.  instance Functor Grid where-    fmap f (Value (a,span,ew)) = Value   (f a,span,ew)+    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 f Empty               = Empty-    fmap f Null                = Null+    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)]@@ -197,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@@ -219,14 +213,14 @@ 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 -getSizes :: Grid (Renderable a) -> ChartBackend (DArray, DArray, DArray, DArray)+getSizes :: Grid (Renderable a) -> BackendProgram (DArray, DArray, DArray, DArray) getSizes t = do-    szs <- mapGridM minsize t :: ChartBackend (Grid RectSize)+    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')@@ -238,53 +232,53 @@                                                    (foldT (ef ywf snd) [] szs')     return (widths,heights,xweights,yweights)   where-      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)+      wf  (x,_) (w,_) _      = (x,w)+      hf  (_,y) (_,h) _      = (y,h)+      xwf (x,_) _     (xw,_) = (x,xw)+      ywf (_,y) _     (_,yw) = (y,yw) -      ef f ds loc (size,span,ew) r | ds span == 1 = (f loc size ew:r)-                                   | otherwise    = r+      ef f ds loc (size,spn,ew) r | ds spn == 1 = f loc size ew:r+                                  | otherwise    = r  instance (ToRenderable a) => ToRenderable (Grid a) where   toRenderable = gridToRenderable . fmap toRenderable  gridToRenderable :: Grid (Renderable a) -> Renderable a-gridToRenderable t = Renderable minsizef renderf+gridToRenderable gt = Renderable minsizef renderf   where-    minsizef :: ChartBackend RectSize+    minsizef :: BackendProgram RectSize     minsizef = do-        (widths, heights, xweights, yweights) <- getSizes t+        (widths, heights, _, _) <- getSizes gt         return (sum (elems widths), sum (elems heights))      renderf (w,h)  = do-        (widths, heights, xweights, yweights) <- getSizes t+        (widths, heights, xweights, yweights) <- getSizes gt         let widths'  = addExtraSpace w widths xweights         let heights' = addExtraSpace h heights yweights         let borders  = (ctotal widths',ctotal heights')-        rf1 borders (0,0) t+        rf1 borders (0,0) gt      -- (x borders, y borders) -> (x,y) -> grid -> drawing     rf1 borders loc@(i,j) t = case t of         Null  -> return nullPickFn         Empty -> return nullPickFn-        (Value (r,span,_)) -> do-            let (Rect p0 p1) = mkRect borders loc span-            p0'@(Point x0 y0) <- alignFillPoint p0-            p1'@(Point x1 y1) <- alignFillPoint p1+        (Value (r,spn,_)) -> do+            let (Rect p0 p1) = mkRect borders loc spn+            (Point x0 y0) <- alignFillPoint p0+            (Point x1 y1) <- alignFillPoint p1             withTranslation (Point x0 y0) $ do               pf <- render r (x1-x0,y1-y0)               return (newpf pf x0 y0)         (Above t1 t2 _) -> do              pf1 <- rf1 borders (i,j) t1              pf2 <- rf1 borders (i,j+height t1) t2-             let pf p@(Point x y) = if y < (snd borders ! (j + height t1))+             let pf p@(Point _ y) = if y < (snd borders ! (j + height t1))                                     then pf1 p else pf2 p              return pf         (Beside t1 t2 _) -> do              pf1 <- rf1 borders (i,j) t1              pf2 <- rf1 borders (i+width t1,j) t2-             let pf p@(Point x y) = if x < (fst borders ! (i + width t1))+             let pf p@(Point x _) = if x < (fst borders ! (i + width t1))                                     then pf1 p else pf2 p              return pf         (Overlay t1 t2 _) ->  do@@ -293,7 +287,7 @@              let pf p = pf1 p `mplus` pf2 p              return pf -    newpf pf x0 y0 = \ (Point x1 y1)-> pf (Point (x1-x0) (y1-y0))+    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]@@ -304,17 +298,17 @@         y1 = cheights ! y         x2 = cwidths  ! min (x+w) (snd $ bounds cwidths)         y2 = cheights ! min (y+h) (snd $ bounds cheights)-        mx = fst (bounds cwidths)-        my = fst (bounds cheights)+        -- 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
Graphics/Rendering/Chart/Layout.hs view
@@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Graphics.Rendering.Chart.Layout--- Copyright   :  (c) Tim Docker 2006+-- Copyright   :  (c) Tim Docker 2006, 2014 -- License     :  BSD-style (see chart/COPYRIGHT) -- -- This module glues together axes and plots to actually create a renderable@@ -11,50 +11,45 @@ -- (see 'Control.Lens') for each field of the following data types: -- --     * 'Layout'---     +-- --     * 'LayoutLR'--- +-- --     * 'StackedLayouts' -- --     * 'LayoutAxis' ----- These accessors are not shown in this API documentation.  They have--- the same name as the field, but with the leading underscore--- dropped. Hence for data field _f::F in type D, they have type------ @---   f :: Control.Lens.Lens' D F--- @---+{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ExistentialQuantification #-}  module Graphics.Rendering.Chart.Layout-  ( Layout(..)+  ( -- * Types+    Layout(..)   , LayoutLR(..)   , LayoutAxis(..)   , LayoutPick(..)   , StackedLayouts(..)   , StackedLayout(..)+  -- , LegendItem  haddock complains about this being missing, but from what?   , MAxisFn-  ++    -- * Rendering   , layoutToRenderable+  , layoutToGrid   , layoutLRToRenderable--  , setLayoutForeground-  , updateAllAxesStyles-  , setLayoutLRForeground-  , updateAllAxesStylesLR+  , layoutLRToGrid+  , renderStackedLayouts -  , defaultLayoutAxis+    -- * LayoutAxis lenses   , laxis_title_style   , laxis_title   , laxis_style   , laxis_generate   , laxis_override   , laxis_reverse-    ++    -- * Layout lenses   , layout_background   , layout_plot_background   , layout_title@@ -69,7 +64,13 @@   , 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@@ -86,13 +87,20 @@   , layoutlr_margin   , layoutlr_grid_last -  , defaultStackedLayouts+  , layoutlr_axes_styles+  , layoutlr_axes_title_styles+  , layoutlr_all_font_styles+  , layoutlr_foreground++    -- * StackedLayouts lenses   , slayouts_layouts   , slayouts_compress_legend--  , renderStackedLayouts   ) 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@@ -102,8 +110,7 @@ import Graphics.Rendering.Chart.Renderable import Graphics.Rendering.Chart.Grid import Control.Monad-import Control.Monad.Reader (local)-import Control.Lens+import Control.Lens hiding (at) import Data.Colour import Data.Colour.Names (white) import Data.Default.Class@@ -113,11 +120,11 @@ 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 +--   values in 'Layout' and 'LayoutLR' override visibility related --   settings of the axis. data LayoutAxis x = LayoutAxis   { _laxis_title_style :: FontStyle@@ -130,42 +137,42 @@   , _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.+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 -> ChartBackend ())+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 +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, +    -- ^ How to fill the background of the plot,     --   if different from the overall background.    , _layout_title           :: String@@ -189,7 +196,7 @@    , _layout_plots           :: [Plot x y]     -- ^ The data sets to plot in the chart.-    --   The are ploted over each other.+    --   They are plotted over each other.    , _layout_legend          :: Maybe LegendStyle     -- ^ How to style the legend.@@ -205,18 +212,24 @@  -- | 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)+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-    layoutToGrid l = aboveN-           [  tval $ titleToRenderable (_layout_margin l) (_layout_title_style l) (_layout_title l)-           ,  weights (1,1) $ tval $ gridToRenderable $-                  addMarginsToGrid (lm,lm,lm,lm) (layoutPlotAreaToGrid l)-           ,  tval $ renderLegend l (getLegendItems l)-           ]+    lp :: Grid a -> a -> Grid a+    lp = case maybe LegendBelow _legend_position $ _layout_legend l of+              LegendAbove -> flip wideAbove+              LegendBelow -> aboveWide+              LegendRight -> besideTall+              LegendLeft  -> flip tallBeside +    title = 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) @@ -229,9 +242,9 @@ renderLegend l legItems = gridToRenderable g   where     g      = besideN [ tval $ mkLegend (_layout_legend l) (_layout_margin l) legItems-                     , weights (1,1) $ tval $ emptyRenderable ]+                     , weights (1,1) $ tval emptyRenderable ] --- | Render the plot area of a 'Layout'. This consists of the +-- | 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))@@ -244,8 +257,8 @@   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]+    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@@ -253,21 +266,21 @@     rAxis = mkAxis E_Right  (overrideAxisVisibility l _layout_y_axis _layout_right_axis_visibility ) yvals     axes = (bAxis,lAxis,tAxis,rAxis) -    plotsToRenderable l = Renderable {+    plotsToRenderable lxy = Renderable {         minsize = return (0,0),-        render  = renderPlots l+        render  = renderPlots lxy     }      -- | Render the plots of a 'Layout' to a plot area of given size.-    renderPlots :: Layout x y -> RectSize -> ChartBackend (PickFn (LayoutPick x y y))-    renderPlots l sz@(w,h) = do-        when (not (_layout_grid_last l)) (renderGrids sz axes)-        withClipRegion (Rect (Point 0 0) (Point w h)) $ do-          mapM_ rPlot (_layout_plots l)-        when (_layout_grid_last l) (renderGrids sz axes)+    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 p = renderSinglePlot sz bAxis lAxis p+        rPlot = renderSinglePlot sz bAxis lAxis          xr = (0, w)         yr = (h, 0)@@ -286,10 +299,10 @@                 (Just at,_)   -> Just at                 (_,Just at)   -> Just at                 (Nothing,Nothing)   -> Nothing-            mapx (AxisT _ _ rev ad) x = _axis_tropweiv ad (optPairReverse rev xr) x-            mapy (AxisT _ _ rev ad) y = _axis_tropweiv ad (optPairReverse rev yr) y+            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 +-- | 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@@ -300,7 +313,7 @@     , _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@@ -319,16 +332,16 @@     }  -----------------------------------------------------------------------  + -- | 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 +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, +    -- ^ How to fill the background of the plot,     --   if different from the overall background.    , _layoutlr_title           :: String@@ -351,10 +364,10 @@     -- ^ 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.-    --   The are ploted over each other.+    --   They are plotted over each other.     --   The either type associates the plot with the     --   left or right y axis. @@ -371,18 +384,20 @@   toRenderable = setPickFn nullPickFn . layoutLRToRenderable  -- | Render the given 'LayoutLR'.-layoutLRToRenderable :: forall x yl yr . (Ord x, Ord yl, Ord yr) +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) +layoutLRToRenderable l = fillBackground (_layoutlr_background l)                        $ gridToRenderable (layoutLRToGrid l)-  where-    layoutLRToGrid l = aboveN-           [  tval $ titleToRenderable (_layoutlr_margin l) (_layoutlr_title_style l) (_layoutlr_title l)-           ,  weights (1,1) $ tval $ gridToRenderable $-                  addMarginsToGrid (lm,lm,lm,lm) (layoutLRPlotAreaToGrid l)-           ,  tval $ renderLegendLR l (getLegendItemsLR 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]@@ -396,8 +411,8 @@ --   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) ]+    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'.@@ -405,12 +420,12 @@ renderLegendLR l (lefts,rights) = gridToRenderable g   where     g      = besideN [ tval $ mkLegend (_layoutlr_legend l) (_layoutlr_margin l) lefts-                     , weights (1,1) $ tval $ emptyRenderable+                     , weights (1,1) $ tval emptyRenderable                      , tval $ mkLegend (_layoutlr_legend l) (_layoutlr_margin l) rights ]-    lm     = _layoutlr_margin l+    -- lm     = _layoutlr_margin l -layoutLRPlotAreaToGrid :: forall x yl yr. (Ord x, Ord yl, Ord yr) -                       => LayoutLR x yl yr +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,@@ -425,24 +440,24 @@           ++ [ 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 l = Renderable {+    plotsToRenderable llr = Renderable {         minsize = return (0,0),-        render  = renderPlots l+        render  = renderPlots llr     } -    renderPlots :: LayoutLR x yl yr -> RectSize -> ChartBackend (PickFn (LayoutPick x yl yr))-    renderPlots l sz@(w,h) = do-        when (not (_layoutlr_grid_last l)) (renderGrids sz axes)-        withClipRegion (Rect (Point 0 0) (Point w h)) $ do-          mapM_ rPlot (_layoutlr_plots l)-        when (_layoutlr_grid_last l) (renderGrids sz axes)+    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@@ -463,8 +478,8 @@             myats = case (lAxis,rAxis) of                 (Just at1,Just at2) -> Just (at1,at2)                 (_,_)   -> Nothing-            mapx (AxisT _ _ rev ad) x = _axis_tropweiv ad (optPairReverse rev xr) x-            mapy (AxisT _ _ rev ad) y = _axis_tropweiv ad (optPairReverse rev yr) y+            mapx (AxisT _ _ rev ad) = _axis_tropweiv ad (optPairReverse rev xr)+            mapy (AxisT _ _ rev ad) = _axis_tropweiv ad (optPairReverse rev yr)  ---------------------------------------------------------------------- @@ -478,21 +493,23 @@  -- | A container for a set of vertically 'StackedLayout's. --   The x axis of the different layouts will be aligned.-data StackedLayouts x = StackedLayouts +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.   } -{-# DEPRECATED defaultStackedLayouts  "Use the according Data.Default instance!" #-}-defaultStackedLayouts :: StackedLayouts x-defaultStackedLayouts = def- -- | 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. --@@ -504,12 +521,12 @@   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)+          addMarginsToGrid (lm,lm,lm,lm) (mkPlotArea usedAxis)           `aboveWide`           (if showLegend then legendR else emptyRenderable)       where@@ -519,21 +536,21 @@         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 +          StackedLayout l -> fmap noPickFn+                           $ layoutPlotAreaToGrid                            $ l { _layout_x_axis = axis }-          StackedLayoutLR l -> fmap noPickFn -                             $ layoutLRPlotAreaToGrid +          StackedLayoutLR l -> fmap noPickFn+                             $ layoutLRPlotAreaToGrid                              $ l { _layoutlr_x_axis = axis }          showLegend = not (null (fst legenditems)) || not (null (snd legenditems))@@ -543,37 +560,37 @@         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 +        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, [])-    lebendItems (StackedLayoutLR l) = getLegendItemsLR 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 [@@ -589,13 +606,13 @@     rs = tval $ spacer (r,0)  titleToRenderable :: Double -> FontStyle -> String -> Renderable (LayoutPick x yl yr)-titleToRenderable lm fs "" = emptyRenderable+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 ls lm vals = case ls of+mkLegend mls lm vals = case mls of     Nothing -> emptyRenderable     Just ls ->  case filter ((/="").fst) vals of         []  -> emptyRenderable ;@@ -605,7 +622,7 @@  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),@@ -629,20 +646,20 @@          , besideN [er,     er,  er,    btitle, er,    er,  er       ]          ] -    er = tval $ emptyRenderable+    er = tval emptyRenderable      plots = tval $ lge_plots lge -    (tdata,tlbl,tstyle) = lge_taxis 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+    -- (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@@ -657,19 +674,19 @@     tr = tval $ axesSpacer snd tdata fst rdata     br = tval $ axesSpacer snd bdata snd rdata -    mktitle :: HTextAnchor -> VTextAnchor +    mktitle :: HTextAnchor -> VTextAnchor             -> Double             -> String -> FontStyle-            -> (String -> LayoutPick x yl yr) +            -> (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 (label,gap)+    mktitle ha va rot lbl style pf = if lbl == "" then (er,er) else (labelG,gapG)       where-        label = tval $ mapPickFn pf $ rlabel style ha va rot lbl-        gap = tval $ spacer (lge_margin lge,0)+        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)) -> ChartBackend ()+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@@ -682,20 +699,20 @@  -- | 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 -> ChartBackend ()-renderSinglePlot (w, h) (Just (AxisT _ xs xrev xaxis)) (Just (AxisT _ ys yrev yaxis)) p =+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)+      -- 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 (min,max) _ LMin       = min-      mapv (min,max) _ LMax       = max-      mapv _         f (LValue v) = f v+      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) +axesSpacer :: (Ord x, Ord y)            => ((Double, Double) -> Double) -> Maybe (AxisT x)            -> ((Double, Double) -> Double) -> Maybe (AxisT y)            -> Renderable a@@ -704,27 +721,27 @@     oh2 <- maybeM (0,0) axisOverhang a2     return (spacer (f1 oh1, f2 oh2)) --- | Construct a axis for the given edge using the attributes +-- | 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 = case axisVisible of-    False -> Nothing-    True  -> Just $ AxisT edge style rev adata+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)+    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 = +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 = selVis ly }) +  in (selAxis ly) { _laxis_override = (\ad -> ad { _axis_visibility = vis })                                     . _laxis_override (selAxis ly)                   } @@ -732,7 +749,7 @@ mfill Nothing   = id mfill (Just fs) = fillBackground fs --- | Empty 'LayoutLR' without title and plots. The background is white and +-- | 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@@ -754,7 +771,7 @@     , _layoutlr_left_axis_visibility  = def     , _layoutlr_right_axis          = def     , _layoutlr_right_axis_visibility = def-    +     , _layoutlr_plots      = []      , _layoutlr_legend          = Just def@@ -762,10 +779,6 @@     , _layoutlr_grid_last       = False     } -{-# DEPRECATED defaultLayoutAxis "Use the according Data.Default instance!" #-}-defaultLayoutAxis :: PlotValue t => LayoutAxis t-defaultLayoutAxis = def- instance PlotValue t => Default (LayoutAxis t) where   def = LayoutAxis     { _laxis_title_style = def { _font_size=10 }@@ -784,29 +797,59 @@ $( makeLenses ''LayoutAxis ) $( makeLenses ''StackedLayouts ) --- | Helper to update all axis styles on a Layout1 simultaneously.-updateAllAxesStyles :: (AxisStyle -> AxisStyle) -> Layout x y -> Layout x y-updateAllAxesStyles uf = (layout_x_axis . laxis_style %~ uf) .-                         (layout_y_axis . laxis_style %~ uf)+-- | 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) --- | Helper to update all axis styles on a LayoutLR simultaneously.-updateAllAxesStylesLR :: (AxisStyle -> AxisStyle) -> LayoutLR x yl yr -> LayoutLR x yl yr-updateAllAxesStylesLR uf = (layoutlr_x_axis       . laxis_style %~ uf)-                         . (layoutlr_left_axis  . laxis_style %~ uf)-                         . (layoutlr_right_axis . laxis_style %~ uf)+-- | 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) --- | Helper to set the forground color uniformly on a Layout.-setLayoutForeground :: AlphaColour Double -> Layout x y -> Layout x y-setLayoutForeground fg =-    updateAllAxesStyles  ( (axis_line_style  . line_color .~ fg)-                         . (axis_label_style . font_color .~ fg))-                         . (layout_title_style . font_color .~ fg)-                         . (layout_legend %~ fmap (legend_label_style .> font_color .~ fg))+-- | 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) --- | Helper to set the forground color uniformly on a LayoutLR.-setLayoutLRForeground :: AlphaColour Double -> LayoutLR x yl yr -> LayoutLR x yl yr-setLayoutLRForeground fg = updateAllAxesStylesLR -  ( (axis_line_style  . line_color .~ fg)-  . (axis_label_style . font_color .~ fg))-  . (layoutlr_title_style . font_color .~ fg)-  . (layoutlr_legend %~ fmap (legend_label_style .> font_color .~ fg))+-- | 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,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Graphics.Rendering.Chart.Legend--- Copyright   :  (c) Tim Docker 2006+-- Copyright   :  (c) Tim Docker 2006, 2014 -- License     :  BSD-style (see chart/COPYRIGHT) --  -- Types and functions for handling the legend(s) on a chart. A legend@@ -12,22 +12,21 @@     Legend(..),     LegendStyle(..),     LegendOrientation(..),-    defaultLegendStyle,+    LegendPosition(..),     legendToRenderable,     legend_label_style,     legend_margin,     legend_plot_size,-    legend_orientation+    legend_orientation,+    legend_position ) where -import Control.Monad-import Data.List (nub, partition,intersperse)+import Data.List (partition,intersperse) import Control.Lens import Data.Default.Class  import Graphics.Rendering.Chart.Geometry import Graphics.Rendering.Chart.Drawing-import Graphics.Rendering.Chart.Plot.Types import Graphics.Rendering.Chart.Renderable import Graphics.Rendering.Chart.Grid @@ -38,7 +37,8 @@    _legend_label_style :: FontStyle,    _legend_margin      :: Double,    _legend_plot_size   :: Double,-   _legend_orientation :: LegendOrientation+   _legend_orientation :: LegendOrientation,+   _legend_position    :: LegendPosition }  -- | Legends can be constructed in two orientations: in rows@@ -46,62 +46,79 @@ -- columns (where we specify the maximum number of rows) data LegendOrientation = LORows Int                        | LOCols Int-                        -data Legend x y = Legend LegendStyle [(String, Rect -> ChartBackend ())]+-- | Defines the position of the legend, relative to the plot.+data LegendPosition = LegendAbove+                    | LegendBelow+                    | LegendRight+                    | LegendLeft +data Legend x y = Legend LegendStyle [(String, Rect -> BackendProgram ())]+ instance ToRenderable (Legend x y) where   toRenderable = setPickFn nullPickFn . legendToRenderable  legendToRenderable :: Legend x y -> Renderable String legendToRenderable (Legend ls lvs) = gridToRenderable grid   where+    grid :: Grid (Renderable String)     grid = case _legend_orientation ls of         LORows n -> mkGrid n aboveG besideG         LOCols n -> mkGrid n besideG aboveG  -    aboveG = aboveN.(intersperse ggap1)-    besideG = besideN.(intersperse ggap1)+    aboveG, besideG :: [Grid (Renderable String)] -> Grid (Renderable String)+    aboveG = aboveN.intersperse ggap1+    besideG = besideN.intersperse ggap1 +    mkGrid :: Int+              -> ([Grid (Renderable String)] -> Grid (Renderable String))+              -> ([Grid (Renderable String)] -> Grid (Renderable String))+              -> Grid (Renderable String)     mkGrid n join1 join2 = join1 [ join2 (map rf ps1) | ps1 <- groups n ps ] -    ps  :: [(String, [Rect -> ChartBackend ()])]+    ps  :: [(String, [Rect -> BackendProgram ()])]     ps   = join_nub lvs +    rf :: (String, [Rect -> BackendProgram ()]) -> Grid (Renderable String)     rf (title,rfs) = besideN [gpic,ggap2,gtitle]       where+        gpic :: Grid (Renderable String)         gpic = besideN $ intersperse ggap2 (map rp rfs)++        gtitle :: Grid (Renderable String)         gtitle = tval $ lbl title-        rp rfn = tval $ Renderable {++        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))+                     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_Left VTA_Centre s +    lbl :: String -> Renderable String+    lbl = label (_legend_label_style ls) HTA_Left VTA_Centre+ groups :: Int -> [a] -> [[a]]-groups  n [] = []-groups  n vs = let (vs1,vs2) = splitAt n vs in vs1:groups n vs2+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 []          = [] -{-# DEPRECATED defaultLegendStyle  "Use the according Data.Default instance!" #-}-defaultLegendStyle :: LegendStyle-defaultLegendStyle = def- instance Default LegendStyle where-  def = LegendStyle +  def = LegendStyle     { _legend_label_style = def     , _legend_margin      = 20     , _legend_plot_size   = 20     , _legend_orientation = LORows 4+    , _legend_position    = LegendBelow     }  $( makeLenses ''LegendStyle )
Graphics/Rendering/Chart/Plot.hs view
@@ -10,6 +10,7 @@ module Graphics.Rendering.Chart.Plot(     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,@@ -19,10 +20,12 @@     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  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@@ -32,3 +35,4 @@ 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
@@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Graphics.Rendering.Chart.Plot.Annotation--- Copyright   :  (c) Tim Docker 2006+-- Copyright   :  (c) Tim Docker 2006, 2014 -- License     :  BSD-style (see chart/COPYRIGHT) -- -- Show textual annotations on a chart.@@ -10,71 +10,92 @@  module Graphics.Rendering.Chart.Plot.Annotation(     PlotAnnotation(..),-    defaultPlotAnnotation,      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 Data.Colour (opaque)-import Data.Colour.Names (black, blue)-import Data.Colour.SRGB (sRGB)-import Data.Default.Class+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. Rotation angle is given in degrees,---   rotation is performend around the anchor point.+--   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 (\(x,_,_)->x)  vs , map (\(_,y,_)->y) vs)+      _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 -> ChartBackend ()-renderAnnotation p pMap = withFontStyle style $ do                           +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-          drawOne (x,y,s) = drawTextsR hta vta angle point s-              where point = pMap (LValue x, LValue y)--{-# DEPRECATED defaultPlotAnnotation  "Use the according Data.Default instance!" #-}-defaultPlotAnnotation :: PlotAnnotation x y-defaultPlotAnnotation = def+          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 +  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
@@ -11,48 +11,36 @@  module Graphics.Rendering.Chart.Plot.AreaSpots   ( AreaSpots(..)-  , defaultAreaSpots    , area_spots_title   , area_spots_linethick   , area_spots_linecolour   , area_spots_fillcolour+  , area_spots_opacity   , area_spots_max_radius   , area_spots_values    , AreaSpots4D(..)-  , defaultAreaSpots4D    , 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+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+import Data.Colour hiding (over) import Data.Colour.Names import Data.Default.Class  import Control.Monad ---- stuff that belongs in Data.Tuple-fst3 (a,_,_) = a-snd3 (_,a,_) = a-thd3 (_,_,a) = a--fst4 (a,_,_,_) = a-snd4 (_,a,_,_) = a-thd4 (_,_,a,_) = a-fth4 (_,_,_,a) = a-- -- | 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@@ -61,14 +49,10 @@   , _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_max_radius :: Double   -- ^ the largest size of spot   , _area_spots_values     :: [(x,y,z)]   } -{-# DEPRECATED defaultAreaSpots "Use the according Data.Default instance!" #-}-defaultAreaSpots :: AreaSpots z x y-defaultAreaSpots = def- instance Default (AreaSpots z x y) where   def = AreaSpots     { _area_spots_title      = ""@@ -83,13 +67,13 @@ 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 fst3 (_area_spots_values p)-                                         , map snd3 (_area_spots_values 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 -> ChartBackend ()+renderAreaSpots  :: (PlotValue z) => AreaSpots z x y -> PointMapFn x y -> BackendProgram () renderAreaSpots p pmap = -    forM_ (scaleMax ((_area_spots_max_radius p)^2)+    forM_ (scaleMax (_area_spots_max_radius p^(2::Integer))                     (_area_spots_values p))           (\ (x,y,z)-> do               let radius = sqrt z@@ -105,23 +89,21 @@           )   where     scaleMax :: PlotValue z => Double -> [(x,y,z)] -> [(x,y,Double)]-    scaleMax n points = let largest  = maximum (map (toValue . thd3) points)+    scaleMax n points = let largest  = maximum (map (^._3.to toValue) points)                             scale v  = n * toValue v / largest-                        in map (\ (x,y,z) -> (x,y, scale z)) points+                        in over (mapped._3) scale points -renderSpotLegend :: AreaSpots z x y -> Rect -> ChartBackend ()-renderSpotLegend p r@(Rect p1 p2) = do+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-    let psSpot    = filledCircles radius $-                                          flip withOpacity -                                               (_area_spots_opacity p) $-                                          _area_spots_fillcolour p-    drawPoint psSpot centre-    let psSpot = hollowCircles radius-                                            (_area_spots_linethick p)-                                            (_area_spots_linecolour p)+        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)@@ -136,14 +118,10 @@   , _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_max_radius :: Double        -- ^ the largest size of spot   , _area_spots_4d_values     :: [(x,y,z,t)]   } -{-# DEPRECATED defaultAreaSpots4D "Use the according Data.Default instance!" #-}-defaultAreaSpots4D :: AreaSpots4D z t x y-defaultAreaSpots4D = def- instance Default (AreaSpots4D z t x y) where   def = AreaSpots4D     { _area_spots_4d_title      = ""@@ -158,22 +136,22 @@     toPlot p = Plot { _plot_render = renderAreaSpots4D p                     , _plot_legend = [ (_area_spots_4d_title p                                        , renderSpotLegend4D p) ]-                    , _plot_all_points = ( map fst4 (_area_spots_4d_values p)-                                         , map snd4 (_area_spots_4d_values 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 -> ChartBackend ()+                      AreaSpots4D z t x y -> PointMapFn x y -> BackendProgram () renderAreaSpots4D p pmap = -    forM_ (scaleMax ((_area_spots_4d_max_radius p)^2)+    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 colour  = _area_spots_4d_palette p !! t                let psSpot                     = filledCircles radius $-                          flip withOpacity (_area_spots_4d_opacity p) $ colour+                          withOpacity colour (_area_spots_4d_opacity p)               drawPoint psSpot (pmap (LValue x, LValue y))               let psOutline                     = hollowCircles radius (_area_spots_4d_linethick p)@@ -183,9 +161,9 @@   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 (toValue . thd4) points)+    scaleMax n c points = let largest  = maximum (map (^._3.to toValue) points)                               scale v  = n * toValue v / largest-                              colVals  = map (toValue . fth4) points+                              colVals  = map (^._4.to toValue) points                               colMin   = minimum colVals                               colMax   = maximum colVals                               select t = min (c-1) $ @@ -195,19 +173,16 @@                           in map (\ (x,y,z,t) -> (x,y, scale z, select t))                                  points -renderSpotLegend4D :: AreaSpots4D z t x y -> Rect -> ChartBackend ()-renderSpotLegend4D p r@(Rect p1 p2) = do+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-    let psSpot    = filledCircles radius $-                                          flip withOpacity-                                               (_area_spots_4d_opacity p) $-                                          head $ _area_spots_4d_palette p+        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-    let psOutline = hollowCircles radius-                                            (_area_spots_4d_linethick p)-                                            (opaque $-                                             head (_area_spots_4d_palette p))     drawPoint psOutline centre   where     linearInterpolate (Point x0 y0) (Point x1 y1) =
Graphics/Rendering/Chart/Plot/Bars.hs view
@@ -1,57 +1,84 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Graphics.Rendering.Chart.Plot.Bars--- Copyright   :  (c) Tim Docker 2006+-- 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(..),-    defaultPlotBars,     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_reference,     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.Geometry+import Graphics.Rendering.Chart.Axis import Graphics.Rendering.Chart.Drawing-import Graphics.Rendering.Chart.Renderable+import Graphics.Rendering.Chart.Geometry hiding (x0, y0) import Graphics.Rendering.Chart.Plot.Types-import Graphics.Rendering.Chart.Axis-import Data.Colour (opaque)-import Data.Colour.Names (black, blue)-import Data.Colour.SRGB (sRGB)-import Data.Default.Class-+import Graphics.Rendering.Chart.Utils class PlotValue a => BarsPlotValue a where-    barsReference :: a+    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-    barsReference = 0+    barsIsNull a  = a == 0.0+    barsReference = const 0     barsAdd       = (+)+ instance BarsPlotValue Int where-    barsReference = 0+    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.@@ -73,154 +100,312 @@                        | 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 PlotBars x y = PlotBars {+data BarsSettings = BarsSettings {    -- | This value specifies whether each value from [y] should be    --   shown beside or above the previous value.-   _plot_bars_style           :: PlotBarsStyle,+   _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.-   _plot_bars_item_styles     :: [ (FillStyle,Maybe LineStyle) ],--   -- | The title of each element of [y]. These will be shown in the legend.-   _plot_bars_titles          :: [String],+   _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.-   _plot_bars_spacing         :: PlotBarsSpacing,+   _bars_settings_spacing         :: PlotBarsSpacing,     -- | This value controls how bars for a fixed x are aligned with    --   respect to the device coordinate corresponding to x.-   _plot_bars_alignment       :: PlotBarsAlignment,+   _bars_settings_alignment       :: PlotBarsAlignment, -   -- | The starting level for the chart (normally 0).-   _plot_bars_reference       :: y,+   _bars_settings_singleton_width :: Double, -   _plot_bars_singleton_width :: Double,+   -- | The point on the bar to horizontally anchor the label to+   _bars_settings_label_bar_hanchor :: BarHorizAnchor, -   -- | The actual points to be plotted.-   _plot_bars_values          :: [ (x,[y]) ]-}+   -- | The point on the bar to vertically anchor the label to+   _bars_settings_label_bar_vanchor  :: BarVertAnchor, -{-# DEPRECATED defaultPlotBars "Use the according Data.Default instance!" #-}-defaultPlotBars :: BarsPlotValue y => PlotBars x y-defaultPlotBars = def+    -- | The anchor point on the label.+   _bars_settings_label_text_hanchor :: HTextAnchor, -instance BarsPlotValue y => Default (PlotBars x y) where-  def = PlotBars-    { _plot_bars_style           = BarsClustered-    , _plot_bars_item_styles     = cycle istyles-    , _plot_bars_titles          = []-    , _plot_bars_spacing         = BarsFixGap 10 2-    , _plot_bars_alignment       = BarsCentered-    , _plot_bars_values          = []-    , _plot_bars_singleton_width = 20-    , _plot_bars_reference       = barsReference+    -- | 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     = renderPlotBars p,+        _plot_render     = \pmap -> renderBars s vals yref0+                                      (barRect pmap) (mapX pmap),         _plot_legend     = zip (_plot_bars_titles p)                                (map renderPlotLegendBars-                                    (_plot_bars_item_styles p)),-        _plot_all_points = allBarPoints p+                                    (_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 -renderPlotBars :: (BarsPlotValue y) => PlotBars x y -> PointMapFn x y -> ChartBackend ()-renderPlotBars p pmap = case (_plot_bars_style p) of+    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 (x,ys) = do-       forM_ (zip3 [0,1..] ys styles) $ \(i, y, (fstyle,_)) -> do-           withFillStyle fstyle $ do-             p <- alignFillPath (barPath (offset i) x yref0 y)-             fillPath p-       forM_ (zip3 [0,1..] ys styles) $ \(i, y, (_,mlstyle)) -> do-           whenJust mlstyle $ \lstyle -> do-             withLineStyle lstyle $ do-               p <- alignStrokePath (barPath (offset i) x yref0 y)-               strokePath p+    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 -    offset = case (_plot_bars_alignment p) of-      BarsLeft     -> \i -> fromIntegral i * width-      BarsRight    -> \i -> fromIntegral (i-nys) * width-      BarsCentered -> \i -> fromIntegral (2*i-nys) * width/2+    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 -    stackedBars (x,ys) = do-       let y2s = zip (yref0:stack ys) (stack ys)-       let ofs = case (_plot_bars_alignment p) of {-         BarsLeft     -> 0          ;-         BarsRight    -> (-width)   ;-         BarsCentered -> (-width/2)-         }-       forM_ (zip y2s styles) $ \((y0,y1), (fstyle,_)) -> do-           withFillStyle fstyle $ do-             p <- alignFillPath (barPath ofs x y0 y1)-             fillPath p-       forM_ (zip y2s styles) $ \((y0,y1), (_,mlstyle)) -> do-           whenJust mlstyle $ \lstyle -> do-              withLineStyle lstyle $ do-                p <- alignStrokePath (barPath ofs x y0 y1)-                strokePath p+    styles = _bars_settings_item_styles p -    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'))+    barPath os k v0 v1 = rectPath $ r os bsize k v0 v1 -    yref0 = _plot_bars_reference p-    vals  = _plot_bars_values p-    width = case _plot_bars_spacing p of-        BarsFixGap gap minw -> let w = max (minXInterval - gap) minw in-            case (_plot_bars_style p) of-                BarsClustered -> w / fromIntegral nys+    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-    styles = _plot_bars_item_styles p+        BarsFixWidth width' -> width' -    minXInterval = let diffs = zipWith (-) (tail mxs) mxs+    minKInterval = let diffs = zipWith (-) (tail mks) mks                    in if null diffs-                        then _plot_bars_singleton_width p+                        then _bars_settings_singleton_width p                         else minimum diffs       where-        xs  = fst (allBarPoints p)-        mxs = nub $ sort $ map mapX xs+        mks = nub $ sort $ map (mapk . fst) vals -    nys    = maximum [ length ys | (x,ys) <- vals ]+    nvs = maximum $ map (length . snd) vals -    pmap'  = mapXY pmap-    mapX x = p_x (pmap' (x,barsReference))+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 -whenJust :: (Monad m) => Maybe a -> (a -> m ()) -> m ()-whenJust (Just a) f = f a-whenJust _        _ = return ()+-- Helper function for printing bar values as labels+addLabels :: Show y => [(x, [y])] -> [(x, [(y, String)])]+addLabels = map . second $ map (\y -> (y, show y)) -allBarPoints :: (BarsPlotValue y) => PlotBars x y -> ([x],[y])-allBarPoints p = case (_plot_bars_style p) of-    BarsClustered -> ( [x| (x,_) <- pts], y0:concat [ys| (_,ys) <- pts] )-    BarsStacked   -> ( [x| (x,_) <- pts], y0:concat [stack ys | (_,ys) <- pts] )-  where-    pts = _plot_bars_values p-    y0  = _plot_bars_reference p+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 -stack :: (BarsPlotValue y) => [y] -> [y]-stack ys = scanl1 barsAdd ys+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 -> ChartBackend ()-renderPlotLegendBars (fstyle,mlstyle) r@(Rect p1 p2) = do-  withFillStyle fstyle $ do+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
@@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Graphics.Rendering.Chart.Plot.Candle--- Copyright   :  (c) Tim Docker 2006+-- Copyright   :  (c) Tim Docker 2006, 2014 -- License     :  BSD-style (see chart/COPYRIGHT) -- -- Candlestick charts for financial plotting@@ -11,7 +11,6 @@ module Graphics.Rendering.Chart.Plot.Candle(     PlotCandle(..),     Candle(..),-    defaultPlotCandle,      plot_candle_title,     plot_candle_line_style,@@ -24,17 +23,14 @@     plot_candle_values, ) where -import Control.Lens-import Data.Monoid+import Control.Lens hiding (op) -import Graphics.Rendering.Chart.Geometry+import Graphics.Rendering.Chart.Geometry hiding (close) import Graphics.Rendering.Chart.Drawing-import Graphics.Rendering.Chart.Renderable import Graphics.Rendering.Chart.Plot.Types import Control.Monad import Data.Colour (opaque)-import Data.Colour.Names (black, white, blue)-import Data.Colour.SRGB (sRGB)+import Data.Colour.Names (white, blue) import Data.Default.Class  -- | Value defining a financial interval: opening and closing prices, with@@ -77,8 +73,8 @@       where         pts = _plot_candle_values p -renderPlotCandle :: PlotCandle x y -> PointMapFn x y -> ChartBackend ()-renderPlotCandle p pmap = do+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) =@@ -90,6 +86,7 @@               (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@@ -98,7 +95,7 @@         -- 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) $ do+                                   else _plot_candle_fall_fill_style ps) $                     fillPath $ moveTo' (x-wd) open                             <> lineTo' (x-wd) close                             <> lineTo' (x+wd) close@@ -121,29 +118,25 @@                                     <> lineTo' (x+tl) lo                                     <> moveTo' (x-tl) hi                                     <> lineTo' (x+tl) hi-          -          when (ct > 0) $ do strokePath $ moveTo' (x-ct) mid-                                       <> lineTo' (x+ct) mid -renderPlotLegendCandle :: PlotCandle x y -> Rect -> ChartBackend ()-renderPlotLegendCandle p r@(Rect p1 p2) = do-    drawCandle p{ _plot_candle_width = 2}-                      (Candle ((p_x p1 + p_x p2)*1/4) lo open mid close hi)-    drawCandle p{ _plot_candle_width = 2}-                      (Candle ((p_x p1 + p_x p2)*2/3) lo close mid open 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 -{-# DEPRECATED defaultPlotCandle "Use the according Data.Default instance!" #-}-defaultPlotCandle :: PlotCandle x y-defaultPlotCandle = def- instance Default (PlotCandle x y) where-  def = PlotCandle +  def = PlotCandle     { _plot_candle_title       = ""     , _plot_candle_line_style  = solidLine 1 $ opaque blue     , _plot_candle_fill        = False
Graphics/Rendering/Chart/Plot/ErrBars.hs view
@@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Graphics.Rendering.Chart.Plot.ErrBars--- Copyright   :  (c) Tim Docker 2006+-- Copyright   :  (c) Tim Docker 2006, 2014 -- License     :  BSD-style (see chart/COPYRIGHT) -- -- Plot series of points with associated error bars.@@ -10,7 +10,6 @@  module Graphics.Rendering.Chart.Plot.ErrBars(     PlotErrBars(..),-    defaultPlotErrBars,     ErrPoint(..),     ErrValue(..),     symErrPoint,@@ -26,15 +25,12 @@ ) where  import Control.Lens-import Data.Monoid  import Graphics.Rendering.Chart.Geometry import Graphics.Rendering.Chart.Drawing-import Graphics.Rendering.Chart.Renderable import Graphics.Rendering.Chart.Plot.Types import Data.Colour (opaque)-import Data.Colour.Names (black, blue)-import Data.Colour.SRGB (sRGB)+import Data.Colour.Names (blue) import Data.Default.Class  -- | Value for holding a point with associated error bounds for each axis.@@ -78,8 +74,8 @@       where         pts = _plot_errbars_values p -renderPlotErrBars :: PlotErrBars x y -> PointMapFn x y -> ChartBackend ()-renderPlotErrBars p pmap = do+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)) =@@ -90,10 +86,11 @@     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) $ do+        withLineStyle (_plot_errbars_line_style ps) $           strokePath $ moveTo' (xl-oh) y                     <> lineTo' (xh+oh) y                     <> moveTo' x (yl-oh)@@ -107,22 +104,19 @@                     <> moveTo' (x-tl) yh                     <> lineTo' (x+tl) yh -renderPlotLegendErrBars :: PlotErrBars x y -> Rect -> ChartBackend ()-renderPlotLegendErrBars p r@(Rect p1 p2) = 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)+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)--{-# DEPRECATED defaultPlotErrBars "Use the according Data.Default instance!" #-}-defaultPlotErrBars :: PlotErrBars x y-defaultPlotErrBars = def+    y          = (p_y p1 + p_y p2)/2  instance Default (PlotErrBars x y) where-  def = PlotErrBars +  def = PlotErrBars     { _plot_errbars_title       = ""     , _plot_errbars_line_style  = solidLine 1 $ opaque blue     , _plot_errbars_tick_length = 3
Graphics/Rendering/Chart/Plot/FillBetween.hs view
@@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Graphics.Rendering.Chart.Plot.FillBetween--- Copyright   :  (c) Tim Docker 2006+-- Copyright   :  (c) Tim Docker 2006, 2014 -- License     :  BSD-style (see chart/COPYRIGHT) -- -- Plots that fill the area between two lines.@@ -10,22 +10,20 @@  module Graphics.Rendering.Chart.Plot.FillBetween(     PlotFillBetween(..),-    defaultPlotFillBetween,      -- * 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.Renderable import Graphics.Rendering.Chart.Plot.Types import Data.Colour (opaque)-import Data.Colour.Names (black, blue) import Data.Colour.SRGB (sRGB) import Data.Default.Class @@ -35,6 +33,7 @@ data PlotFillBetween x y = PlotFillBetween {     _plot_fillbetween_title  :: String,     _plot_fillbetween_style  :: FillStyle,+    _plot_fillbetween_line  :: Maybe LineStyle,     _plot_fillbetween_values :: [ (x, (y,y))] } @@ -46,23 +45,31 @@         _plot_all_points = plotAllPointsFillBetween p     } -renderPlotFillBetween :: PlotFillBetween x y -> PointMapFn x y -> ChartBackend ()-renderPlotFillBetween p pmap =-    renderPlotFillBetween' p (_plot_fillbetween_values p) pmap+renderPlotFillBetween :: PlotFillBetween x y -> PointMapFn x y -> BackendProgram ()+renderPlotFillBetween p =+    renderPlotFillBetween' p (_plot_fillbetween_values p) -renderPlotFillBetween' p [] _     = return ()+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,y2)) <- vs ]-    p2s      = map pmap' [ (x,y2) | (x,(y1,y2)) <- vs ]+    (p0:p1s) = map pmap' [ (x,y1) | (x,(y1,_)) <- vs ]+    p2s      = map pmap' [ (x,y2) | (x,(_,y2)) <- vs ] -renderPlotLegendFill :: PlotFillBetween x y -> Rect -> ChartBackend ()+renderPlotLegendFill :: PlotFillBetween x y -> Rect -> BackendProgram () renderPlotLegendFill p r = -  withFillStyle (_plot_fillbetween_style p) $ do+  withFillStyle (_plot_fillbetween_style p) $      fillPath (rectPath r)  plotAllPointsFillBetween :: PlotFillBetween x y -> ([x],[y])@@ -71,14 +78,11 @@   where     pts = _plot_fillbetween_values p -{-# DEPRECATED defaultPlotFillBetween "Use the according Data.Default instance!" #-}-defaultPlotFillBetween :: PlotFillBetween x y-defaultPlotFillBetween = def - 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 = []     }
Graphics/Rendering/Chart/Plot/Hidden.hs view
@@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Graphics.Rendering.Chart.Plot.Hidden--- Copyright   :  (c) Tim Docker 2006+-- 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@@ -11,16 +11,16 @@  module Graphics.Rendering.Chart.Plot.Hidden(     PlotHidden(..),+    +    plot_hidden_x_values,+    plot_hidden_y_values ) where  import Control.Lens-import Graphics.Rendering.Chart.Geometry-import Graphics.Rendering.Chart.Drawing-import Graphics.Rendering.Chart.Renderable import Graphics.Rendering.Chart.Plot.Types --- | Value defining some hidden x and y values. The values don't---   get displayed, but still affect axis scaling.+-- | 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]
+ 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
@@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Graphics.Rendering.Chart.Plot.Lines--- Copyright   :  (c) Tim Docker 2006+-- Copyright   :  (c) Tim Docker 2006, 2014 -- License     :  BSD-style (see chart/COPYRIGHT) -- -- Line plots@@ -10,7 +10,6 @@  module Graphics.Rendering.Chart.Plot.Lines(     PlotLines(..),-    defaultPlotLines,     defaultPlotLineStyle,     hlinePlot,     vlinePlot,@@ -24,10 +23,9 @@ import Control.Lens import Graphics.Rendering.Chart.Geometry import Graphics.Rendering.Chart.Drawing-import Graphics.Rendering.Chart.Renderable import Graphics.Rendering.Chart.Plot.Types import Data.Colour (opaque)-import Data.Colour.Names (black, blue)+import Data.Colour.Names (blue) import Data.Default.Class  -- | Value defining a series of (possibly disjointed) lines,@@ -56,7 +54,7 @@         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 -> ChartBackend ()+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)@@ -64,8 +62,8 @@   where     drawLines mapfn pts = alignStrokePoints (map mapfn pts) >>= strokePointPath  -renderPlotLegendLines :: PlotLines x y -> Rect -> ChartBackend ()-renderPlotLegendLines p r@(Rect p1 p2) = +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]@@ -77,10 +75,6 @@      _line_join = LineJoinRound  } -{-# DEPRECATED defaultPlotLines "Use the according Data.Default instance!" #-}-defaultPlotLines :: PlotLines x y-defaultPlotLines = def- instance Default (PlotLines x y) where   def = PlotLines      { _plot_lines_title        = ""@@ -91,7 +85,7 @@  -- | Helper function to plot a single horizontal line. hlinePlot :: String -> LineStyle -> b -> Plot a b-hlinePlot t ls v = toPlot defaultPlotLines {+hlinePlot t ls v = toPlot def {     _plot_lines_title        = t,     _plot_lines_style        = ls,     _plot_lines_limit_values = [[(LMin, LValue v),(LMax, LValue v)]]@@ -99,7 +93,7 @@  -- | Helper function to plot a single vertical line. vlinePlot :: String -> LineStyle -> a -> Plot a b-vlinePlot t ls v = toPlot defaultPlotLines {+vlinePlot t ls v = toPlot def {     _plot_lines_title        = t,     _plot_lines_style        = ls,     _plot_lines_limit_values = [[(LValue v,LMin),(LValue v,LMax)]]
Graphics/Rendering/Chart/Plot/Pie.hs view
@@ -1,241 +1,228 @@------------------------------------------------------------------------------
--- |
--- Module      :  Graphics.Rendering.Chart.Plot.Pie
--- Copyright   :  (c) Tim Docker 2008
--- 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
---        $ defaultPieLayout
--- renderable = toRenderable layout
--- @
-{-# LANGUAGE TemplateHaskell #-}
-
-module Graphics.Rendering.Chart.Plot.Pie(
-    PieLayout(..),
-    PieChart(..),
-    PieItem(..),
-    defaultPieLayout,
-    defaultPieChart,
-    defaultPieItem,
-    
-    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
-
-import Data.List
-import Data.Bits
-import Control.Lens hiding (moveTo)
-import Data.Colour
-import Data.Colour.Names (black, white)
-import Data.Monoid
-import Data.Default.Class
-import Control.Monad
-
-import Graphics.Rendering.Chart.Geometry
-import Graphics.Rendering.Chart.Drawing
-import Graphics.Rendering.Chart.Legend
-import Graphics.Rendering.Chart.Renderable
-import Graphics.Rendering.Chart.Grid
-import Graphics.Rendering.Chart.Plot.Types
-
-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
-}
-
-{-# DEPRECATED defaultPieChart  "Use the according Data.Default instance!" #-}
-defaultPieChart :: PieChart
-defaultPieChart = def
-
-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
-    }
-
-{-# DEPRECATED defaultPieItem  "Use the according Data.Default instance!" #-}
-defaultPieItem :: PieItem
-defaultPieItem = def
-
-instance Default PieItem where
-  def = PieItem "" 0 0
-
-{-# DEPRECATED defaultPieLayout  "Use the according Data.Default instance!" #-}
-defaultPieLayout :: PieLayout
-defaultPieLayout = def
-
-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        = defaultPieChart
-    , _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 -> ChartBackend (Double, Double)
-extraSpace p = do
-    textSizes <- mapM textDimension (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 :: PieChart -> ChartBackend (Double, Double)
-minsizePie p = do
-    (extraw,extrah) <- extraSpace p
-    return (extraw * 2, extrah * 2)
-
-renderPie :: PieChart -> (Double, Double) -> ChartBackend (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 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)
-              -> ChartBackend 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 -> ChartBackend ()
-                pieLabel name angle offset = do
-                    withFontStyle (_pie_label_style p) $ do
-                      withLineStyle (_pie_label_line_style p) $ do
-                        let p1 = ray angle (radius+label_rgap+label_rlength+offset)
-                        p1a <- alignStrokePoint $ p1
-                        (tw,th) <- 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 $ 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 -> ChartBackend ()
-                pieSlice (Point x y) a1 a2 color = do
-                    let path = arc' x y radius (radian a1) (radian a2)
-                            <> lineTo' x y
-                            <> lineTo' x y
-                            <> close
-
-                    withFillStyle (FillStyleSolid color) $ do
-                      fillPath path
-                    withLineStyle (def { _line_color = withOpacity white 0.1 }) $ do
-                      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
-                    x''  = ((x + r) - x)
-                    x    = p_x center
-                    y    = p_y center
-
-                radian = (*(pi / 180.0))
-
-
-label_rgap = 5
-label_rlength = 15
-
-$( makeLenses ''PieLayout )
-$( makeLenses ''PieChart )
-$( makeLenses ''PieItem )
+-----------------------------------------------------------------------------+-- |+-- 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
@@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Graphics.Rendering.Chart.Plot.Points--- Copyright   :  (c) Tim Docker 2006+-- Copyright   :  (c) Tim Docker 2006, 2014 -- License     :  BSD-style (see chart/COPYRIGHT) -- -- Functions to plot sets of points, marked in various styles.@@ -10,7 +10,6 @@  module Graphics.Rendering.Chart.Plot.Points(     PlotPoints(..),-    defaultPlotPoints,      -- * Accessors     -- | These accessors are generated by template haskell@@ -23,10 +22,7 @@ import Control.Lens import Graphics.Rendering.Chart.Geometry import Graphics.Rendering.Chart.Drawing-import Graphics.Rendering.Chart.Renderable import Graphics.Rendering.Chart.Plot.Types-import Data.Colour (opaque)-import Data.Colour.Names (black, blue) import Data.Default.Class  -- | Value defining a series of datapoints, and a style in@@ -46,25 +42,22 @@       where         pts = _plot_points_values p -renderPlotPoints :: PlotPoints x y -> PointMapFn x y -> ChartBackend ()-renderPlotPoints p pmap = do+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)+    ps = _plot_points_style p -renderPlotLegendPoints :: PlotPoints x y -> Rect -> ChartBackend ()-renderPlotLegendPoints p r@(Rect p1 p2) = do-    drawPoint ps (Point (p_x p1)              ((p_y p1 + p_y p2)/2))-    drawPoint ps (Point ((p_x p1 + p_x p2)/2) ((p_y p1 + p_y p2)/2))-    drawPoint ps (Point (p_x p2)              ((p_y p1 + p_y p2)/2))+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)--{-# DEPRECATED defaultPlotPoints  "Use the according Data.Default instance!" #-}-defaultPlotPoints :: PlotPoints x y-defaultPlotPoints = def+    ps = _plot_points_style p+    y = (p_y p1 + p_y p2)/2  instance Default (PlotPoints x y) where   def = PlotPoints
Graphics/Rendering/Chart/Plot/Types.hs view
@@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Graphics.Rendering.Chart.Plot.Types--- Copyright   :  (c) Tim Docker 2006+-- Copyright   :  (c) Tim Docker 2006, 2014 -- License     :  BSD-style (see chart/COPYRIGHT) -- -- Datatypes and functions common to the implementation of the various@@ -24,23 +24,19 @@  import Graphics.Rendering.Chart.Geometry import Graphics.Rendering.Chart.Drawing-import Graphics.Rendering.Chart.Renderable-import Control.Monad import Control.Lens-import Data.Colour-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 -> ChartBackend (),+    _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 -> ChartBackend ()) ],+    _plot_legend     :: [ (String, Rect -> BackendProgram ()) ],      -- | All of the model space coordinates to be plotted. These are     --   used to autoscale the axes where necessary.@@ -51,6 +47,9 @@ 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@@ -68,7 +67,7 @@  ---------------------------------------------------------------------- -mapXY :: PointMapFn x y -> ((x,y) -> Point)+mapXY :: PointMapFn x y -> (x,y) -> Point mapXY f (x,y) = f (LValue x, LValue y)  ----------------------------------------------------------------------
+ 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,21 +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,-    +    Rectangle(..),+    RectCornerStyle(..),+     rectangleToRenderable,+    drawRectangle,      fillBackground,     addMargins,@@ -38,8 +42,6 @@  import Control.Monad import Control.Lens-import Data.List ( nub, transpose, sort )-import Data.Monoid import Data.Default.Class  import Graphics.Rendering.Chart.Geometry@@ -50,7 +52,7 @@ -- --   Perhaps it might be generalised from Maybe a to --   (MonadPlus m ) => m a in the future.-type PickFn a = Point -> (Maybe a)+type PickFn a = Point -> Maybe a  nullPickFn :: PickFn a nullPickFn = const Nothing@@ -59,25 +61,29 @@ --   graphic element. data Renderable a = Renderable { -   -- | A Cairo action to calculate a minimum size.-   minsize :: ChartBackend 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 -> ChartBackend (PickFn a)+   render  :: RectSize -> BackendProgram (PickFn a) }+  deriving (Functor)  -- | A type class abtracting the conversion of a value to a Renderable. class ToRenderable a where   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 :: RectSize -> Renderable a spacer sz  = Renderable {    minsize = return sz,    render  = \_ -> return nullPickFn@@ -91,7 +97,7 @@  -- | Replace the pick function of a renderable with another. setPickFn :: PickFn b -> Renderable a -> Renderable b-setPickFn pickfn r = r{ render  = \sz -> do { render r sz; return pickfn; } }+setPickFn pickfn r = r{ render  = \sz -> render r sz >> return pickfn }  -- | Map a function over the result of a renderable's pickfunction, keeping only 'Just' results. mapMaybePickFn :: (a -> Maybe b) -> Renderable a -> Renderable b@@ -112,14 +118,14 @@         (w,h) <- minsize rd         return (w+l+r,h+t+b) -    rf (w,h) = do+    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)) -    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+    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 :: FillStyle -> Renderable a -> Renderable a@@ -132,8 +138,8 @@       render r rsize  -- | Helper function for using a renderable, when we generate it---   in the CRender monad.-embedRenderable :: ChartBackend (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 }@@ -148,34 +154,42 @@ 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.+--   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 = withFontStyle fs $ do        ts <- textSize s-       let (w,h) = (textSizeWidth ts, textSizeHeight ts)-       return (w*acr+h*asr,w*asr+h*acr)+       let sz = (textSizeWidth ts, textSizeHeight ts)+       return (xwid sz, ywid sz)+     rf (w0,h0) = withFontStyle fs $ do       ts <- textSize s       let sz@(w,h) = (textSizeWidth ts, textSizeHeight ts)-      let descent = textSizeDescent ts-      withTranslation (Point 0 (-descent)) $ do-        withTranslation (Point (xadj sz hta 0 w0) (yadj sz vta 0 h0)) $ do+          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-    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      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 @@ -190,10 +204,6 @@   _rect_cornerStyle :: RectCornerStyle } -{-# DEPRECATED defaultRectangle "Use the according Data.Default instance!" #-}-defaultRectangle :: Rectangle-defaultRectangle = def- instance Default Rectangle where   def = Rectangle     { _rect_minsize     = (0,0)@@ -208,47 +218,54 @@ rectangleToRenderable :: Rectangle -> Renderable a rectangleToRenderable rectangle = Renderable mf rf   where-    mf    = return (_rect_minsize rectangle)-    rf sz = do-      maybeM () (fill sz) (_rect_fillStyle rectangle)-      maybeM () (stroke sz) (_rect_lineStyle rectangle)-      return nullPickFn+    mf = return (_rect_minsize rectangle)+    rf = \rectSize -> drawRectangle (Point 0 0)+                                    rectangle{ _rect_minsize = rectSize } -    fill sz fs = do-        withFillStyle fs $ do-          fillPath $ strokeRectangleP sz (_rect_cornerStyle rectangle)+-- | 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 -    stroke sz ls = do-        withLineStyle ls $ do-          strokePath $ strokeRectangleP sz (_rect_cornerStyle rectangle)+      fill p sz fs =+          withFillStyle fs $+            fillPath $ strokeRectangleP p sz (_rect_cornerStyle rectangle) -    strokeRectangleP (x2,y2) RCornerSquare =-      let (x1,y1) = (0,0) in moveTo' x1 y1-                          <> lineTo' x1 y2-                          <> lineTo' x2 y2-                          <> lineTo' x2 y1-                          <> lineTo' x1 y1-                          <> lineTo' x1 y2-                                -    strokeRectangleP (x2,y2) (RCornerBevel s) =-      let (x1,y1) = (0,0) in moveTo' x1 (y1+s)-                          <> lineTo' x1 (y2-s)-                          <> lineTo' (x1+s) y2-                          <> lineTo' (x2-s) y2-                          <> lineTo' x2 (y2-s)-                          <> lineTo' x2 (y1+s)-                          <> lineTo' (x2-s) y1-                          <> lineTo' (x1+s) y1-                          <> lineTo' x1 (y1+s)-                          <> lineTo' x1 (y2-s)+      stroke p sz ls =+          withLineStyle ls $+            strokePath $ strokeRectangleP p sz (_rect_cornerStyle rectangle) -    strokeRectangleP (x2,y2) (RCornerRounded s) =-      let (x1,y1) = (0,0) in arcNeg (Point (x1+s) (y2-s)) s (pi2*2) pi2 -                          <> arcNeg (Point (x2-s) (y2-s)) s pi2 0-                          <> arcNeg (Point (x2-s) (y1+s)) s 0 (pi2*3)-                          <> arcNeg (Point (x1+s) (y1+s)) s (pi2*3) (pi2*2)-                          <> lineTo' x1 (y2-s)-    -    pi2 = pi / 2+      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++      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)++      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,38 +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 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:------ > 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,-                                        plotPDF, plotPS,-                                        plotLayout, plotPNG, LayoutDDD,-                                        layoutDddToRenderable-                                      , PlotPDFType(..)-                                      , PlotPSType(..)-                                      , PlotPNGType(..)-                                      , uplot-                                      ) where--import Graphics.Rendering.Chart.Simple.Internal
− Graphics/Rendering/Chart/Simple/Internal.hs 
@@ -1,269 +0,0 @@--module Graphics.Rendering.Chart.Simple.Internal where--import Data.Maybe ( catMaybes )-import Data.Colour-import Data.Colour.Names-import Data.Default.Class--import Graphics.Rendering.Chart-import Graphics.Rendering.Chart.Utils---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 ]--iplot :: (PlotValue x, PlotValue y) => [InternalPlot x y] -> Layout x y-iplot foobar = def {-        _layout_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 = plots-      where-        vs = zip xs ys-        plots = case catMaybes $ map plotas yks of-                    [] -> [ toPlot $ def-                           { _plot_lines_title  = name yks,-                             _plot_lines_values = [vs],-                             _plot_lines_style  = solidLine 1 (styleColor ind)-                           } ]-                    xs -> xs-        plotas Solid = Just $ toPlot $ def-                         { _plot_lines_title  = name yks,-                           _plot_lines_values = [vs],-                           _plot_lines_style  = solidLine 1 (styleColor ind) }-        plotas Dashed = Just $ toPlot $ def-                         { _plot_lines_title  = name yks,-                           _plot_lines_values = [vs],-                           _plot_lines_style  = dashedLine 1 [10,10]-                                                           (styleColor ind) }-        plotas Dotted = Just $ toPlot $ def-                         { _plot_lines_title  = name yks,-                           _plot_lines_values = [vs],-                           _plot_lines_style  = dashedLine 1 [1,11]-                                                           (styleColor ind) }-        plotas FilledCircle = Just $ toPlot $ def-                         { _plot_points_title  = name yks,-                           _plot_points_values = vs,-                           _plot_points_style  = filledCircles 4-                                                           (styleColor ind) }-        plotas HollowCircle = Just $ toPlot $ def-                         { _plot_points_title  = name yks,-                           _plot_points_values = vs,-                           _plot_points_style  = hollowCircles 5 1-                                                           (styleColor ind) }-        plotas Triangle = Just $ toPlot $ def-                         { _plot_points_title  = name yks,-                           _plot_points_values = vs,-                           _plot_points_style  = hollowPolygon 7 1 3 False-                                                           (styleColor ind) }-        plotas DownTriangle = Just $ toPlot $ def-                         { _plot_points_title  = name yks,-                           _plot_points_values = vs,-                           _plot_points_style  = hollowPolygon 7 1 3 True-                                                           (styleColor ind) }-        plotas Square = Just $ toPlot $ def-                         { _plot_points_title  = name yks,-                           _plot_points_values = vs,-                           _plot_points_style  = hollowPolygon 7 1 4 False-                                                           (styleColor ind) }-        plotas Diamond = Just $ toPlot $ def-                         { _plot_points_title  = name yks,-                           _plot_points_values = vs,-                           _plot_points_style  = hollowPolygon 7 1 4 True-                                                           (styleColor ind) }-        plotas Plus = Just $ toPlot $ def-                         { _plot_points_title  = name yks,-                           _plot_points_values = vs,-                           _plot_points_style  = plusses 7 1 (styleColor ind) }-        plotas Ex = Just $ toPlot $ def-                         { _plot_points_title  = name yks,-                           _plot_points_values = vs,-                           _plot_points_style  = exes 7 1 (styleColor ind) }-        plotas Star = Just $ toPlot $ def-                         { _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 LayoutDDD = LayoutDDD { plotLayout :: Layout Double Double }--layoutDddToRenderable :: LayoutDDD -> Renderable (LayoutPick Double Double Double)-layoutDddToRenderable = layoutToRenderable . plotLayout--instance ToRenderable LayoutDDD where-  toRenderable = setPickFn nullPickFn . toRenderable--uplot :: [UPlot] -> LayoutDDD-uplot us = LayoutDDD $ 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 LayoutDDD where-    pl args = uplot (reverse args)---- | 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)---- | 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)---- | 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)--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
@@ -1,27 +1,29 @@ --------------------------------------------------------------- -- | -- Module      : Graphics.Rendering.Chart.Sparkline--- Copyright   : (c) Hitesh Jasani, 2008, Malcolm Wallace 2011+-- Copyright   : (c) Hitesh Jasani, 2008, Malcolm Wallace 2011, Tim Docker 2014 -- License     : BSD3 ----- Created     : 2008-02-26--- Modified    : 2011-02-11--- Version     : 0.2------ Sparklines implementation in Haskell.  Sparklines are--- mini graphs inspired by Edward Tufte.+-- 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 uses Cairo as its renderer, and integrates with+-- <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 can be composed into grids etc.+-- 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] -- >--- > sparkLineToPNG "bar_spark.png" (SparkLine barSpark dp)+-- > sl = SparkLine barSpark dp+-- > fopts = FileOptions (sparkSize sl) PNG+-- > renderableToFile fopts (sparkLineToRenderable sl) "bar_spark.png"  -- > --------------------------------------------------------------- @@ -90,9 +92,10 @@ barSpark :: SparkOptions barSpark  = smoothSpark { so_smooth=False } +-- | Create a renderable from a SparkLine. sparkLineToRenderable :: SparkLine -> Renderable () sparkLineToRenderable sp = Renderable-            { minsize = return (0, fromIntegral (so_height (sl_options sp)))+            { minsize = let (w,h) = sparkSize sp in return (fromIntegral w , fromIntegral h)             , render  = \_rect-> renderSparkLine sp             } @@ -109,11 +112,12 @@          | 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 using cairo.-renderSparkLine :: SparkLine -> ChartBackend (PickFn ())+-- | 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
+ 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/Utils.hs view
@@ -1,16 +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 +-- | 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