packages feed

Chart 0.17 → 1.9.5

raw patch · 58 files changed

Files

Chart.cabal view
@@ -1,62 +1,56 @@ Name: Chart-Version: 0.17+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 -Extra-Source-Files:-     tests/all_tests.hs,-     tests/Test1.hs,-     tests/Test2.hs,-     tests/Test3.hs,-     tests/Test4.hs,-     tests/Test5.hs,-     tests/Test6.hs,-     tests/Test7.hs,-     tests/Test8.hs,-     tests/Test9.hs,-     tests/Test14.hs,-     tests/Test14a.hs,-     tests/Test15.hs,-     tests/Test17.hs,-     tests/TestParametric.hs,     -     tests/Prices.hs-     tests/ExampleStocks.hs+library+  default-language: Haskell98+  Build-depends: base >= 3 && < 5+               , old-locale+               , time, array+               , lens >= 3.9 && < 5.3+               , colour >= 2.2.1 && < 2.4+               , data-default-class < 0.2+               , mtl >= 2.0 && < 2.4+               , operational >= 0.2.2 && < 0.3+               , vector >=0.9 && <0.14 -flag splitbase-  description: Choose the new smaller, split-up base package.+  if !impl(ghc >= 8.0)+    build-depends: semigroups >= 0.18.4 && <0.19 -library-  if flag(splitbase)-    Build-depends: base >= 3 && < 5, old-locale, time, mtl, array-  else-    Build-depends: base < 3-  Build-depends: cairo >= 0.9.11, time, mtl, array, data-accessor == 0.2.*, -                 data-accessor-template >= 0.2.1.1 && < 0.3, colour >= 2.2.1 +  Ghc-options: -Wall -fno-warn-orphans+   Exposed-modules:         Graphics.Rendering.Chart,-        Graphics.Rendering.Chart.Types,+        Graphics.Rendering.Chart.Drawing,+        Graphics.Rendering.Chart.Geometry,+        Graphics.Rendering.Chart.Utils,         Graphics.Rendering.Chart.Renderable,         Graphics.Rendering.Chart.Axis,         Graphics.Rendering.Chart.Axis.Floating,         Graphics.Rendering.Chart.Axis.Indexed,         Graphics.Rendering.Chart.Axis.Int,+        Graphics.Rendering.Chart.Axis.Time,         Graphics.Rendering.Chart.Axis.LocalTime,         Graphics.Rendering.Chart.Axis.Types,         Graphics.Rendering.Chart.Axis.Unit,         Graphics.Rendering.Chart.Layout,         Graphics.Rendering.Chart.Legend,-        Graphics.Rendering.Chart.Simple,-        Graphics.Rendering.Chart.Simple.Internal,         Graphics.Rendering.Chart.Grid,         Graphics.Rendering.Chart.Plot,         Graphics.Rendering.Chart.Plot.Types,@@ -68,10 +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,49 +1,61 @@ ---------------------------------------------------------------------------- -- | -- Module      :  Graphics.Rendering.Chart--- Copyright   :  (c) Tim Docker 2006+-- Copyright   :  (c) Tim Docker 2006-2013 -- License     :  BSD-style (see chart/COPYRIGHT) -- -- A framework for creating 2D charts in Haskell. ----- The basic model is that you define a value of type 'Renderable',--- typically by applying 'toRenderable' to some other value. This--- 'Renderable' is then actually displayed or output by calling either--- 'renderableToPNGFile', or '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. -- -----------------------------------------------------------------------------  module Graphics.Rendering.Chart( -    module Graphics.Rendering.Chart.Types,+    module Graphics.Rendering.Chart.Geometry,+    module Graphics.Rendering.Chart.Drawing,     module Graphics.Rendering.Chart.Renderable,     module Graphics.Rendering.Chart.Layout,     module Graphics.Rendering.Chart.Axis,     module Graphics.Rendering.Chart.Plot,     module Graphics.Rendering.Chart.Legend,+    module Graphics.Rendering.Chart.Backend.Types  ) where -import Graphics.Rendering.Chart.Types+import Graphics.Rendering.Chart.Geometry+import Graphics.Rendering.Chart.Drawing import Graphics.Rendering.Chart.Renderable import Graphics.Rendering.Chart.Layout import Graphics.Rendering.Chart.Axis import Graphics.Rendering.Chart.Plot import Graphics.Rendering.Chart.Legend+import Graphics.Rendering.Chart.Backend.Types
Graphics/Rendering/Chart/Axis.hs view
@@ -7,14 +7,11 @@ -- Code to calculate and render axes. -- -{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# OPTIONS_GHC -XTemplateHaskell #-}- module Graphics.Rendering.Chart.Axis(     module Graphics.Rendering.Chart.Axis.Types,     module Graphics.Rendering.Chart.Axis.Floating,     module Graphics.Rendering.Chart.Axis.Int,-    module Graphics.Rendering.Chart.Axis.LocalTime,+    module Graphics.Rendering.Chart.Axis.Time,     module Graphics.Rendering.Chart.Axis.Unit,     module Graphics.Rendering.Chart.Axis.Indexed, ) where@@ -22,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@@ -9,15 +9,15 @@ --  {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# OPTIONS_GHC -XTemplateHaskell #-}+{-# 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,19 +30,29 @@     loga_labelf ) where -import Data.List(minimumBy)+import Data.List(minimumBy, nub) import Data.Ord (comparing)-import Numeric (showFFloat)+import Data.Default.Class+import Numeric (showEFloat, showFFloat) -import Data.Accessor.Template-import Graphics.Rendering.Chart.Types+import Control.Lens+import Graphics.Rendering.Chart.Geometry+import Graphics.Rendering.Chart.Utils import Graphics.Rendering.Chart.Axis.Types +-- Note: the following code uses explicit Integer types+-- to avoid -Wall 'defaulting to Integer' messages.+ instance PlotValue Double where     toValue  = id     fromValue= id-    autoAxis = autoScaledAxis 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}@@ -54,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@@ -67,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@@ -76,34 +176,34 @@  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,+    _la_nLabels :: Int,      -- | The target number of ticks to be shown.-    la_nTicks_  :: Int+    _la_nTicks  :: Int } -defaultLinearAxis :: (Show a, RealFloat a) => LinearAxisParams a-defaultLinearAxis = LinearAxisParams {-    la_labelf_    = showD,-    la_nLabels_   = 5,-    la_nTicks_    = 50-}+instance (Show a, RealFloat a) => Default (LinearAxisParams a) where+  def = LinearAxisParams+    { _la_labelf    = showDs+    , _la_nLabels   = 5+    , _la_nTicks    = 50+    }  -- | Generate a linear axis with the specified bounds scaledAxis :: RealFloat a => LinearAxisParams a -> (a,a) -> AxisFn a-scaledAxis lap (min,max) ps0 = makeAxis' realToFrac realToFrac-                                         (la_labelf_ lap) (labelvs,tickvs,gridvs)+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)-    labelvs   = map fromRational $ steps (fromIntegral (la_nLabels_ lap)) r-    tickvs    = map fromRational $ steps (fromIntegral (la_nTicks_ lap))+    range _   | minV == maxV = if minV==0 then (-1,1) else+                               let d = abs (minV * 0.01) in (minV-d,maxV+d)+              | otherwise    = rs+    labelvs   = map fromRational $ steps (fromIntegral (_la_nLabels lap)) r+    tickvs    = map fromRational $ steps (fromIntegral (_la_nTicks lap))                                          (minimum labelvs,maximum labelvs)     gridvs    = labelvs     r         = range ps@@ -111,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,@@ -139,95 +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  ---------------------------------------------------------------------- -defaultLogAxis :: (Show a, RealFloat a) => LogAxisParams a-defaultLogAxis = LogAxisParams {-    loga_labelf_ = showD-}+instance (Show a, RealFloat a) => Default (LogAxisParams a) where+  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--frac x | 0 <= b    = (a,b)-       | otherwise = (a-1,b+1)- where-  (a,b) = properFraction x+  ratio' :: Double+  ratio' = fromRational (h'/l')+  filterX = filter (\x -> l'<=x && x <=h') . powers (dl',dh') -$( deriveAccessors ''LinearAxisParams )-$( deriveAccessors ''LogAxisParams )+  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,20 +1,23 @@ ----------------------------------------------------------------------------- -- | -- 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 #-}-{-# OPTIONS_GHC -XTemplateHaskell #-}+{-# LANGUAGE TupleSections #-}  module Graphics.Rendering.Chart.Axis.Indexed(     PlotIndex(..),+    autoIndexAxis',     autoIndexAxis,     addIndexes, ) where +import Data.Default.Class+ import Graphics.Rendering.Chart.Axis.Types  -- | Type for capturing values plotted by index number@@ -29,22 +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 {-    axis_viewport_ = vport,-    axis_tropweiv_ = invport,-    axis_ticks_    = [],-    axis_labels_   = [filter (\(i,l) -> i >= imin && i <= imax)-                            (zip [0..] labels)],-    axis_grid_     = []+autoIndexAxis' :: Integral i => Bool -> [String] -> AxisFn i+autoIndexAxis' tks labels vs = AxisData {+    _axis_visibility = def { _axis_show_ticks = False },+    _axis_viewport = vport,+    _axis_tropweiv = invport,+    _axis_ticks    = if tks then map (, 5) $ take (length labels) [0..] else [],+    _axis_labels   = [filter (\(i,_) -> i >= imin && i <= imax)+                             (zip [0..] labels)],+    _axis_grid     = []     }   where     vport r i = linMap id ( fromIntegral imin - 0.5                           , fromIntegral imax + 0.5) r (fromIntegral i)-    invport 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,13 +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--{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# OPTIONS_GHC -XTemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}  module Graphics.Rendering.Chart.Axis.Int(     defaultIntAxis,@@ -16,7 +14,9 @@ ) where  import Data.List(genericLength)-import Graphics.Rendering.Chart.Types+import Data.Int (Int8, Int16, Int32, Int64)+import Data.Word (Word8, Word16, Word32, Word64)+import Graphics.Rendering.Chart.Geometry import Graphics.Rendering.Chart.Axis.Types import Graphics.Rendering.Chart.Axis.Floating @@ -25,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@@ -32,28 +77,28 @@  defaultIntAxis :: (Show a) => LinearAxisParams a defaultIntAxis  = LinearAxisParams {-    la_labelf_  = show,-    la_nLabels_ = 5,-    la_nTicks_  = 10+    _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 =-    makeAxis (la_labelf_ lap) (labelvs,tickvs,gridvs)+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)+    labelvs   = stepsInt (fromIntegral $ _la_nLabels lap) r+    tickvs    = stepsInt (fromIntegral $ _la_nTicks lap)                                   ( fromIntegral $ minimum labelvs                                   , fromIntegral $ maximum labelvs )     gridvs    = labelvs@@ -64,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,39 +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 -{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# OPTIONS_GHC -XTemplateHaskell #-}+module Graphics.Rendering.Chart.Axis.LocalTime+    {-# DEPRECATED "Use Graphics.Rendering.Chart.Axis.Time module" #-}+    (+    TimeSeq,+    TimeLabelFn,+    TimeLabelAlignment(..), -module Graphics.Rendering.Chart.Axis.LocalTime(     timeAxis,     autoTimeAxis,-    days, months, years-) where -import qualified Graphics.Rendering.Cairo as C+    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-import Data.Accessor.Template-import Data.Colour (opaque)-import Data.Colour.Names (black, lightgrey)-import Data.Ord (comparing)+#endif+import Data.Fixed+import Control.Lens -import Graphics.Rendering.Chart.Types-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 ()  ---------------------------------------------------------------------- @@ -57,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@@ -80,43 +84,53 @@                         | 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_viewport_ = vmap(min', max'),-    axis_tropweiv_ = invmap(min', max'),-    axis_ticks_    = [ (t,2) | t <- times] ++ [ (t,5) | t <- ltimes, visible t],-    axis_labels_   = [ [ (t,l) | (t,l) <- labels labelf   ltimes lal, visible t]+    _axis_visibility = def,+    _axis_viewport = vmap(min', max'),+    _axis_tropweiv = invmap(min', max'),+    _axis_ticks    = [ (t,2) | t <- times] ++ [ (t,5) | t <- ltimes, visible t],+    _axis_labels   = [ [ (t,l) | (t,l) <- labels labelf   ltimes lal, visible t]                      , [ (t,l) | (t,l) <- labels contextf ctimes clal, visible t]-                     ], -    axis_grid_     = [ t     | t <- ltimes, visible t]+                     ],+    _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@@ -147,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@@ -179,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@@ -195,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@@ -204,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@@ -221,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,24 +1,23 @@ ----------------------------------------------------------------------------- -- | -- 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 -- -{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# OPTIONS_GHC -XTemplateHaskell #-}+{-# LANGUAGE TemplateHaskell #-}  module Graphics.Rendering.Chart.Axis.Types(     AxisData(..),+    AxisVisibility(..),     AxisT(..),     AxisStyle(..),     PlotValue(..),     AxisFn,      defaultAxisLineStyle,-    defaultAxisStyle,     defaultGridLineStyle,      makeAxis,@@ -37,10 +36,13 @@     axisGridAtBigTicks,     axisGridAtLabels,     axisGridHide,-    axisTicksHide,-    axisLabelsHide,     axisLabelsOverride,+    +    axis_show_line,+    axis_show_ticks,+    axis_show_labels, +    axis_visibility,     axis_viewport,     axis_tropweiv,     axis_ticks,@@ -54,18 +56,15 @@  ) where -import qualified Graphics.Rendering.Cairo as C-import Data.Time-import Data.Fixed-import Data.Maybe-import System.Locale (defaultTimeLocale) import Control.Monad import Data.List(sort,intersperse)-import Data.Accessor.Template+import Control.Lens hiding (at, re) import Data.Colour (opaque) import Data.Colour.Names (black, lightgrey)+import Data.Default.Class -import Graphics.Rendering.Chart.Types+import Graphics.Rendering.Chart.Geometry+import Graphics.Rendering.Chart.Drawing import Graphics.Rendering.Chart.Renderable  -- | A typeclass abstracting the functions we need@@ -75,14 +74,30 @@     fromValue:: Double -> a     autoAxis :: AxisFn a +-- | Configures whick visual elements of a axis are shown at the+--   appropriate edge of a plot area.+data AxisVisibility = AxisVisibility+  { -- | Whether to display a line along the axis.+    _axis_show_line :: Bool+    +    -- | Whether to display the tick marks.+  , _axis_show_ticks :: Bool++    -- | Whether to display the labels.+  , _axis_show_labels :: Bool+  }+ -- | The basic data associated with an axis showing values of type x. data AxisData x = AxisData {--    -- | The axis_viewport_ function maps values into device coordinates.-    axis_viewport_ :: Range -> x -> Double,+    +    -- | Which parts of the axis shall be displayed.+    _axis_visibility :: AxisVisibility,+    +    -- | The _axis_viewport function maps values into device coordinates.+    _axis_viewport :: Range -> x -> Double, -    -- | The axis_tropweiv_ function maps device coordinates back to values.-    axis_tropweiv_ :: Range -> Double -> x,+    -- | The _axis_tropweiv function maps device coordinates back to values.+    _axis_tropweiv :: Range -> Double -> x,      -- | The tick marks on the axis as pairs.     --   The first element is the position on the axis@@ -90,28 +105,31 @@     --   length of the tick in output coordinates.     --   The tick starts on the axis, and positive numbers are drawn     --   towards the plot area.-    axis_ticks_    :: [(x,Double)],+    _axis_ticks    :: [(x,Double)],      -- | The labels on an axis as pairs. The first element of the pair     --   is the position on the axis (in viewport units) and the     --   second is the label text string. Note that multiple sets of     --   labels can be specified, and are shown successively further     --   away from the axis line.-    axis_labels_   :: [[(x, String)]],+    _axis_labels   :: [[(x, String)]],      -- | The positions on the axis (in viewport units) where     --   we want to show grid lines.-    axis_grid_     :: [ x ]+    _axis_grid     :: [ x ] }  -- | Control values for how an axis gets displayed. data AxisStyle = AxisStyle {-    axis_line_style_  :: CairoLineStyle,-    axis_label_style_ :: CairoFontStyle,-    axis_grid_style_  :: CairoLineStyle,+    -- | 'LineStyle' to use for axis line and ticks.+    _axis_line_style  :: LineStyle,+    -- | 'FontStyle' to use for axis labels.+    _axis_label_style :: FontStyle,+    -- | 'LineStyle' to use for axis grid.+    _axis_grid_style  :: LineStyle,      -- | How far the labels are to be drawn from the axis.-    axis_label_gap_   :: Double+    _axis_label_gap   :: Double }  -- | A function to generate the axis data, given the data values@@ -134,47 +152,42 @@  -- | Modifier to remove grid lines from an axis axisGridHide         :: AxisData x -> AxisData x-axisGridHide ad       = ad{ axis_grid_ = [] }+axisGridHide ad       = ad{ _axis_grid = [] }  -- | Modifier to position grid lines to line up with the ticks axisGridAtTicks      :: AxisData x -> AxisData x-axisGridAtTicks ad    = ad{ axis_grid_ = map fst (axis_ticks_ ad) }+axisGridAtTicks ad    = ad{ _axis_grid = map fst (_axis_ticks ad) }  -- | Modifier to position grid lines to line up with only the major ticks axisGridAtBigTicks   :: AxisData x -> AxisData x-axisGridAtBigTicks ad = ad{ axis_grid_ =+axisGridAtBigTicks ad = ad{ _axis_grid =                             map fst $-                            filter ((> minimum (map (abs.snd) (axis_ticks_ ad))).snd) $-                            axis_ticks_ ad }+                            filter ((> minimum (map (abs.snd) (_axis_ticks ad))).snd) $+                            _axis_ticks ad }  -- | Modifier to position grid lines to line up with the labels axisGridAtLabels     :: AxisData x -> AxisData x-axisGridAtLabels ad   = ad{ axis_grid_ = map fst vs }+axisGridAtLabels ad   = ad{ _axis_grid = map fst vs }   where-    vs = case axis_labels_ ad of+    vs = case _axis_labels ad of         [] -> []         ls -> head ls --- | Modifier to remove ticks from an axis-axisTicksHide       :: AxisData x -> AxisData x-axisTicksHide ad     = ad{ axis_ticks_  = [] }---- | Modifier to remove labels from an axis-axisLabelsHide      :: AxisData x -> AxisData x-axisLabelsHide ad    = ad{ axis_labels_ = []}- -- | Modifier to change labels on an axis axisLabelsOverride  :: [(x,String)] -> AxisData x -> AxisData x-axisLabelsOverride o ad = ad{ axis_labels_ = [o] }+axisLabelsOverride o ad = ad{ _axis_labels = [o] } -minsizeAxis :: AxisT x -> CRender RectSize-minsizeAxis (AxisT at as rev ad) = do-    labelSizes <- preserveCState $ do-        setFontStyle (axis_label_style_ as)-        mapM (mapM textSize) (labelTexts 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) $+                    mapM (mapM textDimension) labels -    let ag      = axis_label_gap_ as-    let tsize   = maximum ([0] ++ [ max 0 (-l) | (v,l) <- axis_ticks_ ad ])+    let ag      = _axis_label_gap as+    let tsize   = maximum (0 : [ max 0 (-l) | (_,l) <- ticks ])      let hw = maximum0 (map (maximum0.map fst) labelSizes)     let hh = ag + tsize + (sum . intersperse ag . map (maximum0.map snd) $ labelSizes)@@ -183,77 +196,77 @@     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)+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 -> CRender (Double,Double)-axisOverhang (AxisT at as rev ad) = do-    let labels = map snd . sort . concat . axis_labels_ $ ad-    labelSizes <- preserveCState $ do-        setFontStyle (axis_label_style_ as)-        mapM textSize labels+axisOverhang :: (Ord x) => AxisT x -> BackendProgram (Double,Double)+axisOverhang (AxisT at as _ ad) = do+    let labels = map snd . sort . concat . _axis_labels $ ad+    labelSizes <- withFontStyle (_axis_label_style as) $+      mapM textDimension labels     case labelSizes of-        []  -> return (0,0)-	ls  -> let l1     = head ls-		   l2     = last ls-		   ohangv = return (snd l1 / 2, snd l2 / 2)-		   ohangh = return (fst l1 / 2, fst l2 / 2)-		   in-		   case at of-		       E_Top    -> ohangh-		       E_Bottom -> ohangh-		       E_Left   -> ohangv-		       E_Right  -> ohangh--renderAxis :: AxisT x -> RectSize -> CRender (PickFn x)-renderAxis at@(AxisT et as rev ad) sz = do-   let ls = axis_line_style_ as-   preserveCState $ do-       setLineStyle ls{line_cap_=C.LineCapSquare}-       strokePath [Point sx sy,Point ex ey]-   preserveCState $ do-       setLineStyle ls{line_cap_=C.LineCapButt}-       mapM_ drawTick (axis_ticks_ ad)-   preserveCState $ do-       setFontStyle (axis_label_style_ as)-       labelSizes <- mapM (mapM textSize) (labelTexts ad)-       let sizes = map ((+ag).maximum0.map coord) labelSizes-       let offsets = scanl (+) ag sizes-       mapM_ drawLabels (zip offsets  (axis_labels_ ad))+      []  -> return (0,0)+      ls  -> let l1     = head ls+                 l2     = last ls+                 ohangv = return (snd l1 / 2, snd l2 / 2)+                 ohangh = return (fst l1 / 2, fst l2 / 2)+             in case at of+                 E_Top    -> ohangh+                 E_Bottom -> ohangh+                 E_Left   -> ohangv+                 E_Right  -> ohangh -   return pickfn+renderAxis :: AxisT x -> RectSize -> BackendProgram (PickFn x)+renderAxis at@(AxisT et as _ ad) sz = do+  let ls = _axis_line_style as+      vis = _axis_visibility ad+  when (_axis_show_line vis) $ +    withLineStyle (ls {_line_cap = LineCapSquare}) $ do+      p <- alignStrokePoints [Point sx sy,Point ex ey]+      strokePointPath p+  when (_axis_show_ticks vis) $ +    withLineStyle (ls {_line_cap = LineCapButt}) $ +      mapM_ drawTick (_axis_ticks ad)+  when (_axis_show_labels vis) $ +    withFontStyle (_axis_label_style as) $ do+      labelSizes <- mapM (mapM textDimension) (labelTexts ad)+      let sizes = map ((+ag).maximum0.map coord) labelSizes+      let offsets = scanl (+) ag sizes+      mapM_ drawLabels (zip offsets  (_axis_labels ad))+  return pickfn  where    (sx,sy,ex,ey,tp,axisPoint,invAxisPoint) = axisMapping at sz -   drawTick (value,length) =+   drawTick (value,len) =        let t1 = axisPoint value-	   t2 = t1 `pvadd` (vscale length tp)-       in strokePath [t1,t2]+           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)) @@ -262,16 +275,16 @@         mapM_ drawLabel labels'      where        drawLabel (value,s) = do-           drawText hta vta (axisPoint value `pvadd` (awayFromAxis offset)) s-           textSize s+           drawTextA hta vta (axisPoint value `pvadd` awayFromAxis offset) s+           textDimension s -   ag = axis_label_gap_ as+   ag = _axis_label_gap as    pickfn = Just . invAxisPoint  hBufferRect :: Rect -> Rect hBufferRect (Rect p (Point x y)) = Rect p $ Point x' y   where x' = x + w/2-        w = x - (p_x p)+        w = x - p_x p  noOverlaps :: [Rect] -> Bool noOverlaps [] = True@@ -287,6 +300,7 @@         p4 = Point x2 y1         ps = [p1,p2,p3,p4] +eachNth :: Int -> [a] -> [a] eachNth n = skipN   where     n' = n - 1@@ -300,32 +314,31 @@  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)+    mapx y x = Point (_axis_viewport ad xr x) y+    mapy x y = Point x (_axis_viewport ad yr y) -    imapx (Point x _) = axis_tropweiv_ ad xr x-    imapy (Point _ y) = axis_tropweiv_ ad yr y+    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 -> CRender ()-renderAxisGrid sz@(w,h) at@(AxisT re as rev ad) = do-    preserveCState $ do-        setLineStyle (axis_grid_style_ as)-        mapM_ (drawGridLine re) (axis_grid_ ad)+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@@ -333,59 +346,82 @@     drawGridLine E_Right  = hline      vline v = let v' = p_x (axisPoint v)-	      in strokePath [Point v' 0,Point v' h]+              in alignStrokePoints [Point v' 0,Point v' h] >>= strokePointPath      hline v = let v' = p_y (axisPoint v)-	      in strokePath [Point 0 v',Point w v']+              in alignStrokePoints [Point 0 v',Point w v'] >>= strokePointPath   -- | Construct an axis given the positions for ticks, grid lines, and  -- labels, and the labelling function-makeAxis :: PlotValue x => (x -> String) -> ([x],[x],[x]) -> AxisData x+makeAxis :: PlotValue x => ([x] -> [String]) -> ([x],[x],[x]) -> AxisData x makeAxis labelf (labelvs, tickvs, gridvs) = AxisData {-    axis_viewport_ = newViewport,-    axis_tropweiv_ = newTropweiv,-    axis_ticks_    = newTicks,-    axis_grid_     = gridvs,-    axis_labels_   = [newLabels]+    _axis_visibility = def,+    _axis_viewport = newViewport,+    _axis_tropweiv = newTropweiv,+    _axis_ticks    = newTicks,+    _axis_grid     = gridvs,+    _axis_labels   = [newLabels]     }   where     newViewport = vmap (min',max')     newTropweiv = invmap (min',max')     newTicks    = [ (v,2)        | v <- tickvs  ] ++ [ (v,5) | v <- labelvs ]-    newLabels   = [ (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_viewport_ = linMap t (minimum labelvs, maximum labelvs),-    axis_tropweiv_ = invLinMap f t (minimum labelvs, maximum labelvs),-    axis_ticks_    = zip tickvs (repeat 2)  ++  zip labelvs (repeat 5),-    axis_grid_     = gridvs,-    axis_labels_   = [[ (v,labelf v) | v <- labelvs ]]+    _axis_visibility = def,+    _axis_viewport = linMap t (minimum labelvs, maximum labelvs),+    _axis_tropweiv = invLinMap f t (minimum labelvs, maximum labelvs),+    _axis_ticks    = zip tickvs (repeat 2)  ++  zip labelvs (repeat 5),+    _axis_grid     = gridvs,+    _axis_labels   =+      let zipWithLengthCheck (x:xs) (y:ys) = (x,y) : zipWithLengthCheck xs ys+          zipWithLengthCheck [] [] = []+          zipWithLengthCheck _ _ =+            error "makeAxis': label function returned the wrong number of labels"+      in [zipWithLengthCheck labelvs (labelf labelvs)]     }   ---------------------------------------------------------------------- -defaultAxisLineStyle :: CairoLineStyle+-- | The default 'LineStyle' of an axis.+defaultAxisLineStyle :: LineStyle defaultAxisLineStyle = solidLine 1 $ opaque black -defaultGridLineStyle :: CairoLineStyle+-- | The default 'LineStyle' of a plot area grid.+defaultGridLineStyle :: LineStyle defaultGridLineStyle = dashedLine 1 [5,5] $ opaque lightgrey -defaultAxisStyle :: AxisStyle-defaultAxisStyle = AxisStyle {-    axis_line_style_  = defaultAxisLineStyle,-    axis_label_style_ = defaultFontStyle,-    axis_grid_style_  = defaultGridLineStyle,-    axis_label_gap_   = 10-}+instance Default AxisStyle where+  def = AxisStyle +    { _axis_line_style  = defaultAxisLineStyle+    , _axis_label_style = def+    , _axis_grid_style  = defaultGridLineStyle+    , _axis_label_gap   = 10+    } +-- | By default all parts of a axis are visible.+instance Default AxisVisibility where+  def = AxisVisibility+    { _axis_show_line   = True+    , _axis_show_ticks  = True+    , _axis_show_labels = True+    }+ ----------------------------------------------------------------------  -- | A linear mapping of points in one range to another.@@ -412,9 +448,7 @@   where     doubleRange = t v4 - t v3 -------------------------------------------------------------------------- Template haskell to derive an instance of Data.Accessor.Accessor for--- each field.-$( deriveAccessors ''AxisData )-$( deriveAccessors ''AxisStyle )+$( makeLenses ''AxisVisibility )+$( makeLenses ''AxisData )+$( makeLenses ''AxisStyle )
Graphics/Rendering/Chart/Axis/Unit.hs view
@@ -5,14 +5,14 @@ -- License     :  BSD-style (see chart/COPYRIGHT) -- -- Calculate and render unit indexed axes--{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# OPTIONS_GHC -XTemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}  module Graphics.Rendering.Chart.Axis.Unit(     unitAxis, ) where +import Data.Default.Class+ import Graphics.Rendering.Chart.Axis.Types  instance PlotValue () where@@ -22,9 +22,13 @@  unitAxis :: AxisData () unitAxis = AxisData {-    axis_viewport_ = \(x0,x1) _ -> (x0+x1)/2,-    axis_tropweiv_ = \_       _ -> (),-    axis_ticks_    = [((), 0)],-    axis_labels_   = [[((), "")]],-    axis_grid_     = []+    _axis_visibility = def +                     { _axis_show_ticks  = False+                     , _axis_show_labels = False +                     },+    _axis_viewport = \(x0,x1) _ -> (x0+x1)/2,+    _axis_tropweiv = \_       _ -> (),+    _axis_ticks    = [((), 0)],+    _axis_labels   = [[((), "")]],+    _axis_grid     = [] }
+ Graphics/Rendering/Chart/Backend.hs view
@@ -0,0 +1,67 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Graphics.Rendering.Chart.Backend+-- Copyright   :  (c) Tim Docker 2014+-- License     :  BSD-style (see chart/COPYRIGHT)+--+-- This module provides the API for drawing operations abstracted+-- to drive arbitrary Backend.++module Graphics.Rendering.Chart.Backend+  (+  -- * The backend Monad+    BackendProgram+  +  -- * Backend Operations+  , fillPath+  , strokePath+  , drawText, textSize+  , withTransform+  , withClipRegion+  , withFontStyle, withFillStyle, withLineStyle+  +  -- * Backend Helpers+--  , getTransform+--  , getFillStyle, getFontStyle+--  , getLineStyle, getClipRegion+  , getPointAlignFn, getCoordAlignFn++  -- * Text Metrics+  , TextSize(..)                     +  +  -- * Line Types+  , LineCap(..)+  , LineJoin(..)+  , LineStyle(..)+  +  , line_width+  , line_color+  , line_dashes+  , line_cap+  , line_join+  +  -- * Fill Types+  , FillStyle(..)++  -- * Font and Text Types+  , FontWeight(..)+  , FontSlant(..)+  , FontStyle(..)++  , HTextAnchor(..)+  , VTextAnchor(..)++  , font_name+  , font_size+  , font_slant+  , font_weight+  , font_color+  +  , AlignmentFn+  , AlignmentFns+  , vectorAlignmentFns+  , bitmapAlignmentFns+  ) where++import Graphics.Rendering.Chart.Backend.Types+import Graphics.Rendering.Chart.Backend.Impl
+ Graphics/Rendering/Chart/Backend/Impl.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE GADTs #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Graphics.Rendering.Chart.Backend.Impl+-- Copyright   :  (c) Tim Docker 2014+-- License     :  BSD-style (see chart/COPYRIGHT)+--+-- This module provides the implementation details common to all 'ChartBackend's.++module Graphics.Rendering.Chart.Backend.Impl where++import Control.Monad+import Control.Monad.Operational++import Graphics.Rendering.Chart.Geometry+import Graphics.Rendering.Chart.Backend.Types++-- -----------------------------------------------------------------------+-- Rendering Backend Class+-- -----------------------------------------------------------------------++-- | The abstract drawing operation generated when using the+--   the chart drawing API.+--+--   See the documentation of the different function for the correct semantics+--   of each instruction:+--+--   * 'strokePath', 'fillPath'+--+--   * 'drawText', 'textSize'+--+--   * 'getPointAlignFn', 'getCoordAlignFn', 'AlignmentFns'+--+--   * 'withTransform', 'withClipRegion'+--+--   * 'withLineStyle', 'withFillStyle', 'withFontStyle'+--+data ChartBackendInstr a where+  StrokePath :: Path -> ChartBackendInstr ()+  FillPath   :: Path -> ChartBackendInstr ()+  GetTextSize :: String -> ChartBackendInstr TextSize+  DrawText    :: Point -> String -> ChartBackendInstr ()+  GetAlignments :: ChartBackendInstr AlignmentFns+  WithTransform  :: Matrix ->  Program ChartBackendInstr a -> ChartBackendInstr a+  WithFontStyle  :: FontStyle -> Program ChartBackendInstr a -> ChartBackendInstr a+  WithFillStyle  :: FillStyle -> Program ChartBackendInstr a -> ChartBackendInstr a+  WithLineStyle  :: LineStyle -> Program ChartBackendInstr a -> ChartBackendInstr a+  WithClipRegion :: Rect -> Program ChartBackendInstr a -> ChartBackendInstr a++-- | A 'BackendProgram' provides the capability to render a chart somewhere.+--+--   The coordinate system of the backend has its initial origin (0,0)+--   in the top left corner of the drawing plane. The x-axis points+--   towards the top right corner and the y-axis points towards+--   the bottom left corner. The unit used by coordinates, the font size,+--   and lengths is the always the same, but depends on the backend.+--   All angles are measured in radians.+--+--   The line, fill and font style are set to their default values+--   initially.+--+--   Information about the semantics of the instructions can be+--   found in the documentation of 'ChartBackendInstr'.+type BackendProgram a = Program ChartBackendInstr a++-- | Stroke the outline of the given path using the+--   current 'LineStyle'. This function does /not/ perform+--   alignment operations on the path. See 'Path' for the exact semantic+--   of paths.+strokePath :: Path -> BackendProgram ()+strokePath p = singleton (StrokePath p)++-- | Fill the given path using the current 'FillStyle'.+--   The given path will be closed prior to filling.+--   This function does /not/ perform+--   alignment operations on the path.+--   See 'Path' for the exact semantic of paths.+fillPath :: Path -> BackendProgram ()+fillPath p = singleton (FillPath p)++-- | Calculate a 'TextSize' object with rendering information+--   about the given string without actually rendering it.+textSize :: String -> BackendProgram TextSize+textSize text = singleton (GetTextSize text)++-- | Draw a single-line textual label anchored by the baseline (vertical)+--   left (horizontal) point. Uses the current 'FontStyle' for drawing.+drawText :: Point -> String -> BackendProgram ()+drawText p text = singleton (DrawText p text)++-- | Apply the given transformation in this local+--   environment when drawing. The given transformation+--   is applied after the current transformation. This+--   means both are combined.+withTransform :: Matrix -> BackendProgram a -> BackendProgram a+withTransform t p = singleton (WithTransform t p)++-- | Use the given font style in this local+--   environment when drawing text.+--+--   An implementing backend is expected to guarantee+--   to support the following font families: @serif@, @sans-serif@ and @monospace@;+--+--   If the backend is not able to find or load a given font+--   it is required to fall back to a custom fail-safe font+--   and use it instead.+withFontStyle :: FontStyle -> BackendProgram a -> BackendProgram a+withFontStyle fs p = singleton (WithFontStyle fs p)++-- | Use the given fill style in this local+--   environment when filling paths.+withFillStyle :: FillStyle -> BackendProgram a -> BackendProgram a+withFillStyle fs p = singleton (WithFillStyle fs p)++-- | Use the given line style in this local+--   environment when stroking paths.+withLineStyle :: LineStyle -> BackendProgram a -> BackendProgram a+withLineStyle ls p = singleton (WithLineStyle ls p)++-- | Use the given clipping rectangle when drawing+--   in this local environment. The new clipping region+--   is intersected with the given clip region. You cannot+--   escape the clip!+withClipRegion :: Rect -> BackendProgram a -> BackendProgram a+withClipRegion c p = singleton (WithClipRegion c p)++-- -----------------------------------------------------------------------+-- Rendering Utility Functions+-- -----------------------------------------------------------------------++-- | Get the point alignment function+getPointAlignFn :: BackendProgram (Point->Point)+getPointAlignFn = liftM afPointAlignFn (singleton GetAlignments)++-- | Get the coordinate alignment function+getCoordAlignFn :: BackendProgram (Point->Point)+getCoordAlignFn = liftM afCoordAlignFn (singleton GetAlignments)+
+ Graphics/Rendering/Chart/Backend/Types.hs view
@@ -0,0 +1,189 @@+{-# LANGUAGE TemplateHaskell #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Graphics.Rendering.Chart.Backend.Types+-- Copyright   :  (c) Tim Docker 2014+-- License     :  BSD-style (see chart/COPYRIGHT)+--++module Graphics.Rendering.Chart.Backend.Types where++import Data.Default.Class+import Data.Colour+import Data.Colour.Names+import Control.Lens++import Graphics.Rendering.Chart.Geometry++-- -----------------------------------------------------------------------+-- Line Types+-- -----------------------------------------------------------------------++-- | The different supported line ends.+data LineCap = LineCapButt   -- ^ Just cut the line straight.+             | LineCapRound  -- ^ Make a rounded line end.+             | LineCapSquare -- ^ Make a square that ends the line.+             deriving (Show, Eq, Ord)++-- | The different supported ways to join line ends.+data LineJoin = LineJoinMiter -- ^ Extends the outline until they meet each other.+              | LineJoinRound -- ^ Draw a circle fragment to connet line end.+              | LineJoinBevel -- ^ Like miter, but cuts it off if a certain +                              --   threshold is exceeded.+              deriving (Show, Eq, Ord)++-- | Data type for the style of a line.+data LineStyle = LineStyle +  { _line_width  :: Double+  -- ^ The thickness of a line in device units.+  , _line_color  :: AlphaColour Double+  -- ^ The color of a line.+  , _line_dashes :: [Double]+  -- ^ The dash pattern. Every value at a even index gives a dash width and +  --   every value at a odd index gives a gap width in device units.+  , _line_cap    :: LineCap+  -- ^ How to end a line.+  , _line_join   :: LineJoin+  -- ^ How to connect two lines.+  } deriving (Show, Eq)++-- | The default line style.+instance Default LineStyle where+  def = LineStyle +    { _line_width  = 1+    , _line_color  = opaque black+    , _line_dashes = []+    , _line_cap    = LineCapButt+    , _line_join   = LineJoinBevel+    }++-- -----------------------------------------------------------------------+-- Font & Text Types+-- -----------------------------------------------------------------------++-- | The possible slants of a font.+data FontSlant = FontSlantNormal  -- ^ Normal font style without slant.+               | FontSlantItalic  -- ^ With a slight slant.+               | FontSlantOblique -- ^ With a greater slant.+               deriving (Show, Eq, Ord)++-- | The default font slant.+instance Default FontSlant where+  def = FontSlantNormal++-- | The possible weights of a font.+data FontWeight = FontWeightNormal -- ^ Normal font style without weight.+                | FontWeightBold   -- ^ Bold font.+                deriving (Show, Eq, Ord)++-- | The default font weight.+instance Default FontWeight where+  def = FontWeightNormal++-- | Data type for a font.+data FontStyle = FontStyle {+      _font_name   :: String,+      -- ^ The font family or font face to use.+      _font_size   :: Double,+      -- ^ The height of the rendered font in device coordinates.+      _font_slant  :: FontSlant,+      -- ^ The slant to render with.+      _font_weight :: FontWeight,+      -- ^ The weight to render with.+      _font_color  :: AlphaColour Double+      -- ^ The color to render text with.+} deriving (Show, Eq)++-- | The default font style.+instance Default FontStyle where+  def = FontStyle +    { _font_name   = "sans-serif"+    , _font_size   = 10+    , _font_slant  = def+    , _font_weight = def+    , _font_color  = opaque black+    }++-- | Possible horizontal anchor points for text.+data HTextAnchor = HTA_Left +                 | HTA_Centre +                 | HTA_Right +                 deriving (Show, Eq, Ord)++-- | Possible vertical anchor points for text.+data VTextAnchor = VTA_Top +                 | VTA_Centre +                 | VTA_Bottom +                 | VTA_BaseLine +                 deriving (Show, Eq, Ord)++-- | Text metrics returned by 'textSize'.+data TextSize = TextSize +  { textSizeWidth    :: Double -- ^ The total width of the text.+  , textSizeAscent   :: Double -- ^ The ascent or space above the baseline.+  , textSizeDescent  :: Double -- ^ The decent or space below the baseline.+  , textSizeYBearing :: Double -- ^ The Y bearing.+  , textSizeHeight   :: Double -- ^ The total height of the text.+  } deriving (Show, Eq)++-- -----------------------------------------------------------------------+-- Fill Types+-- -----------------------------------------------------------------------++-- | Abstract data type for a fill style.+--+--   The contained action sets the required fill+--   style in the rendering state.+newtype FillStyle = FillStyleSolid +  { _fill_color :: AlphaColour Double +  } deriving (Show, Eq)++-- | The default fill style.+instance Default FillStyle where+  def = FillStyleSolid { _fill_color = opaque white }++-------------------------------------------------------------------------++-- | A function to align points for a certain rendering device.+type AlignmentFn = Point -> Point++-- | Holds the point and coordinate alignment function.+data AlignmentFns = AlignmentFns {+  afPointAlignFn :: AlignmentFn,+  -- ^ An adjustment applied immediately prior to points+  --   being displayed in device coordinates.+  --+  --   When device coordinates correspond to pixels, a cleaner+  --   image is created if this transform rounds to the nearest+  --   pixel. With higher-resolution output, this transform can+  --   just be the identity function.+  --   +  --   This is usually used to align prior to stroking.++  -- | The adjustment applied immediately prior to coordinates+  --   being transformed.+  --   +  --   This is usually used to align prior to filling.+  afCoordAlignFn :: AlignmentFn+  }++-- | Alignment to render on raster based graphics.+bitmapAlignmentFns :: AlignmentFns+bitmapAlignmentFns = AlignmentFns (adjfn 0.5) (adjfn 0.0) +  where+    adjfn offset (Point x y) = Point (adj x) (adj y)+      where+        -- avoid messages about Integer default+        rnd :: Double -> Integer+        rnd = round+        adj v = (fromIntegral.rnd) v +offset++-- | Alignment to render on vector based graphics.+vectorAlignmentFns :: AlignmentFns+vectorAlignmentFns = AlignmentFns id id++$( makeLenses ''LineStyle )+$( makeLenses ''FontStyle )+$( makeLenses ''FillStyle )+
+ Graphics/Rendering/Chart/Drawing.hs view
@@ -0,0 +1,504 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Graphics.Rendering.Chart.Drawing+-- Copyright   :  (c) Tim Docker 2006, 2014+-- License     :  BSD-style (see chart/COPYRIGHT)+--+-- This module contains basic types and functions used for drawing.+--+-- Note that Template Haskell is used to derive accessor functions+-- (see 'Control.Lens') for each field of the following data types:+--+--    * 'PointStyle'+--+-- These accessors are not shown in this API documentation.  They have+-- the same name as the field, but with the trailing underscore+-- dropped. Hence for data field @f_::F@ in type @D@, they have type+--+-- @+--   f :: Control.Lens.Lens' D F+-- @+--++{-# LANGUAGE TemplateHaskell #-}++module Graphics.Rendering.Chart.Drawing+  ( -- * Point Types and Drawing+    PointShape(..)+  , PointStyle(..)+  , drawPoint++  -- * Alignments and Paths+  , alignPath+  , alignFillPath+  , alignStrokePath+  , alignFillPoints+  , alignStrokePoints++  , alignFillPoint+  , alignStrokePoint++  , strokePointPath+  , fillPointPath++  -- * Transformation and Style Helpers+  , withRotation+  , withTranslation+  , withScale+  , withScaleX, withScaleY+  , withPointStyle+  , withDefaultStyle++  -- * Text Drawing+  , drawTextA+  , drawTextR+  , drawTextsR+  , textDrawRect+  , textDimension++  -- * Style Helpers+  , defaultColorSeq++  , solidLine+  , dashedLine++  , filledCircles+  , hollowCircles+  , filledPolygon+  , hollowPolygon+  , plusses+  , exes+  , stars+  , arrows++  , solidFillStyle++  -- * Backend and general Types+  , module Graphics.Rendering.Chart.Backend++  -- * Accessors+  , point_color+  , point_border_color+  , point_border_width+  , point_radius+  , point_shape+) where++import Data.Default.Class+-- lens < 4 includes Control.Lens.Zipper.moveTo which clashes+-- with Graphics.Rendering.Chart.Geometry.moveTo (so you get+-- -Wall notices). This would suggest a 'hiding (moveTo)' in+-- the import, but it's been removed in lens-4.0 and I don't+-- feel it's worth the use of conditional compilation. This does+-- lead to the qualified Geometry import below.+import Control.Lens+import Data.Colour+import Data.Colour.Names+import Data.List (unfoldr)++import Graphics.Rendering.Chart.Backend+import Graphics.Rendering.Chart.Geometry hiding (moveTo)+import qualified Graphics.Rendering.Chart.Geometry as G++-- -----------------------------------------------------------------------+-- Transformation helpers+-- -----------------------------------------------------------------------++-- | Apply a local rotation. The angle is given in radians.+withRotation :: Double -> BackendProgram a -> BackendProgram a+withRotation angle = withTransform (rotate angle 1)++-- | Apply a local translation.+withTranslation :: Point -> BackendProgram a -> BackendProgram a+withTranslation p = withTransform (translate (pointToVec p) 1)++-- | Apply a local scale.+withScale :: Vector -> BackendProgram a -> BackendProgram a+withScale v = withTransform (scale v 1)++-- | Apply a local scale on the x-axis.+withScaleX :: Double -> BackendProgram a -> BackendProgram a+withScaleX x = withScale (Vector x 1)++-- | Apply a local scale on the y-axis.+withScaleY :: Double -> BackendProgram a -> BackendProgram a+withScaleY y = withScale (Vector 1 y)++-- | Changes the 'LineStyle' and 'FillStyle' to comply with+--   the given 'PointStyle'.+withPointStyle :: PointStyle -> BackendProgram a -> BackendProgram a+withPointStyle (PointStyle cl bcl bw _ _) m =+  withLineStyle (def { _line_color = bcl, _line_width = bw, _line_join = LineJoinMiter }) $+    withFillStyle (solidFillStyle cl) m++withDefaultStyle :: BackendProgram a -> BackendProgram a+withDefaultStyle = withLineStyle def . withFillStyle def . withFontStyle def++-- -----------------------------------------------------------------------+-- Alignment Helpers+-- -----------------------------------------------------------------------++-- | Align the path by applying the given function on all points.+alignPath :: (Point -> Point) -> Path -> Path+alignPath f = foldPath (G.moveTo . f)+                       (lineTo . f)+                       (arc . f)+                       (arcNeg . f)+                       close++-- | Align the path using the environment's alignment function for points.+--   This is generally useful when stroking.+--   See 'alignPath' and 'getPointAlignFn'.+alignStrokePath :: Path -> BackendProgram Path+alignStrokePath p = do+  f <- getPointAlignFn+  return $ alignPath f p++-- | Align the path using the environment's alignment function for coordinates.+--   This is generally useful when filling.+--   See 'alignPath' and 'getCoordAlignFn'.+alignFillPath :: Path -> BackendProgram Path+alignFillPath p = do+  f <- getCoordAlignFn+  return $ alignPath f p++-- | The points will be aligned by the 'getPointAlignFn', so that+--   when drawing bitmaps, 1 pixel wide lines will be centred on the+--   pixels.+alignStrokePoints :: [Point] -> BackendProgram [Point]+alignStrokePoints p = do+  f <- getPointAlignFn+  return $ fmap f p++-- | The points will be aligned by the 'getCoordAlignFn', so that+--   when drawing bitmaps, the edges of the region will fall between+--   pixels.+alignFillPoints :: [Point] -> BackendProgram [Point]+alignFillPoints p = do+  f <- getCoordAlignFn+  return $ fmap f p++-- | Align the point using the environment's alignment function for points.+--   See 'getPointAlignFn'.+alignStrokePoint :: Point -> BackendProgram Point+alignStrokePoint p = do+    alignfn <- getPointAlignFn+    return (alignfn p)++-- | Align the point using the environment's alignment function for coordinates.+--   See 'getCoordAlignFn'.+alignFillPoint :: Point -> BackendProgram Point+alignFillPoint p = do+    alignfn <- getCoordAlignFn+    return (alignfn p)++-- | Create a path by connecting all points with a line.+--   The path is not closed.+stepPath :: [Point] -> Path+stepPath (p:ps) = G.moveTo p+               <> mconcat (map lineTo ps)+stepPath [] = mempty++-- | Draw lines between the specified points.+strokePointPath :: [Point] -> BackendProgram ()+strokePointPath pts = strokePath $ stepPath pts++-- | Fill the region with the given corners.+fillPointPath :: [Point] -> BackendProgram ()+fillPointPath pts = fillPath $ stepPath pts++-- -----------------------------------------------------------------------+-- Text Drawing+-- -----------------------------------------------------------------------++-- | Draw a line of text that is aligned at a different anchor point.+--   See 'drawText'.+drawTextA :: HTextAnchor -> VTextAnchor -> Point -> String -> BackendProgram ()+drawTextA hta vta = drawTextR hta vta 0++{-+   The following is useful for checking out the bounding-box+   calculation. At present it looks okay for PNG/Cairo but+   is a bit off for SVG/Diagrams; this may well be down to+   differences in how fonts are rendered in the two backends++drawTextA hta vta p txt =+  drawTextR hta vta 0 p txt+  >> withLineStyle (solidLine 1 (opaque red))+     (textDrawRect hta vta p txt+       >>= \rect -> alignStrokePath (rectPath rect) >>= strokePath)+-}++-- | Draw a textual label anchored by one of its corners+--   or edges, with rotation. Rotation angle is given in degrees,+--   rotation is performed around anchor point.+--   See 'drawText'.+drawTextR :: HTextAnchor -> VTextAnchor -> Double -> Point -> String -> BackendProgram ()+drawTextR hta vta angle p s =+  withTranslation p $+    withRotation theta $ do+      ts <- textSize s+      drawText (adjustText hta vta ts) s+  where+    theta = angle*pi/180.0++-- | Draw a multi-line textual label anchored by one of its corners+--   or edges, with rotation. Rotation angle is given in degrees,+--   rotation is performed around anchor point.+--   See 'drawText'.+drawTextsR :: HTextAnchor -> VTextAnchor -> Double -> Point -> String -> BackendProgram ()+drawTextsR hta vta angle p s = case num of+      0 -> return ()+      1 -> drawTextR hta vta angle p s+      _ ->+        withTranslation p $+          withRotation theta $ do+            tss <- mapM textSize ss+            let ts = head tss+            let -- widths = map textSizeWidth tss+                -- maxw   = maximum widths+                maxh   = maximum (map textSizeYBearing tss)+                gap    = maxh / 2 -- half-line spacing+                totalHeight = fromIntegral num*maxh ++                              (fromIntegral num-1)*gap+                ys = take num (unfoldr (\y-> Just (y, y-gap-maxh))+                                       (yinit vta ts totalHeight))+                xs = map (adjustTextX hta) tss+            sequence_ (zipWith3 drawT xs ys ss)+    where+      ss   = lines s+      num  = length ss++      drawT x y = drawText (Point x y)+      theta = angle*pi/180.0++      yinit VTA_Top      ts _      = textSizeAscent ts+      yinit VTA_BaseLine _  _      = 0+      yinit VTA_Centre   ts height = height / 2 + textSizeAscent ts+      yinit VTA_Bottom   ts height = height + textSizeAscent ts++-- | Calculate the correct offset to align the text anchor.+adjustText :: HTextAnchor -> VTextAnchor -> TextSize -> Point+adjustText hta vta ts = Point (adjustTextX hta ts) (adjustTextY vta ts)++-- | Calculate the correct offset to align the horizontal anchor.+adjustTextX :: HTextAnchor -> TextSize -> Double+adjustTextX HTA_Left   _  = 0+adjustTextX HTA_Centre ts = - (textSizeWidth ts / 2)+adjustTextX HTA_Right  ts = - textSizeWidth ts++-- | Calculate the correct offset to align the vertical anchor.+adjustTextY :: VTextAnchor -> TextSize -> Double+adjustTextY VTA_Top      ts = textSizeAscent ts+adjustTextY VTA_Centre   ts = - textSizeYBearing ts / 2+adjustTextY VTA_BaseLine _  = 0+adjustTextY VTA_Bottom   ts = - textSizeDescent ts++-- | Return the bounding rectangle for a text string positioned+--   where it would be drawn by 'drawText'.+--   See 'textSize'.+textDrawRect :: HTextAnchor -> VTextAnchor -> Point -> String -> BackendProgram Rect+textDrawRect hta vta (Point x y) s = do+  ts <- textSize s+  -- This does not account for the pixel width of the label; e.g.+  -- with a label "bread" and a large-enough foint size (e.g. 36)+  -- I have seen the right-hand edge of the bounding box go through+  -- the vertical part of the 'd' character (see chart-tests/tests/Test8.hs+  -- and bump up the label size).+  let (w,h,dh) = (textSizeWidth ts, textSizeHeight ts, textSizeDescent ts)+      lx = adjustTextX hta ts+      ly = adjustTextY vta ts+      (x',y') = (x + lx, y + ly + dh)+      p1 = Point x' (y' - h)+      p2 = Point (x' + w) y'+  return $ Rect p1 p2++-- | Get the width and height of the string when rendered.+--   See 'textSize'.+textDimension :: String -> BackendProgram RectSize+textDimension s = do+  ts <- textSize s+  return (textSizeWidth ts, textSizeHeight ts)++-- -----------------------------------------------------------------------+-- Point Types and Drawing+-- -----------------------------------------------------------------------++-- | The different shapes a point can have.+data PointShape = PointShapeCircle           -- ^ A circle.+                | PointShapePolygon Int Bool -- ^ Number of vertices and is right-side-up?+                | PointShapePlus  -- ^ A plus sign.+                | PointShapeCross -- ^ A cross.+                | PointShapeStar  -- ^ Combination of a cross and a plus.+                | PointShapeArrowHead Double+                | PointShapeEllipse Double Double -- ^ Ratio of minor to major axis and rotation++-- | Abstract data type for the style of a plotted point.+data PointStyle = PointStyle+  { _point_color :: AlphaColour Double+  -- ^ The color to fill the point with.+  , _point_border_color :: AlphaColour Double+  -- ^ The color to stroke the outline with.+  , _point_border_width :: Double+  -- ^ The width of the outline.+  , _point_radius :: Double+  -- ^ The radius of the tightest surrounding circle of the point.+  , _point_shape :: PointShape+  -- ^ The shape.+  }++-- | Default style to use for points.+instance Default PointStyle where+  def = PointStyle+    { _point_color        = opaque black+    , _point_border_color = transparent+    , _point_border_width = 0+    , _point_radius       = 1+    , _point_shape        = PointShapeCircle+    }++-- | Draw a single point at the given location.+drawPoint :: PointStyle  -- ^ Style to use when rendering the point.+          -> Point       -- ^ Position of the point to render.+          -> BackendProgram ()+drawPoint ps@(PointStyle cl _ _ r shape) p = withPointStyle ps $ do+  p'@(Point x y) <- alignStrokePoint p+  case shape of+    PointShapeCircle -> do+      let path = arc p' r 0 (2*pi)+      fillPath path+      strokePath path+    PointShapePolygon sides isrot -> do+      let intToAngle n =+            if isrot+            then       fromIntegral n * 2*pi/fromIntegral sides+            else (0.5 + fromIntegral n)*2*pi/fromIntegral sides+          angles = map intToAngle [0 .. sides-1]+          (p1:p1':p1s) = map (\a -> Point (x + r * sin a)+                                      (y + r * cos a)) angles+      let path = G.moveTo p1 <> mconcat (map lineTo $ p1':p1s) <> lineTo p1 <> lineTo p1'+      fillPath path+      strokePath path+    PointShapeArrowHead theta ->+      withTranslation p $ withRotation (theta - pi/2) $+          drawPoint (filledPolygon r 3 True cl) (Point 0 0)+    PointShapePlus ->+      strokePath $ moveTo' (x+r) y+                <> lineTo' (x-r) y+                <> moveTo' x (y-r)+                <> lineTo' x (y+r)+    PointShapeCross -> do+      let rad = r / sqrt 2+      strokePath $ moveTo' (x+rad) (y+rad)+                <> lineTo' (x-rad) (y-rad)+                <> moveTo' (x+rad) (y-rad)+                <> lineTo' (x-rad) (y+rad)+    PointShapeStar -> do+      let rad = r / sqrt 2+      strokePath $ moveTo' (x+r) y+                <> lineTo' (x-r) y+                <> moveTo' x (y-r)+                <> lineTo' x (y+r)+                <> moveTo' (x+rad) (y+rad)+                <> lineTo' (x-rad) (y-rad)+                <> moveTo' (x+rad) (y-rad)+                <> lineTo' (x-rad) (y+rad)+    PointShapeEllipse b theta ->+      withTranslation p $ withRotation theta $ withScaleX b $ do+        let path = arc (Point 0 0) r 0 (2*pi)+        fillPath path+        strokePath path++-- -----------------------------------------------------------------------+-- Style Helpers+-- -----------------------------------------------------------------------++-- | The default sequence of colours to use when plotings different data sets+--   in a graph.+defaultColorSeq :: [AlphaColour Double]+defaultColorSeq = cycle $ map opaque [blue, red, green, yellow, cyan, magenta]++-- | Create a solid line style (not dashed).+solidLine :: Double             -- ^ Width of line.+          -> AlphaColour Double -- ^ Colour of line.+          -> LineStyle+solidLine w cl = LineStyle w cl [] LineCapButt LineJoinMiter++-- | Create a dashed line style.+dashedLine :: Double   -- ^ Width of line.+           -> [Double] -- ^ The dash pattern in device coordinates.+           -> AlphaColour Double -- ^ Colour of line.+           -> LineStyle+dashedLine w ds cl = LineStyle w cl ds LineCapButt LineJoinMiter++-- | Style for filled circle points.+filledCircles :: Double             -- ^ Radius of circle.+              -> AlphaColour Double -- ^ Fill colour.+              -> PointStyle+filledCircles radius cl =+  PointStyle cl transparent 0 radius PointShapeCircle++-- | Style for stroked circle points.+hollowCircles :: Double -- ^ Radius of circle.+              -> Double -- ^ Thickness of line.+              -> AlphaColour Double -- Colour of line.+              -> PointStyle+hollowCircles radius w cl =+  PointStyle transparent cl w radius PointShapeCircle++-- | Style for stroked polygon points.+hollowPolygon :: Double -- ^ Radius of circle.+              -> Double -- ^ Thickness of line.+              -> Int    -- ^ Number of vertices.+              -> Bool   -- ^ Is right-side-up?+              -> AlphaColour Double -- ^ Colour of line.+              -> PointStyle+hollowPolygon radius w sides isrot cl =+  PointStyle transparent cl w radius (PointShapePolygon sides isrot)++-- | Style for filled polygon points.+filledPolygon :: Double -- ^ Radius of circle.+              -> Int    -- ^ Number of vertices.+              -> Bool   -- ^ Is right-side-up?+              -> AlphaColour Double -- ^ Fill color.+              -> PointStyle+filledPolygon radius sides isrot cl =+  PointStyle cl transparent 0 radius (PointShapePolygon sides isrot)++-- | Plus sign point style.+plusses :: Double -- ^ Radius of tightest surrounding circle.+        -> Double -- ^ Thickness of line.+        -> AlphaColour Double -- ^ Color of line.+        -> PointStyle+plusses radius w cl =+  PointStyle transparent cl w radius PointShapePlus++-- | Cross point style.+exes :: Double -- ^ Radius of circle.+     -> Double -- ^ Thickness of line.+     -> AlphaColour Double -- ^ Color of line.+     -> PointStyle+exes radius w cl =+  PointStyle transparent cl w radius PointShapeCross++-- | Combination of plus and cross point style.+stars :: Double -- ^ Radius of circle.+      -> Double -- ^ Thickness of line.+      -> AlphaColour Double -- ^ Color of line.+      -> PointStyle+stars radius w cl =+  PointStyle transparent cl w radius PointShapeStar++arrows :: Double -- ^ Radius of circle.+       -> Double -- ^ Rotation (Tau)+       -> Double -- ^ Thickness of line.+       -> AlphaColour Double -- ^ Color of line.+       -> PointStyle+arrows radius angle w cl =+  PointStyle transparent cl w radius (PointShapeArrowHead angle)++-- | Fill style that fill everything this the given colour.+solidFillStyle :: AlphaColour Double -> FillStyle+solidFillStyle = FillStyleSolid++$( makeLenses ''PointStyle )
+ Graphics/Rendering/Chart/Easy.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE ScopedTypeVariables, FlexibleInstances #-}+----------------------------------------------------------------------------+-- |+-- Module      :  Graphics.Rendering.Chart.Easy+-- Copyright   :  (c) Tim Docker 2014+-- License     :  BSD-style (see chart/COPYRIGHT)+--+-- A high level API for generating a plot quickly.+--+-- Importing the Easy module brings into scope all core functions and types required+-- for working with the chart library. This includes key external dependencies such as+-- Control.Lens and Data.Colour. The module also provides several helper functions for+-- quickly generating common plots. Note that chart backends must still be explicitly+-- imported, as some backends cannot be built on all platforms.+--+-- Example usage:+--+-- > import Graphics.Rendering.Chart.Easy+-- > import Graphics.Rendering.Chart.Backend.Cairo+-- >+-- > signal :: [Double] -> [(Double,Double)]+-- > signal xs = [ (x,(sin (x*3.14159/45) + 1) / 2 * (sin (x*3.14159/5))) | x <- xs ]+-- >+-- > main = toFile def "example.png" $ do+-- >     layout_title .= "Amplitude Modulation"+-- >     plot (line "am" [signal [0,(0.5)..400]])+-- >     plot (points "am points" (signal [0,7..400]))+--+-- More examples can be found on the <https://github.com/timbod7/haskell-chart/wiki library's wiki>++module Graphics.Rendering.Chart.Easy(++  module Control.Lens,+  module Data.Default.Class,+  module Data.Colour,+  module Data.Colour.Names,++  module Graphics.Rendering.Chart,+  module Graphics.Rendering.Chart.State,++  line,+  points,+  bars,+  setColors,+  setShapes+  ) where++import Control.Lens+import Control.Monad(unless)+import Data.Default.Class+import Data.Colour hiding (over) -- overlaps with lens over function+import Data.Colour.Names+import Graphics.Rendering.Chart+import Graphics.Rendering.Chart.State++-- | Set the contents of the colour source, for+-- subsequent plots+setColors :: [AlphaColour Double] -> EC l ()+setColors cs = liftCState $ colors .= cycle cs++-- | Set the contents of the shape source, for+-- subsequent plots+setShapes :: [PointShape] -> EC l ()+setShapes ps = liftCState $ shapes .= cycle ps++-- | Constuct a line plot with the given title and+-- data, using the next available color.+line :: String -> [[(x,y)]]  -> EC l (PlotLines x y)+line title values = liftEC $ do+    color <- takeColor+    plot_lines_title .= title+    plot_lines_values .= values+    plot_lines_style . line_color .= color++-- | Construct a scatter plot with the given title and data, using the+-- next available color and point shape.+points :: String -> [(x,y)]  -> EC l (PlotPoints x y)+points title values = liftEC $ do+    color <- takeColor+    shape <- takeShape+    plot_points_values .= values+    plot_points_title .= title+    plot_points_style . point_color .= color+    plot_points_style . point_shape .= shape+    plot_points_style . point_radius .= 2++    -- Show borders for unfilled shapes+    unless (isFilled shape) $ do+        plot_points_style . point_border_color .= color+        plot_points_style . point_border_width .= 1++isFilled :: PointShape -> Bool+isFilled PointShapeCircle = True+isFilled PointShapePolygon{} = True+isFilled _ = False++-- | Construct a bar chart with the given titles and data, using the+-- next available colors+bars :: (PlotValue x, BarsPlotValue y) => [String] -> [(x,[y])] -> EC l (PlotBars x y)+bars titles vals = liftEC $ do+    styles <- sequence [fmap mkStyle takeColor | _ <- titles]+    plot_bars_titles .= titles+    plot_bars_values .= vals+    plot_bars_style .= BarsClustered+    plot_bars_spacing .= BarsFixGap 30 5+    plot_bars_item_styles .= styles+  where+    mkStyle c = (solidFillStyle c, Just (solidLine 1.0 $ opaque black))
+ Graphics/Rendering/Chart/Geometry.hs view
@@ -0,0 +1,396 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Graphics.Rendering.Chart.Geometry+-- Copyright   :  (c) Tim Docker 2006, 2014+-- License     :  BSD-style (see chart/COPYRIGHT)+--+module Graphics.Rendering.Chart.Geometry+  ( -- * Points and Vectors+    Rect(..)+  , Point(..)+  , Vector(..)++  , RectSize+  , Range++  , pointToVec++  , mkrect+  , rectPath+  , pvadd+  , pvsub+  , psub+  , vangle+  , vlen+  , vscale+  , within+  , intersectRect++  , RectEdge(..)+  , Limit(..)+  , PointMapFn++  -- * Paths+  , Path(..)+  , lineTo, moveTo+  , lineTo', moveTo'+  , arc, arc'+  , arcNeg, arcNeg'+  , close++  , foldPath+  , makeLinesExplicit++  -- * Matrices+  , transformP, scaleP, rotateP, translateP+  , Matrix(..)+  , identity+  , rotate, scale, translate+  , scalarMultiply+  , adjoint+  , invert+  ) where++import qualified Prelude+import Prelude hiding ((^))++-- The homomorphic version to avoid casts inside the code.+(^) :: Num a => a -> Integer -> a+(^) = (Prelude.^)++-- | A point in two dimensions.+data Point = Point {+    p_x :: Double,+    p_y :: Double+} deriving Show++-- | A vector in two dimensions.+data Vector = Vector {+    v_x :: Double,+    v_y :: Double+} deriving Show++-- | Convert a 'Point' to a 'Vector'.+pointToVec :: Point -> Vector+pointToVec (Point x y) = Vector x y++-- | Angle of a vector (counterclockwise from positive x-axis)+vangle :: Vector -> Double+vangle (Vector x y)+    | x > 0 = atan (y/x)+    | x < 0 = atan (y/x) + pi+    | otherwise = if y > 0 then pi/2 else -pi/2++-- | Length/magnitude of a vector+vlen :: Vector -> Double+vlen (Vector x y) = sqrt $ x^2 + y^2++-- | Scale a vector by a constant.+vscale :: Double -> Vector -> Vector+vscale c (Vector x y) = Vector (x*c) (y*c)++-- | Add a point and a vector.+pvadd :: Point -> Vector -> Point+pvadd (Point x1 y1) (Vector x2 y2) = Point (x1+x2) (y1+y2)++-- | Subtract a vector from a point.+pvsub :: Point -> Vector -> Point+pvsub (Point x1 y1) (Vector x2 y2) = Point (x1-x2) (y1-y2)++-- | Subtract two points.+psub :: Point -> Point -> Vector+psub (Point x1 y1) (Point x2 y2) = Vector (x1-x2) (y1-y2)++data Limit a = LMin | LValue a | LMax+   deriving Show++-- | A function mapping between points.+type PointMapFn x y = (Limit x, Limit y) -> Point++-- | A rectangle is defined by two points.+data Rect = Rect Point Point+   deriving Show++-- | Edge of a rectangle.+data RectEdge = E_Top | E_Bottom | E_Left | E_Right++-- | Create a rectangle based upon the coordinates of 4 points.+mkrect :: Point -> Point -> Point -> Point -> Rect+mkrect (Point x1 _) (Point _ y2) (Point x3 _) (Point _ y4) =+    Rect (Point x1 y2) (Point x3 y4)++-- | Test if a point is within a rectangle.+within :: Point -> Rect -> Bool+within (Point x y) (Rect (Point x1 y1) (Point x2 y2)) =+    x >= x1 && x <= x2 && y >= y1 && y <= y2++-- | Intersects the rectangles. If they intersect the+--   intersection rectangle is returned.+--   'LMin' is the empty rectangle / intersection and+--   'LMax' is the infinite plane.+intersectRect :: Limit Rect -> Limit Rect -> Limit Rect+intersectRect LMax r = r+intersectRect r LMax = r+intersectRect LMin _ = LMin+intersectRect _ LMin = LMin+intersectRect (LValue (Rect (Point x11 y11) (Point x12 y12)))+              (LValue (Rect (Point x21 y21) (Point x22 y22))) =+  let p1@(Point x1 y1) = Point (max x11 x21) (max y11 y21)+      p2@(Point x2 y2) = Point (min x12 x22) (min y12 y22)+  in if x2 < x1 || y2 < y1+        then LMin+        else LValue $ Rect p1 p2++type Range    = (Double,Double)+type RectSize = (Double,Double)++{-+-- | Make a path from a rectangle.+rectPointPath :: Rect -> [Point]+rectPointPath (Rect p1@(Point x1 y1) p3@(Point x2 y2)) = [p1,p2,p3,p4,p1]+  where+    p2 = (Point x1 y2)+    p4 = (Point x2 y1)+-}++-- | Make a path from a rectangle.+rectPath :: Rect -> Path+rectPath (Rect p1@(Point x1 y1) p3@(Point x2 y2)) =+  let p2 = Point x1 y2+      p4 = Point x2 y1+  in moveTo p1 <> lineTo p2 <> lineTo p3 <> lineTo p4 <> close++-- -----------------------------------------------------------------------+-- Path Types+-- -----------------------------------------------------------------------++-- | The path type used by Charts.+--+--   A path can consist of several subpaths. Each+--   is started by a 'MoveTo' operation. All subpaths+--   are open, except the last one, which may be closed+--   using the 'Close' operation. When filling a path+--   all subpaths are closed implicitly.+--+--   Closing a subpath means that a line is drawn from+--   the end point to the start point of the subpath.+--+--   If a 'Arc' (or 'ArcNeg') is drawn a implicit line+--   from the last end point of the subpath is drawn+--   to the beginning of the arc. Another implicit line+--   is drawn from the end of an arc to the beginning of+--   the next path segment.+--+--   The beginning of a subpath is either (0,0) or set+--   by a 'MoveTo' instruction. If the first subpath is started+--   with an arc the beginning of that subpath is the beginning+--   of the arc.+data Path = MoveTo Point Path+          | LineTo Point Path+          | Arc Point Double Double Double Path+          | ArcNeg Point Double Double Double Path+          | End+          | Close++-- | Paths are monoids. After a path is closed you can not append+--   anything to it anymore. The empty path is open.+--   Use 'close' to close a path.+instance Semigroup Path where+  p1 <> p2 = case p1 of+    MoveTo p path -> MoveTo p $ path <> p2+    LineTo p path -> LineTo p $ path <> p2+    Arc    p r a1 a2 path -> Arc p r a1 a2 $ path <> p2+    ArcNeg p r a1 a2 path -> ArcNeg p r a1 a2 $ path <> p2+    End   -> p2+    Close -> Close++instance Monoid Path where+  mappend = (<>)+  mempty = End++-- | Move the paths pointer to the given location.+moveTo :: Point -> Path+moveTo p = MoveTo p mempty++-- | Short-cut for 'moveTo', if you don't want to create a 'Point'.+moveTo' :: Double -> Double -> Path+moveTo' x y = moveTo $ Point x y++-- | Move the paths pointer to the given location and draw a straight+--   line while doing so.+lineTo :: Point -> Path+lineTo p = LineTo p mempty++-- | Short-cut for 'lineTo', if you don't want to create a 'Point'.+lineTo' :: Double -> Double -> Path+lineTo' x y = lineTo $ Point x y++-- | Draw the arc of a circle. A straight line connects+--   the end of the previous path with the beginning of the arc.+--   The zero angle points in direction of the positive x-axis.+--   Angles increase in clock-wise direction. If the stop angle+--   is smaller then the start angle it is increased by multiples of+--   @2 * pi@ until is is greater or equal.+arc :: Point  -- ^ Center point of the circle arc.+    -> Double -- ^ Radius of the circle.+    -> Double -- ^ Angle to start drawing at, in radians.+    -> Double -- ^ Angle to stop drawing at, in radians.+    -> Path+arc p r a1 a2 = Arc p r a1 a2 mempty++-- | Short-cut for 'arc', if you don't want to create a 'Point'.+arc' :: Double -> Double -> Double -> Double -> Double -> Path+arc' x y r a1 a2 = Arc (Point x y) r a1 a2 mempty++-- | Like 'arc', but draws from the stop angle to the start angle+--   instead of between them.+arcNeg :: Point -> Double -> Double -> Double -> Path+arcNeg p r a1 a2 = ArcNeg p r a1 a2 mempty++-- | Short-cut for 'arcNeg', if you don't want to create a 'Point'.+arcNeg' :: Double -> Double -> Double -> Double -> Double -> Path+arcNeg' x y r a1 a2 = ArcNeg (Point x y) r a1 a2 mempty++-- | A closed empty path. Closes a path when appended.+close :: Path+close = Close++-- | Fold the given path to a monoid structure.+foldPath :: (Monoid m)+         => (Point -> m) -- ^ MoveTo+         -> (Point -> m) -- ^ LineTo+         -> (Point -> Double -> Double -> Double -> m) -- ^ Arc+         -> (Point -> Double -> Double -> Double -> m) -- ^ ArcNeg+         -> m    -- ^ Close+         -> Path -- ^ Path to fold+         -> m+foldPath moveTo_ lineTo_ arc_ arcNeg_ close_ path =+  let restF = foldPath moveTo_ lineTo_ arc_ arcNeg_ close_+  in case path of+    MoveTo p rest -> moveTo_ p `mappend` restF rest+    LineTo p rest -> lineTo_ p `mappend` restF rest+    Arc    p r a1 a2 rest -> arc_    p r a1 a2 `mappend` restF rest+    ArcNeg p r a1 a2 rest -> arcNeg_ p r a1 a2 `mappend` restF rest+    End   -> mempty+    Close -> close_++-- | Enriches the path with explicit instructions to draw lines,+--   that otherwise would be implicit. See 'Path' for details+--   about what lines in paths are implicit.+makeLinesExplicit :: Path -> Path+makeLinesExplicit (Arc c r s e rest) =+  Arc c r s e $ makeLinesExplicit' rest+makeLinesExplicit (ArcNeg c r s e rest) =+  ArcNeg c r s e $ makeLinesExplicit' rest+makeLinesExplicit path = makeLinesExplicit' path++-- | Utility for 'makeLinesExplicit'.+makeLinesExplicit' :: Path -> Path+makeLinesExplicit' End   = End+makeLinesExplicit' Close = Close+makeLinesExplicit' (Arc c r s e rest) =+  let p = translateP (pointToVec c) $ rotateP s $ Point r 0+  in lineTo p <> arc c r s e <> makeLinesExplicit' rest+makeLinesExplicit' (ArcNeg c r s e rest) =+  let p = translateP (pointToVec c) $ rotateP s $ Point r 0+  in lineTo p <> arcNeg c r s e <> makeLinesExplicit' rest+makeLinesExplicit' (MoveTo p0 rest) =+  MoveTo p0 $ makeLinesExplicit' rest+makeLinesExplicit' (LineTo p0 rest) =+  LineTo p0 $ makeLinesExplicit' rest++-- -----------------------------------------------------------------------+-- Matrix Type+-- -----------------------------------------------------------------------++-- | Transform a point using the given matrix.+transformP :: Matrix -> Point -> Point+transformP t (Point x y) = Point+  (xx t * x + xy t * y + x0 t)+  (yx t * x + yy t * y + y0 t)++-- | Rotate a point around the origin.+--   The angle is given in radians.+rotateP :: Double -> Point -> Point+rotateP a = transformP (rotate a 1)++-- | Scale a point.+scaleP :: Vector -> Point -> Point+scaleP s = transformP (scale s 1)++-- | Translate a point.+translateP :: Vector -> Point -> Point+translateP = flip pvadd++-- | Copied from Graphics.Rendering.Cairo.Matrix+data Matrix = Matrix { xx :: !Double, yx :: !Double,+                       xy :: !Double, yy :: !Double,+                       x0 :: !Double, y0 :: !Double }+                     deriving Show++-- | Copied from Graphics.Rendering.Cairo.Matrix+instance Num Matrix where+  -- use underscore to avoid ghc complaints about shadowing the Matrix+  -- field names+  (*) (Matrix xx_ yx_ xy_ yy_ x0_ y0_)+      (Matrix xx'_ yx'_ xy'_ yy'_ x0'_ y0'_) =+    Matrix (xx_ * xx'_ + yx_ * xy'_)+           (xx_ * yx'_ + yx_ * yy'_)+           (xy_ * xx'_ + yy_ * xy'_)+           (xy_ * yx'_ + yy_ * yy'_)+           (x0_ * xx'_ + y0_ * xy'_ + x0'_)+           (x0_ * yx'_ + y0_ * yy'_ + y0'_)++  (+) = pointwise2 (+)+  (-) = pointwise2 (-)++  negate = pointwise negate+  abs    = pointwise abs+  signum = pointwise signum++  fromInteger n = Matrix (fromInteger n) 0 0 (fromInteger n) 0 0++-- | Copied from Graphics.Rendering.Cairo.Matrix+{-# INLINE pointwise #-}+pointwise :: (Double -> Double) -> Matrix -> Matrix+pointwise f (Matrix xx_ yx_ xy_ yy_ x0_ y0_) =+  Matrix (f xx_) (f yx_) (f xy_) (f yy_) (f x0_) (f y0_)++-- | Copied from Graphics.Rendering.Cairo.Matrix+{-# INLINE pointwise2 #-}+pointwise2 :: (Double -> Double -> Double) -> Matrix -> Matrix -> Matrix+pointwise2 f (Matrix xx_ yx_ xy_ yy_ x0_ y0_) (Matrix xx'_ yx'_ xy'_ yy'_ x0'_ y0'_) =+  Matrix (f xx_ xx'_) (f yx_ yx'_) (f xy_ xy'_) (f yy_ yy'_) (f x0_ x0'_) (f y0_ y0'_)++-- | Copied from Graphics.Rendering.Cairo.Matrix+identity :: Matrix+identity = Matrix 1 0 0 1 0 0++-- | Copied and adopted from Graphics.Rendering.Cairo.Matrix+translate :: Vector -> Matrix -> Matrix+translate tv m = m * Matrix 1 0 0 1 (v_x tv) (v_y tv)++-- | Copied and adopted from Graphics.Rendering.Cairo.Matrix+scale :: Vector -> Matrix -> Matrix+scale sv m = m * Matrix (v_x sv) 0 0 (v_y sv) 0 0++-- | Copied from Graphics.Rendering.Cairo.Matrix+--   Rotations angle is given in radians.+rotate :: Double -> Matrix -> Matrix+rotate r m = m * Matrix c s (-s) c 0 0+  where s = sin r+        c = cos r++-- | Copied from Graphics.Rendering.Cairo.Matrix+scalarMultiply :: Double -> Matrix -> Matrix+scalarMultiply scalar = pointwise (* scalar)++-- | Copied from Graphics.Rendering.Cairo.Matrix+adjoint :: Matrix -> Matrix+adjoint (Matrix a b c d tx ty) =+  Matrix d (-b) (-c) a (c*ty - d*tx) (b*tx - a*ty)++-- | Copied from Graphics.Rendering.Cairo.Matrix+invert :: Matrix -> Matrix+invert m@(Matrix xx_ yx_ xy_ yy_ _ _) = scalarMultiply (recip det) $ adjoint m+  where det = xx_*yy_ - yx_*xy_
Graphics/Rendering/Chart/Grid.hs view
@@ -1,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,17 +26,11 @@     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.Types-import qualified Graphics.Rendering.Cairo as C--import Data.Colour-import Data.Colour.Names+import Graphics.Rendering.Chart.Geometry hiding (x0, y0)+import Graphics.Rendering.Chart.Drawing  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) -> CRender (DArray, DArray, DArray, DArray)+getSizes :: Grid (Renderable a) -> BackendProgram (DArray, DArray, DArray, DArray) getSizes t = do-    szs <- mapGridM minsize t :: CRender (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,54 +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+  toRenderable = gridToRenderable . fmap toRenderable  gridToRenderable :: Grid (Renderable a) -> Renderable a-gridToRenderable t = Renderable minsizef renderf+gridToRenderable gt = Renderable minsizef renderf   where-    minsizef :: CRender 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) <- alignc p0-            p1'@(Point x1 y1) <- alignc p1-            preserveCState $ do-                c $ C.translate x0 y0-                pf <- render r (x1-x0,y1-y0)-                return (newpf pf x0 y0)+        (Value (r,spn,_)) -> do+            let (Rect p0 p1) = mkRect borders loc spn+            (Point x0 y0) <- alignFillPoint p0+            (Point x1 y1) <- alignFillPoint p1+            withTranslation (Point x0 y0) $ do+              pf <- render r (x1-x0,y1-y0)+              return (newpf pf x0 y0)         (Above t1 t2 _) -> do              pf1 <- rf1 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@@ -294,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]@@ -305,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,516 +1,855 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Graphics.Rendering.Chart.Layout--- Copyright   :  (c) Tim Docker 2006--- License     :  BSD-style (see chart/COPYRIGHT)------ This module glues together axes and plots to actually create a renderable--- for a chart.------ Note that template haskell is used to derive accessor functions--- (see 'Data.Accessor') for each field of the following data types:------     * 'Layout1'--- ---     * 'StackedLayouts'------     * 'LayoutAxis'------ These accessors are not shown in this API documentation.  They have--- the same name as the field, but with the trailing underscore--- dropped. Hence for data field f_::F in type D, they have type------ @---   f :: Data.Accessor.Accessor D F--- @-----{-# OPTIONS_GHC -XTemplateHaskell -XExistentialQuantification #-}--module Graphics.Rendering.Chart.Layout(-    Layout1(..),-    LayoutAxis(..),-    Layout1Pick(..),-    StackedLayouts(..),-    StackedLayout(..),-    MAxisFn,--    defaultLayout1,-    layout1ToRenderable,-    linkAxes,-    independentAxes,--    updateAllAxesStyles,-    setLayout1Foreground,--    defaultLayoutAxis,-    laxis_title_style,-    laxis_title,-    laxis_style,-    laxis_visible,-    laxis_generate,-    laxis_override,-    laxis_reverse,--    layout1_background,-    layout1_plot_background,-    layout1_title,-    layout1_title_style,-    layout1_left_axis,-    layout1_right_axis,-    layout1_top_axis,-    layout1_bottom_axis,-    layout1_yaxes_control,-    layout1_margin,-    layout1_plots,-    layout1_legend,-    layout1_grid_last,--    defaultStackedLayouts,-    slayouts_layouts,-    slayouts_compress_xlabels,-    slayouts_compress_legend,--    renderStackedLayouts,-  ) where--import qualified Graphics.Rendering.Cairo as C--import Graphics.Rendering.Chart.Axis-import Graphics.Rendering.Chart.Types-import Graphics.Rendering.Chart.Plot-import Graphics.Rendering.Chart.Legend-import Graphics.Rendering.Chart.Renderable-import Graphics.Rendering.Chart.Grid-import Control.Monad-import Control.Monad.Reader (local)-import Data.Accessor.Template-import Data.Accessor-import Data.Colour-import Data.Colour.Names (white)---- | A @MAxisFn@ is a function that generates an (optional) axis---   given the points plotted against that axis.-type MAxisFn t = [t] -> Maybe (AxisData t)--data LayoutAxis x = LayoutAxis {-   laxis_title_style_ :: CairoFontStyle,-   laxis_title_       :: String,-   laxis_style_       :: AxisStyle,--   -- | Function that determines whether an axis should be visible,-   --   based upon the points plotted on this axis. The default value-   --   is 'not.null'.-   laxis_visible_     :: [x] -> Bool,--   -- | Function that generates the axis data, based upon the-   --   points plotted. The default value is 'autoAxis'.-   laxis_generate_    :: AxisFn x,--   -- | Function that can be used to override the generated axis data.-   --   The default value is 'id'.-   laxis_override_    :: AxisData x -> AxisData x,--   -- | True if left to right (bottom to top) is to show descending values.-   laxis_reverse_     :: Bool--}---- | A Layout1 value is a single plot area, with optional: axes on---   each of the 4 sides; title at the top; legend at the bottom. It's---   parameterised by the types of values to be plotted on the horizonal---   and vertical axes.-data Layout1 x y = Layout1 {--    layout1_background_      :: CairoFillStyle,-    layout1_plot_background_ :: Maybe CairoFillStyle,--    layout1_title_           :: String,-    layout1_title_style_     :: CairoFontStyle,--    layout1_bottom_axis_     :: LayoutAxis x,-    layout1_top_axis_        :: LayoutAxis x,-    layout1_left_axis_       :: LayoutAxis y,-    layout1_right_axis_      :: LayoutAxis y,--    -- | Function to map points from the left/right plot-    --   to the left/right axes. The default value is 'id'.-    layout1_yaxes_control_   :: ([y],[y]) -> ([y],[y]),--    layout1_margin_          :: Double,-    layout1_plots_           :: [Either (Plot x y) (Plot x y)],-    layout1_legend_          :: Maybe LegendStyle,--    -- | True if the grid is to be rendered on top of the Plots.-    layout1_grid_last_       :: Bool-}--data Layout1Pick x y = L1P_Legend String-                     | L1P_Title String-                     | L1P_BottomAxisTitle String-                     | L1P_TopAxisTitle String-                     | L1P_LeftAxisTitle String-                     | L1P_RightAxisTitle String-                     | L1P_PlotArea x y y-                     | L1P_BottomAxis x-                     | L1P_TopAxis x-                     | L1P_LeftAxis y-                     | L1P_RightAxis y-    deriving (Show)--instance (Ord x, Ord y) => ToRenderable (Layout1 x y) where-    toRenderable = setPickFn nullPickFn.layout1ToRenderable--type LegendItem = (String,Rect -> CRender ())---- | A layout with it's y type hidded, so that it can be stacked--- with other layouts (with differing y types)-data StackedLayout x = forall y . Ord y => StackedLayout (Layout1 x y)---- | A holder for a set of vertically stacked layouts-data StackedLayouts x = StackedLayouts {-      slayouts_layouts_ :: [StackedLayout x],-      slayouts_compress_xlabels_ :: Bool,-      slayouts_compress_legend_ :: Bool-}--defaultStackedLayouts :: StackedLayouts x-defaultStackedLayouts = StackedLayouts [] True True---- | Render several layouts with the same x-axis type and range,---   vertically stacked so that their origins and x-values are aligned.------ The legends from all the charts may be optionally combined, and shown--- once on the bottom chart.   The x labels may be optionally removed so that--- they are only shown once.-renderStackedLayouts :: (Ord x) => StackedLayouts x -> Renderable ()-renderStackedLayouts (StackedLayouts{slayouts_layouts_=[]}) = emptyRenderable-renderStackedLayouts slp@(StackedLayouts{slayouts_layouts_=sls@(sl1:_)}) = gridToRenderable g-  where-    g = fullOverlayUnder (fillBackground bg emptyRenderable)-      $ foldr (above.mkGrid) nullt (zip sls [0,1..])-      -    mkGrid ((StackedLayout l),i)-        = (noPickFn $ layout1TitleToRenderable l)-          `wideAbove`-          (addMarginsToGrid (lm,lm,lm,lm) $ mkPlotArea baxis taxis)-          `aboveWide`-          (if showLegend then noPickFn $ renderLegend l legenditems else emptyRenderable)--      where-        legenditems = case (slayouts_compress_legend_ slp,isBottomPlot) of-            (False,_) -> getLegendItems l-            (True,True) -> alllegendItems-            (True,False) -> ([],[])--        mkPlotArea bx tx = fmap (mapPickFn (const ()))-                         $ layout1PlotAreaToGrid l{layout1_bottom_axis_=bx,layout1_top_axis_=tx}--        showLegend = not (null (fst legenditems)) || not (null (snd legenditems))--        isTopPlot = i == 0-        isBottomPlot = i == length sls -1--        lm = layout1_margin_ l--        baxis = mkAxis (layout1_bottom_axis_ l) (isBottomPlot || not (slayouts_compress_xlabels_ slp))-        taxis = mkAxis (layout1_top_axis_ l) (isTopPlot || not (slayouts_compress_xlabels_ slp))--        mkAxis a showLabels = a{-            laxis_generate_=const (laxis_generate_ a all_xvals),-            laxis_override_= if showLabels then id else \ad -> ad{axis_labels_=[]}-        }--    bg = (\(StackedLayout l) -> layout1_background_ l) sl1-    -    all_xvals = concatMap (\(StackedLayout l) -> getLayout1XVals l) sls--    alllegendItems = (concatMap (fst.legendItems) sls, concatMap (snd.legendItems) sls)-    legendItems (StackedLayout l) = (getLegendItems l)-    -    noPickFn :: Renderable a -> Renderable ()-    noPickFn = mapPickFn (const ())--addMarginsToGrid :: (Double,Double,Double,Double) -> Grid (Renderable a)-                    -> Grid (Renderable a)-addMarginsToGrid (t,b,l,r) g = aboveN [-     besideN [er, ts, er],-     besideN [ls, g,  rs],-     besideN [er, bs, er]-  ]-  where-    er = empty-    ts = tval $ spacer (0,t)-    ls = tval $ spacer (l,0)-    bs = tval $ spacer (0,b)-    rs = tval $ spacer (r,0)--layout1ToRenderable :: (Ord x, Ord y) =>-                       Layout1 x y -> Renderable (Layout1Pick x y)-layout1ToRenderable l =-   fillBackground (layout1_background_ l) $ gridToRenderable (layout1ToGrid l)--layout1ToGrid :: (Ord x, Ord y) =>-                 Layout1 x y -> Grid (Renderable (Layout1Pick x y))-layout1ToGrid l = aboveN-       [  tval $ layout1TitleToRenderable l-       ,  weights (1,1) $ tval $ gridToRenderable $-              addMarginsToGrid (lm,lm,lm,lm) (layout1PlotAreaToGrid l)-       ,  tval $ layout1LegendsToRenderable l-       ]-  where-    lm = layout1_margin_ l--layout1TitleToRenderable :: (Ord x, Ord y) => Layout1 x y-                                           -> Renderable (Layout1Pick x y)-layout1TitleToRenderable l | null (layout1_title_ l) = emptyRenderable-layout1TitleToRenderable l = addMargins (lm/2,0,0,0)-                                        (mapPickFn L1P_Title title)-  where-    title = label (layout1_title_style_ l) HTA_Centre VTA_Centre-                  (layout1_title_ l)-    lm    = layout1_margin_ l--getLayout1XVals :: Layout1 x y -> [x]-getLayout1XVals l = concatMap (fst.plot_all_points_.deEither) (layout1_plots_ l)-  where-    deEither (Left x)  = x-    deEither (Right x) = x---getLegendItems :: Layout1 x y -> ([LegendItem],[LegendItem])-getLegendItems l = (-    concat [ plot_legend_ p | (Left p ) <- (layout1_plots_ l) ],-    concat [ plot_legend_ p | (Right p) <- (layout1_plots_ l) ]-    )--renderLegend :: Layout1 x y -> ([LegendItem],[LegendItem]) -> Renderable (Layout1Pick x y)-renderLegend l (lefts,rights) = gridToRenderable g-  where-    g      = besideN [ tval $ mkLegend lefts-                     , weights (1,1) $ tval $ emptyRenderable-                     , tval $ mkLegend rights ]--    lm     = layout1_margin_ l--    mkLegend vals = case (layout1_legend_ l) of-        Nothing -> emptyRenderable-        Just ls ->  case filter ((/="").fst) vals of-            []  -> emptyRenderable ;-            lvs -> addMargins (0,lm,lm,lm) $-                       mapPickFn L1P_Legend $ legendToRenderable (Legend ls lvs)--layout1LegendsToRenderable :: (Ord x, Ord y) =>-                              Layout1 x y -> Renderable (Layout1Pick x y)-layout1LegendsToRenderable l = renderLegend l (getLegendItems l)--layout1PlotAreaToGrid :: (Ord x, Ord y) =>-                          Layout1 x y -> Grid (Renderable (Layout1Pick x y))-layout1PlotAreaToGrid l = layer2 `overlay` layer1-  where-    layer1 = aboveN-         [ besideN [er,     er,  er,    er   ]-         , besideN [er,     er,  er,    er   ]-         , besideN [er,     er,  er,    weights (1,1) plots ]-         ]--    layer2 = aboveN-         [ besideN [er,     er,  er,    ttitle, er,    er,  er       ]-         , besideN [er,     er,  tl,    taxis,  tr,    er,  er       ]-         , besideN [ltitle, lam, laxis, er,     raxis, ram, rtitle   ]-         , besideN [er,     er,  bl,    baxis,  br,    er,  er       ]-         , besideN [er,     er,  er,    btitle, er,    er,  er       ]-         ]--    (ttitle,_) = atitle HTA_Centre VTA_Bottom   0 layout1_top_axis_    L1P_TopAxisTitle-    (btitle,_) = atitle HTA_Centre VTA_Top      0 layout1_bottom_axis_ L1P_BottomAxisTitle-    (ltitle,lam) = atitle HTA_Right  VTA_Centre 270 layout1_left_axis_   L1P_LeftAxisTitle-    (rtitle,ram) = atitle HTA_Left   VTA_Centre 270 layout1_right_axis_  L1P_RightAxisTitle--    er = tval $ emptyRenderable--    atitle ha va rot af pf = if ttext == "" then (er,er) else (label,gap)-      where-        label = tval $ mapPickFn pf $ rlabel tstyle ha va rot ttext-        gap = tval $ spacer (layout1_margin_ l,0)-        tstyle = laxis_title_style_ (af l)-        ttext  = laxis_title_       (af l)--    plots = tval $ mfill (layout1_plot_background_ l) $ plotsToRenderable l-      where-        mfill Nothing   = id-        mfill (Just fs) = fillBackground fs--    (ba,la,ta,ra) = getAxes l-    baxis = tval $ maybe emptyRenderable-                         (mapPickFn L1P_BottomAxis . axisToRenderable) ba-    taxis = tval $ maybe emptyRenderable-                         (mapPickFn L1P_TopAxis .    axisToRenderable) ta-    laxis = tval $ maybe emptyRenderable-                         (mapPickFn L1P_LeftAxis .   axisToRenderable) la-    raxis = tval $ maybe emptyRenderable-                         (mapPickFn L1P_RightAxis .  axisToRenderable) ra--    tl = tval $ axesSpacer fst ta fst la-    bl = tval $ axesSpacer fst ba snd la-    tr = tval $ axesSpacer snd ta fst ra-    br = tval $ axesSpacer snd ba snd ra--plotsToRenderable :: Layout1 x y -> Renderable (Layout1Pick x y)-plotsToRenderable l = Renderable {-        minsize = return (0,0),-        render  = renderPlots l-    }--renderPlots :: Layout1 x y -> RectSize -> CRender (PickFn (Layout1Pick x y))-renderPlots l sz@(w,h) = do-    when (not (layout1_grid_last_ l)) renderGrids-    preserveCState $ do-        -- render the plots-        setClipRegion (Point 0 0) (Point w h)-        mapM_ rPlot (layout1_plots_ l)-    when (layout1_grid_last_ l) renderGrids-    return pickfn--  where-    (bAxis,lAxis,tAxis,rAxis) = getAxes l--    rPlot (Left  p) = rPlot1 bAxis lAxis p-    rPlot (Right p) = rPlot1 bAxis rAxis p--    xr = (0, w)-    yr = (h, 0)-    reverse rev (a,b) = if rev then (b,a) else (a,b)--    rPlot1 (Just (AxisT _ xs xrev xaxis)) (Just (AxisT _ ys yrev yaxis)) p =-      let -          xr1 = reverse xrev xr-          yr1 = reverse yrev yr-          yrange = if yrev then (0, h) else (h, 0)-          pmfn (x,y) = Point (mapv xr1 (axis_viewport_ xaxis xr1) x)-                             (mapv yr1 (axis_viewport_ yaxis yr1) y)-          mapv (min,max) _ LMin       = min-          mapv (min,max) _ LMax       = max-          mapv _         f (LValue v) = f v-	  in plot_render_ p pmfn-    rPlot1 _ _ _ = return ()--    pickfn (Point x y) = do  -- Maybe monad-        xat <- mxat-        (yat1,yat2) <- myats-        return (L1P_PlotArea (mapx xat x) (mapy yat1 y)  (mapy yat2 y))-      where-        mxat = case (bAxis,tAxis) of-            (Just at,_)       -> Just at-            (_,Just at)       -> Just at-            (Nothing,Nothing) -> Nothing-        myats = case (lAxis,rAxis) of-            (Just at,Nothing)   -> Just (at,at)-            (Nothing,Just at)   -> Just (at,at)-            (Just at1,Just at2) -> Just (at1,at2)-            (Nothing,Nothing)   -> Nothing-        mapx (AxisT _ _ rev ad) x = axis_tropweiv_ ad (reverse rev xr) x-        mapy (AxisT _ _ rev ad) y = axis_tropweiv_ ad (reverse rev yr) y--    renderGrids = do-      maybeM () (renderAxisGrid sz) tAxis-      maybeM () (renderAxisGrid sz) bAxis-      maybeM () (renderAxisGrid sz) lAxis-      maybeM () (renderAxisGrid sz) rAxis--axesSpacer f1 a1 f2 a2 = embedRenderable $ do-    oh1 <- maybeM (0,0) axisOverhang a1-    oh2 <- maybeM (0,0) axisOverhang a2-    return (spacer (f1 oh1, f2 oh2))--getAxes :: Layout1 x y ->-           (Maybe (AxisT x), Maybe (AxisT y), Maybe (AxisT x), Maybe (AxisT y))-getAxes l = (bAxis,lAxis,tAxis,rAxis)-  where-    (xvals0,xvals1,yvals0,yvals1) = allPlottedValues (layout1_plots_ l)-    xvals                         = xvals0 ++ xvals1-    (yvals0',yvals1')             = layout1_yaxes_control_ l (yvals0,yvals1)--    bAxis = mkAxis E_Bottom (layout1_bottom_axis_ l) xvals-    tAxis = mkAxis E_Top    (layout1_top_axis_ l)    xvals-    lAxis = mkAxis E_Left   (layout1_left_axis_ l)  yvals0'-    rAxis = mkAxis E_Right  (layout1_right_axis_ l) yvals1'--    mkAxis t laxis vals = case laxis_visible_ laxis vals of-        False -> Nothing-        True  -> Just (AxisT t style rev adata)-      where-        style = laxis_style_ laxis-        rev   = laxis_reverse_ laxis-        adata = (laxis_override_ laxis) (laxis_generate_ laxis vals)--allPlottedValues :: [(Either (Plot x y) (Plot x' y'))]-                    -> ( [x], [x'], [y], [y'] )-allPlottedValues plots = (xvals0,xvals1,yvals0,yvals1)-  where-    xvals0 = [ x | (Left p)  <- plots, x <- fst $ plot_all_points_ p]-    yvals0 = [ y | (Left p)  <- plots, y <- snd $ plot_all_points_ p]-    xvals1 = [ x | (Right p) <- plots, x <- fst $ plot_all_points_ p]-    yvals1 = [ y | (Right p) <- plots, y <- snd $ plot_all_points_ p]--defaultLayout1 :: (PlotValue x,PlotValue y) => Layout1 x y-defaultLayout1 = Layout1 {-    layout1_background_      = solidFillStyle $ opaque white,-    layout1_plot_background_ = Nothing,--    layout1_title_           = "",-    layout1_title_style_     = defaultFontStyle{font_size_   =15-                                               ,font_weight_ =C.FontWeightBold},--    layout1_top_axis_        = defaultLayoutAxis {laxis_visible_ = const False},-    layout1_bottom_axis_     = defaultLayoutAxis,-    layout1_left_axis_       = defaultLayoutAxis,-    layout1_right_axis_      = defaultLayoutAxis,--    layout1_yaxes_control_   = id,--    layout1_margin_          = 10,-    layout1_plots_           = [],-    layout1_legend_          = Just defaultLegendStyle,-    layout1_grid_last_       = False-}--defaultLayoutAxis :: PlotValue t => LayoutAxis t-defaultLayoutAxis = LayoutAxis {-   laxis_title_style_ = defaultFontStyle{font_size_=10},-   laxis_title_       = "",-   laxis_style_       = defaultAxisStyle,-   laxis_visible_     = not.null,-   laxis_generate_    = autoAxis,-   laxis_override_    = id,-   laxis_reverse_     = False-}--------------------------------------------------------------------------- Template haskell to derive an instance of Data.Accessor.Accessor--- for each field.-$( deriveAccessors ''Layout1 )-$( deriveAccessors ''LayoutAxis )-$( deriveAccessors ''StackedLayouts )---- | Helper to update all axis styles on a Layout1 simultaneously.-updateAllAxesStyles :: (AxisStyle -> AxisStyle) -> Layout1 x y -> Layout1 x y-updateAllAxesStyles uf = (layout1_top_axis    .> laxis_style ^: uf) .-                         (layout1_bottom_axis .> laxis_style ^: uf) .-                         (layout1_left_axis   .> laxis_style ^: uf) .-                         (layout1_right_axis  .> laxis_style ^: uf)---- | Helper to set the forground color uniformly on a Layout1.-setLayout1Foreground :: AlphaColour Double -> Layout1 x y -> Layout1 x y-setLayout1Foreground fg =-    updateAllAxesStyles  ( (axis_line_style  .> line_color ^= fg)-                         . (axis_label_style .> font_color ^= fg))-    . (layout1_title_style .> font_color ^= fg)-    . (layout1_legend ^: fmap (legend_label_style .> font_color ^= fg))---linkAxes :: ([a], [a]) -> ([a], [a])-linkAxes        (ys1,ys2) = (ys1++ys2,ys1++ys2)--independentAxes :: (a, b) -> (a, b)-independentAxes (ys1,ys2) = (ys1,ys2)+-- Copyright   :  (c) Tim Docker 2006, 2014+-- License     :  BSD-style (see chart/COPYRIGHT)+--+-- This module glues together axes and plots to actually create a renderable+-- for a chart.+--+-- Note that Template haskell is used to derive accessor functions+-- (see 'Control.Lens') for each field of the following data types:+--+--     * 'Layout'+--+--     * 'LayoutLR'+--+--     * 'StackedLayouts'+--+--     * 'LayoutAxis'+--+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ExistentialQuantification #-}++module Graphics.Rendering.Chart.Layout+  ( -- * Types+    Layout(..)+  , LayoutLR(..)+  , LayoutAxis(..)+  , LayoutPick(..)+  , StackedLayouts(..)+  , StackedLayout(..)+  -- , LegendItem  haddock complains about this being missing, but from what?+  , MAxisFn++    -- * Rendering+  , layoutToRenderable+  , layoutToGrid+  , layoutLRToRenderable+  , layoutLRToGrid+  , renderStackedLayouts++    -- * LayoutAxis lenses+  , laxis_title_style+  , laxis_title+  , laxis_style+  , laxis_generate+  , laxis_override+  , laxis_reverse++    -- * Layout lenses+  , layout_background+  , layout_plot_background+  , layout_title+  , layout_title_style+  , layout_x_axis+  , layout_top_axis_visibility+  , layout_bottom_axis_visibility+  , layout_y_axis+  , layout_left_axis_visibility+  , layout_right_axis_visibility+  , layout_margin+  , layout_plots+  , layout_legend+  , layout_grid_last++  , layout_axes_styles+  , layout_axes_title_styles+  , layout_all_font_styles+  , layout_foreground++    -- * LayoutLR lenses+  , layoutlr_background+  , layoutlr_plot_background+  , layoutlr_title+  , layoutlr_title_style+  , layoutlr_x_axis+  , layoutlr_top_axis_visibility+  , layoutlr_bottom_axis_visibility+  , layoutlr_left_axis+  , layoutlr_right_axis+  , layoutlr_left_axis_visibility+  , layoutlr_right_axis_visibility+  , layoutlr_plots+  , layoutlr_legend+  , layoutlr_margin+  , layoutlr_grid_last++  , layoutlr_axes_styles+  , layoutlr_axes_title_styles+  , layoutlr_all_font_styles+  , layoutlr_foreground++    -- * StackedLayouts lenses+  , slayouts_layouts+  , slayouts_compress_legend+  ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif++import Graphics.Rendering.Chart.Axis+import Graphics.Rendering.Chart.Geometry+import Graphics.Rendering.Chart.Drawing+import Graphics.Rendering.Chart.Utils+import Graphics.Rendering.Chart.Plot+import Graphics.Rendering.Chart.Legend+import Graphics.Rendering.Chart.Renderable+import Graphics.Rendering.Chart.Grid+import Control.Monad+import Control.Lens hiding (at)+import Data.Colour+import Data.Colour.Names (white)+import Data.Default.Class++-- | A @MAxisFn@ is a function that generates an (optional) axis+--   given the points plotted against that axis.+type MAxisFn t = [t] -> Maybe (AxisData t)++-- | Type of axis that is used in 'Layout' and 'LayoutLR'.+--+--   To generate the actual axis type ('AxisData' and 'AxisT')+--   the '_laxis_generate' function is called and custom settings+--   are applied with '_laxis_override'. Note that the 'AxisVisibility'+--   values in 'Layout' and 'LayoutLR' override visibility related+--   settings of the axis.+data LayoutAxis x = LayoutAxis+  { _laxis_title_style :: FontStyle+    -- ^ Font style to use for the axis title.+  , _laxis_title       :: String+    -- ^ Title displayed for the axis.+  , _laxis_style       :: AxisStyle+    -- ^ Axis style applied.++  , _laxis_generate    :: AxisFn x+    -- ^ Function that generates the axis data, based upon the+    --   points plotted. The default value is 'autoAxis'.++  , _laxis_override    :: AxisData x -> AxisData x+    -- ^ Function that can be used to override the generated axis data.+    --   The default value is 'id'.++  , _laxis_reverse     :: Bool+    -- ^ True if left to right (bottom to top) is to show descending values.++  }++-- | Information on what is at a specifc location of a 'Layout' or 'LayoutLR'.+--   This is delivered by the 'PickFn' of a 'Renderable'.+data LayoutPick x y1 y2 = LayoutPick_Legend String           -- ^ A legend entry.+                        | LayoutPick_Title String            -- ^ The title.+                        | LayoutPick_XTopAxisTitle String    -- ^ The title of the top x axis.+                        | LayoutPick_XBottomAxisTitle String -- ^ The title of the bottom x axis.+                        | LayoutPick_YLeftAxisTitle String   -- ^ The title of the left y axis.+                        | LayoutPick_YRightAxisTitle String  -- ^ The title of the right y axis.+                        | LayoutPick_PlotArea x y1 y2        -- ^ The plot area at the given plot coordinates.+                        | LayoutPick_XTopAxis x              -- ^ The top x axis at the given plot coordinate.+                        | LayoutPick_XBottomAxis x           -- ^ The bottom x axis at the given plot coordinate.+                        | LayoutPick_YLeftAxis y1            -- ^ The left y axis at the given plot coordinate.+                        | LayoutPick_YRightAxis y2           -- ^ The right y axis at the given plot coordinate.+                          deriving (Show)++type LegendItem = (String,Rect -> BackendProgram ())++-- | A Layout value is a single plot area, with single x and y+--   axis. The title is at the top and the legend at the bottom. It's+--   parametrized by the types of values to be plotted on the x+--   and y axes.+data Layout x y = Layout+  { _layout_background      :: FillStyle+    -- ^ How to fill the background of everything.+  , _layout_plot_background :: Maybe FillStyle+    -- ^ How to fill the background of the plot,+    --   if different from the overall background.++  , _layout_title           :: String+    -- ^ Title to display above the chart.+  , _layout_title_style     :: FontStyle+    -- ^ Font style to use for the title.++  , _layout_x_axis                 :: LayoutAxis x+    -- ^ Rules to generate the x axis.+  , _layout_top_axis_visibility    :: AxisVisibility+    -- ^ Visibility options for the top axis.+  , _layout_bottom_axis_visibility :: AxisVisibility+    -- ^ Visibility options for the bottom axis.++  , _layout_y_axis                :: LayoutAxis y+    -- ^ Rules to generate the y axis.+  , _layout_left_axis_visibility  :: AxisVisibility+    -- ^ Visibility options for the left axis.+  , _layout_right_axis_visibility :: AxisVisibility+    -- ^ Visibility options for the right axis.++  , _layout_plots           :: [Plot x y]+    -- ^ The data sets to plot in the chart.+    --   They are plotted over each other.++  , _layout_legend          :: Maybe LegendStyle+    -- ^ How to style the legend.+  , _layout_margin          :: Double+    -- ^ The margin distance to use.+  , _layout_grid_last       :: Bool+    -- ^ If the grid shall be rendered+    --   beneath (@False@) or over (@True@) all plots.+  }++instance (Ord x, Ord y) => ToRenderable (Layout x y) where+  toRenderable = setPickFn nullPickFn . layoutToRenderable++-- | Render the given 'Layout'.+layoutToRenderable :: forall x y . (Ord x, Ord y) => Layout x y -> Renderable (LayoutPick x y y)+layoutToRenderable l = fillBackground (_layout_background l) $ gridToRenderable (layoutToGrid l)++layoutToGrid :: forall x y . (Ord x, Ord y) => Layout x y -> Grid (Renderable (LayoutPick x y y))+layoutToGrid l = grid+  where+    lp :: Grid a -> a -> Grid a+    lp = case maybe LegendBelow _legend_position $ _layout_legend l of+              LegendAbove -> flip wideAbove+              LegendBelow -> aboveWide+              LegendRight -> besideTall+              LegendLeft  -> flip tallBeside++    title = titleToRenderable lm (_layout_title_style l) (_layout_title l)+    plotArea = addMarginsToGrid (lm,lm,lm,lm) (layoutPlotAreaToGrid l)+    legend = renderLegend l (getLegendItems l)+    grid = title `wideAbove` (plotArea `lp` legend)+    lm = _layout_margin l++getLayoutXVals :: Layout x y -> [x]+getLayoutXVals l = concatMap (fst . _plot_all_points) (_layout_plots l)++-- | Extract all 'LegendItem's from the plots of a 'Layout'.+getLegendItems :: Layout x y -> [LegendItem]+getLegendItems l = concat [ _plot_legend p | p <- _layout_plots l ]++-- | Render the given 'LegendItem's for a 'Layout'.+renderLegend :: Layout x y -> [LegendItem] -> Renderable (LayoutPick x y y)+renderLegend l legItems = gridToRenderable g+  where+    g      = besideN [ tval $ mkLegend (_layout_legend l) (_layout_margin l) legItems+                     , weights (1,1) $ tval emptyRenderable ]++-- | Render the plot area of a 'Layout'. This consists of the+--   actual plot area with all plots, the axis and their titles.+layoutPlotAreaToGrid :: forall x y. (Ord x, Ord y) =>+                        Layout x y -> Grid (Renderable (LayoutPick x y y))+layoutPlotAreaToGrid l = buildGrid LayoutGridElements{+  lge_plots = mfill (_layout_plot_background l) $ plotsToRenderable l,+  lge_taxis = (tAxis,_laxis_title $ _layout_x_axis l, _laxis_title_style $ _layout_x_axis l),+  lge_baxis = (bAxis,_laxis_title $ _layout_x_axis l, _laxis_title_style $ _layout_x_axis l),+  lge_laxis = (lAxis,_laxis_title $ _layout_y_axis l, _laxis_title_style $ _layout_y_axis l),+  lge_raxis = (rAxis,"", def),+  lge_margin = _layout_margin l+  }+  where+    xvals = [ x | p <- _layout_plots l, x <- fst $ _plot_all_points p]+    yvals = [ y | p <- _layout_plots l, y <- snd $ _plot_all_points p]++    bAxis = mkAxis E_Bottom (overrideAxisVisibility l _layout_x_axis _layout_bottom_axis_visibility) xvals+    tAxis = mkAxis E_Top    (overrideAxisVisibility l _layout_x_axis _layout_top_axis_visibility   ) xvals+    lAxis = mkAxis E_Left   (overrideAxisVisibility l _layout_y_axis _layout_left_axis_visibility  ) yvals+    rAxis = mkAxis E_Right  (overrideAxisVisibility l _layout_y_axis _layout_right_axis_visibility ) yvals+    axes = (bAxis,lAxis,tAxis,rAxis)++    plotsToRenderable lxy = Renderable {+        minsize = return (0,0),+        render  = renderPlots lxy+    }++    -- | Render the plots of a 'Layout' to a plot area of given size.+    renderPlots :: Layout x y -> RectSize -> BackendProgram (PickFn (LayoutPick x y y))+    renderPlots lxy sz@(w,h) = do+        unless (_layout_grid_last lxy) (renderGrids sz axes)+        withClipRegion (Rect (Point 0 0) (Point w h)) $+          mapM_ rPlot (_layout_plots lxy)+        when (_layout_grid_last lxy) (renderGrids sz axes)+        return pickfn+      where+        rPlot = renderSinglePlot sz bAxis lAxis++        xr = (0, w)+        yr = (h, 0)++        pickfn :: PickFn (LayoutPick x y y)+        pickfn (Point x y) = do  -- Maybe monad+            xat <- mxat+            yat <- myat+            return (LayoutPick_PlotArea (mapx xat x) (mapy yat y) (mapy yat y))+          where+            mxat = case (bAxis,tAxis) of+                (Just at,_)       -> Just at+                (_,Just at)       -> Just at+                (Nothing,Nothing) -> Nothing+            myat = case (lAxis,rAxis) of+                (Just at,_)   -> Just at+                (_,Just at)   -> Just at+                (Nothing,Nothing)   -> Nothing+            mapx (AxisT _ _ rev ad) = _axis_tropweiv ad (optPairReverse rev xr)+            mapy (AxisT _ _ rev ad) = _axis_tropweiv ad (optPairReverse rev yr)++-- | Empty 'Layout' without title and plots. The background is white and+--   the grid is drawn beneath all plots. There will be a legend. The top+--   and right axis will not be visible.+instance (PlotValue x, PlotValue y) => Default (Layout x y) where+  def = Layout+    { _layout_background      = solidFillStyle $ opaque white+    , _layout_plot_background = Nothing++    , _layout_title           = ""+    , _layout_title_style     = def { _font_size   = 15+                                    , _font_weight = FontWeightBold }++    , _layout_x_axis                 = def+    , _layout_top_axis_visibility    = def { _axis_show_line   = False+                                           , _axis_show_ticks  = False+                                           , _axis_show_labels = False }+    , _layout_bottom_axis_visibility = def+    , _layout_y_axis                 = def+    , _layout_left_axis_visibility   = def+    , _layout_right_axis_visibility  = def { _axis_show_line   = False+                                           , _axis_show_ticks  = False+                                           , _axis_show_labels = False }++    , _layout_margin          = 10+    , _layout_plots           = []+    , _layout_legend          = Just def+    , _layout_grid_last       = False+    }++----------------------------------------------------------------------++-- | A LayoutLR value is a single plot area, with an x axis and+--   independent left and right y axes, with a title at the top;+--   legend at the bottom. It's parametrized by the types of values+--   to be plotted on the x and two y axes.+data LayoutLR x y1 y2 = LayoutLR+  { _layoutlr_background      :: FillStyle+    -- ^ How to fill the background of everything.+  , _layoutlr_plot_background :: Maybe FillStyle+    -- ^ How to fill the background of the plot,+    --   if different from the overall background.++  , _layoutlr_title           :: String+    -- ^ Title to display above the chart.+  , _layoutlr_title_style     :: FontStyle+    -- ^ Font style to use for the title.++  , _layoutlr_x_axis                 :: LayoutAxis x+    -- ^ Rules to generate the x axis.+  , _layoutlr_top_axis_visibility    :: AxisVisibility+    -- ^ Visibility options for the top axis.+  , _layoutlr_bottom_axis_visibility :: AxisVisibility+    -- ^ Visibility options for the bottom axis.++  , _layoutlr_left_axis             :: LayoutAxis y1+    -- ^ Rules to generate the left y axis.+  , _layoutlr_left_axis_visibility  :: AxisVisibility+    -- ^ Visibility options for the left axis.+  , _layoutlr_right_axis            :: LayoutAxis y2+    -- ^ Rules to generate the right y axis.+  , _layoutlr_right_axis_visibility :: AxisVisibility+    -- ^ Visibility options for the right axis.++  , _layoutlr_plots      :: [Either (Plot x y1) (Plot x y2)]+    -- ^ The data sets to plot in the chart.+    --   They are plotted over each other.+    --   The either type associates the plot with the+    --   left or right y axis.++  , _layoutlr_legend          :: Maybe LegendStyle+    -- ^ How to style the legend.+  , _layoutlr_margin          :: Double+    -- ^ The margin distance to use.+  , _layoutlr_grid_last       :: Bool+    -- ^ If the grid shall be rendered+    --   beneath (@False@) or over (@True@) all plots.+  }++instance (Ord x, Ord yl, Ord yr) => ToRenderable (LayoutLR x yl yr) where+  toRenderable = setPickFn nullPickFn . layoutLRToRenderable++-- | Render the given 'LayoutLR'.+layoutLRToRenderable :: forall x yl yr . (Ord x, Ord yl, Ord yr)+                     => LayoutLR x yl yr -> Renderable (LayoutPick x yl yr)+layoutLRToRenderable l = fillBackground (_layoutlr_background l)+                       $ gridToRenderable (layoutLRToGrid l)++layoutLRToGrid :: forall x yl yr . (Ord x, Ord yl, Ord yr)+                     => LayoutLR x yl yr -> Grid (Renderable (LayoutPick x yl yr))+layoutLRToGrid l = grid+  where+    grid = titleToRenderable lm (_layoutlr_title_style l) (_layoutlr_title l)+           `wideAbove`+           addMarginsToGrid (lm,lm,lm,lm) (layoutLRPlotAreaToGrid l)+           `aboveWide`+           renderLegendLR l (getLegendItemsLR l)+    lm = _layoutlr_margin l++getLayoutLRXVals :: LayoutLR x yl yr -> [x]+getLayoutLRXVals l = concatMap deEither $ _layoutlr_plots l+  where+    deEither :: Either (Plot x yl) (Plot x yr) -> [x]+    deEither (Left x)  = fst $ _plot_all_points x+    deEither (Right x) = fst $ _plot_all_points x++-- | Extract all 'LegendItem's from the plots of a 'LayoutLR'.+--   Left and right plot legend items are still separated.+getLegendItemsLR :: LayoutLR x yl yr -> ([LegendItem],[LegendItem])+getLegendItemsLR l = (+    concat [ _plot_legend p | (Left p ) <- _layoutlr_plots l ],+    concat [ _plot_legend p | (Right p) <- _layoutlr_plots l ]+    )++-- | Render the given 'LegendItem's for a 'LayoutLR'.+renderLegendLR :: LayoutLR x yl yr -> ([LegendItem],[LegendItem]) -> Renderable (LayoutPick x yl yr)+renderLegendLR l (lefts,rights) = gridToRenderable g+  where+    g      = besideN [ tval $ mkLegend (_layoutlr_legend l) (_layoutlr_margin l) lefts+                     , weights (1,1) $ tval emptyRenderable+                     , tval $ mkLegend (_layoutlr_legend l) (_layoutlr_margin l) rights ]+    -- lm     = _layoutlr_margin l++layoutLRPlotAreaToGrid :: forall x yl yr. (Ord x, Ord yl, Ord yr)+                       => LayoutLR x yl yr+                       -> Grid (Renderable (LayoutPick x yl yr))+layoutLRPlotAreaToGrid l = buildGrid LayoutGridElements{+  lge_plots = mfill (_layoutlr_plot_background l) $ plotsToRenderable l,+  lge_taxis = (tAxis,_laxis_title $ _layoutlr_x_axis l, _laxis_title_style $ _layoutlr_x_axis l),+  lge_baxis = (bAxis,_laxis_title $ _layoutlr_x_axis l, _laxis_title_style $ _layoutlr_x_axis l),+  lge_laxis = (lAxis,_laxis_title $ _layoutlr_left_axis l, _laxis_title_style $ _layoutlr_left_axis l),+  lge_raxis = (rAxis,_laxis_title $ _layoutlr_right_axis l, _laxis_title_style $ _layoutlr_right_axis l),+  lge_margin = _layoutlr_margin l+  }+  where+    xvals =  [ x | (Left p)  <- _layoutlr_plots l, x <- fst $ _plot_all_points p]+          ++ [ x | (Right p) <- _layoutlr_plots l, x <- fst $ _plot_all_points p]+    yvalsL = [ y | (Left p)  <- _layoutlr_plots l, y <- snd $ _plot_all_points p]+    yvalsR = [ y | (Right p) <- _layoutlr_plots l, y <- snd $ _plot_all_points p]++    bAxis = mkAxis E_Bottom (overrideAxisVisibility l _layoutlr_x_axis _layoutlr_bottom_axis_visibility) xvals+    tAxis = mkAxis E_Top    (overrideAxisVisibility l _layoutlr_x_axis _layoutlr_top_axis_visibility   ) xvals+    lAxis = mkAxis E_Left   (overrideAxisVisibility l _layoutlr_left_axis  _layoutlr_left_axis_visibility ) yvalsL+    rAxis = mkAxis E_Right  (overrideAxisVisibility l _layoutlr_right_axis _layoutlr_right_axis_visibility) yvalsR+    axes = (bAxis,lAxis,tAxis,rAxis)++    plotsToRenderable llr = Renderable {+        minsize = return (0,0),+        render  = renderPlots llr+    }++    renderPlots :: LayoutLR x yl yr -> RectSize -> BackendProgram (PickFn (LayoutPick x yl yr))+    renderPlots llr sz@(w,h) = do+        unless (_layoutlr_grid_last llr) (renderGrids sz axes)+        withClipRegion (Rect (Point 0 0) (Point w h)) $+          mapM_ rPlot (_layoutlr_plots llr)+        when (_layoutlr_grid_last llr) (renderGrids sz axes)+        return pickfn+      where+        rPlot (Left  p) = renderSinglePlot sz bAxis lAxis p+        rPlot (Right p) = renderSinglePlot sz bAxis rAxis p++        xr = (0, w)+        yr = (h, 0)++        pickfn (Point x y) = do  -- Maybe monad+            xat <- mxat+            (yatL,yatR) <- myats+            return (LayoutPick_PlotArea (mapx xat x) (mapy yatL y) (mapy yatR y))+          where+            mxat = case (bAxis,tAxis) of+                (Just at,_)       -> Just at+                (_,Just at)       -> Just at+                (Nothing,Nothing) -> Nothing+            myats = case (lAxis,rAxis) of+                (Just at1,Just at2) -> Just (at1,at2)+                (_,_)   -> Nothing+            mapx (AxisT _ _ rev ad) = _axis_tropweiv ad (optPairReverse rev xr)+            mapy (AxisT _ _ rev ad) = _axis_tropweiv ad (optPairReverse rev yr)++----------------------------------------------------------------------++-- | A layout with its y type hidden, so that it can be stacked+--   with other layouts with differing y axis, but the same x axis.+--   See 'StackedLayouts'.+data StackedLayout x = forall y     . (Ord y)          => StackedLayout (Layout x y)+                       -- ^ A 'Layout' to stack.+                     | forall yl yr . (Ord yl, Ord yr) => StackedLayoutLR (LayoutLR x yl yr)+                       -- ^ A 'LayoutLR' to stack.++-- | A container for a set of vertically 'StackedLayout's.+--   The x axis of the different layouts will be aligned.+data StackedLayouts x = StackedLayouts+  { _slayouts_layouts :: [StackedLayout x]+    -- ^ The stacked layouts from top (first element) to bottom (last element).+  , _slayouts_compress_legend :: Bool+    -- ^ If the different legends shall be combined in one legend at the bottom.+  }++-- | A empty 'StackedLayout' with compressions applied.+instance Default (StackedLayouts x) where+  def = StackedLayouts [] True++++instance Ord x => ToRenderable (StackedLayouts x) where+  toRenderable = renderStackedLayouts+++-- | Render several layouts with the same x-axis type and range,+--   vertically stacked so that their origins and x-values are aligned.+--+--   The legends from all the charts may be optionally combined, and shown+--   once on the bottom chart. See 'StackedLayouts' for further information.+renderStackedLayouts :: forall x. (Ord x) => StackedLayouts x -> Renderable ()+renderStackedLayouts (StackedLayouts{_slayouts_layouts=[]}) = emptyRenderable+renderStackedLayouts slp@(StackedLayouts{_slayouts_layouts=sls@(sl1:_)}) = gridToRenderable g+  where+    g = fullOverlayUnder (fillBackground bg emptyRenderable)+      $ foldr (above.mkGrid) nullt (zip sls [0,1..])++    mkGrid :: (StackedLayout x, Int) -> Grid (Renderable ())+    mkGrid (sl, i)+        = titleR+          `wideAbove`+          addMarginsToGrid (lm,lm,lm,lm) (mkPlotArea usedAxis)+          `aboveWide`+          (if showLegend then legendR else emptyRenderable)+      where+        titleR = case sl of+                   StackedLayout l -> noPickFn $ titleToRenderable (_layout_margin l) (_layout_title_style l) (_layout_title l)+                   StackedLayoutLR l -> noPickFn $ titleToRenderable (_layoutlr_margin l) (_layoutlr_title_style l) (_layoutlr_title l)+        legendR = case sl of+                    StackedLayout l -> noPickFn $ renderLegend l $ fst legenditems+                    StackedLayoutLR l -> noPickFn $ renderLegendLR l legenditems++        legenditems = case (_slayouts_compress_legend slp,isBottomPlot) of+            (False,_) -> case sl of+                           StackedLayout l -> (getLegendItems l, [])+                           StackedLayoutLR l -> getLegendItemsLR l+            (True,True) -> allLegendItems+            (True,False) -> ([],[])++        mkPlotArea :: LayoutAxis x -> Grid (Renderable ())+        mkPlotArea axis = case sl of+          StackedLayout l -> fmap noPickFn+                           $ layoutPlotAreaToGrid+                           $ l { _layout_x_axis = axis }+          StackedLayoutLR l -> fmap noPickFn+                             $ layoutLRPlotAreaToGrid+                             $ l { _layoutlr_x_axis = axis }++        showLegend = not (null (fst legenditems)) || not (null (snd legenditems))++        isBottomPlot = i == length sls - 1++        lm = case sl of+          StackedLayout l -> _layout_margin l+          StackedLayoutLR l -> _layoutlr_margin l++        xAxis :: LayoutAxis x+        xAxis = case sl of+          StackedLayout l -> _layout_x_axis l+          StackedLayoutLR l -> _layoutlr_x_axis l++        usedAxis :: LayoutAxis x+        usedAxis = xAxis+          { _laxis_generate = const (_laxis_generate xAxis all_xvals) }++    bg = case sl1 of+           StackedLayout l -> _layout_background l+           StackedLayoutLR l -> _layoutlr_background l++    getXVals :: StackedLayout x -> [x]+    getXVals (StackedLayout l) = getLayoutXVals l+    getXVals (StackedLayoutLR l) = getLayoutLRXVals l++    all_xvals = concatMap getXVals sls++    allLegendItems = (concatMap (fst.legendItems) sls, concatMap (snd.legendItems) sls)++    legendItems :: StackedLayout x -> ([LegendItem], [LegendItem])+    legendItems (StackedLayout l)   = (getLegendItems l, [])+    legendItems (StackedLayoutLR l) = getLegendItemsLR l++    noPickFn :: Renderable a -> Renderable ()+    noPickFn = mapPickFn (const ())++----------------------------------------------------------------------++addMarginsToGrid :: (Double,Double,Double,Double) -> Grid (Renderable a)+                 -> Grid (Renderable a)+addMarginsToGrid (t,b,l,r) g = aboveN [+     besideN [er, ts, er],+     besideN [ls, g,  rs],+     besideN [er, bs, er]+  ]+  where+    er = empty+    ts = tval $ spacer (0,t)+    ls = tval $ spacer (l,0)+    bs = tval $ spacer (0,b)+    rs = tval $ spacer (r,0)++titleToRenderable :: Double -> FontStyle -> String -> Renderable (LayoutPick x yl yr)+titleToRenderable _  _  "" = emptyRenderable+titleToRenderable lm fs s = addMargins (lm/2,0,0,0) (mapPickFn LayoutPick_Title title)+  where+    title = label fs HTA_Centre VTA_Centre s++mkLegend :: Maybe LegendStyle -> Double -> [LegendItem] -> Renderable (LayoutPick x yl yr)+mkLegend mls lm vals = case mls of+    Nothing -> emptyRenderable+    Just ls ->  case filter ((/="").fst) vals of+        []  -> emptyRenderable ;+        lvs -> addMargins (0,lm,lm,lm) $+                   mapPickFn LayoutPick_Legend $ legendToRenderable (Legend ls lvs)+++data LayoutGridElements x yl yr = LayoutGridElements {+  lge_plots :: Renderable (LayoutPick x yl yr),++  lge_taxis :: (Maybe (AxisT x),String,FontStyle),+  lge_baxis :: (Maybe (AxisT x),String,FontStyle),+  lge_laxis :: (Maybe (AxisT yl),String,FontStyle),+  lge_raxis :: (Maybe (AxisT yr),String,FontStyle),++  lge_margin :: Double+}++buildGrid :: (Ord x, Ord yl, Ord yr) => LayoutGridElements x yl yr -> Grid (Renderable (LayoutPick x yl yr))+buildGrid lge = layer2 `overlay` layer1+  where+    layer1 = aboveN+         [ besideN [er,     er,  er,    er   ]+         , besideN [er,     er,  er,    weights (1,1) plots ]+         ]++    layer2 = aboveN+         [ besideN [er,     er,  tl,    taxis,  tr,    er,  er       ]+         , besideN [ltitle, lam, laxis, er,     raxis, ram, rtitle   ]+         , besideN [er,     er,  bl,    baxis,  br,    er,  er       ]+         , besideN [er,     er,  er,    btitle, er,    er,  er       ]+         ]++    er = tval emptyRenderable++    plots = tval $ lge_plots lge++    (tdata,_,_)         = lge_taxis lge+    (bdata,blbl,bstyle) = lge_baxis lge+    (ldata,llbl,lstyle) = lge_laxis lge+    (rdata,rlbl,rstyle) = lge_raxis lge++    -- (ttitle,_) = mktitle HTA_Centre VTA_Bottom   0 tlbl tstyle LayoutPick_XTopAxisTitle+    (btitle,_) = mktitle HTA_Centre VTA_Top      0 blbl bstyle LayoutPick_XBottomAxisTitle+    (ltitle,lam) = mktitle HTA_Right  VTA_Centre 270 llbl lstyle LayoutPick_YLeftAxisTitle+    (rtitle,ram) = mktitle HTA_Left   VTA_Centre 270 rlbl rstyle LayoutPick_YRightAxisTitle++    baxis = tval $ maybe emptyRenderable+                         (mapPickFn LayoutPick_XBottomAxis . axisToRenderable) bdata+    taxis = tval $ maybe emptyRenderable+                         (mapPickFn LayoutPick_XTopAxis . axisToRenderable) tdata+    laxis = tval $ maybe emptyRenderable+                         (mapPickFn LayoutPick_YLeftAxis . axisToRenderable) ldata+    raxis = tval $ maybe emptyRenderable+                         (mapPickFn LayoutPick_YRightAxis . axisToRenderable) rdata++    tl = tval $ axesSpacer fst tdata fst ldata+    bl = tval $ axesSpacer fst bdata snd ldata+    tr = tval $ axesSpacer snd tdata fst rdata+    br = tval $ axesSpacer snd bdata snd rdata++    mktitle :: HTextAnchor -> VTextAnchor+            -> Double+            -> String -> FontStyle+            -> (String -> LayoutPick x yl yr)+            -> ( Grid (Renderable (LayoutPick x yl yr))+               , Grid (Renderable (LayoutPick x yl yr)) )+    mktitle ha va rot lbl style pf = if lbl == "" then (er,er) else (labelG,gapG)+      where+        labelG = tval $ mapPickFn pf $ rlabel style ha va rot lbl+        gapG = tval $ spacer (lge_margin lge,0)++-- | Render the grids of the given axis to a plot area of given size.+renderGrids :: RectSize -> (Maybe (AxisT x), Maybe (AxisT yl), Maybe (AxisT x), Maybe (AxisT yr)) -> BackendProgram ()+renderGrids sz (bAxis, lAxis, tAxis, rAxis) = do+  maybeM () (renderAxisGrid sz) tAxis+  maybeM () (renderAxisGrid sz) bAxis+  maybeM () (renderAxisGrid sz) lAxis+  maybeM () (renderAxisGrid sz) rAxis++-- | Swap the contents of the pair depending on the flag.+optPairReverse :: Bool -> (a,a) -> (a,a)+optPairReverse rev (a,b) = if rev then (b,a) else (a,b)++-- | Render a single set of plot data onto a plot area of given size using+--   the given x and y axis.+renderSinglePlot :: RectSize -> Maybe (AxisT x) -> Maybe (AxisT y) -> Plot x y -> BackendProgram ()+renderSinglePlot (w, h) (Just (AxisT _ _ xrev xaxis)) (Just (AxisT _ _ yrev yaxis)) p =+  let xr = optPairReverse xrev (0, w)+      yr = optPairReverse yrev (h, 0)+      -- yrange = if yrev then (0, h) else (h, 0)+      pmfn (x,y) = Point (mapv xr (_axis_viewport xaxis xr) x)+                         (mapv yr (_axis_viewport yaxis yr) y)+      mapv lims _ LMin       = fst lims+      mapv lims _ LMax       = snd lims+      mapv _    f (LValue v) = f v+  in _plot_render p pmfn+renderSinglePlot _ _ _ _ = return ()++axesSpacer :: (Ord x, Ord y)+           => ((Double, Double) -> Double) -> Maybe (AxisT x)+           -> ((Double, Double) -> Double) -> Maybe (AxisT y)+           -> Renderable a+axesSpacer f1 a1 f2 a2 = embedRenderable $ do+    oh1 <- maybeM (0,0) axisOverhang a1+    oh2 <- maybeM (0,0) axisOverhang a2+    return (spacer (f1 oh1, f2 oh2))++-- | Construct a axis for the given edge using the attributes+--   from a 'LayoutAxis' the given values.+mkAxis :: RectEdge -> LayoutAxis z -> [z] -> Maybe (AxisT z)+mkAxis edge laxis vals = if axisVisible+                           then Just $ AxisT edge style rev adata+                           else Nothing+  where+    style = _laxis_style laxis+    rev   = _laxis_reverse laxis+    adata = _laxis_override laxis (_laxis_generate laxis vals)+    vis   = _axis_visibility adata+    axisVisible = _axis_show_labels vis || _axis_show_line vis || _axis_show_ticks vis++-- | Override the visibility of a selected axis with the selected 'AxisVisibility'.+overrideAxisVisibility :: layout+                       -> (layout -> LayoutAxis z)+                       -> (layout -> AxisVisibility)+                       -> LayoutAxis z+overrideAxisVisibility ly selAxis selVis =+  let vis = selVis ly+  in (selAxis ly) { _laxis_override = (\ad -> ad { _axis_visibility = vis })+                                    . _laxis_override (selAxis ly)+                  }++mfill :: Maybe FillStyle -> Renderable a -> Renderable a+mfill Nothing   = id+mfill (Just fs) = fillBackground fs++-- | Empty 'LayoutLR' without title and plots. The background is white and+--   the grid is drawn beneath all plots. There will be a legend. The top+--   axis will not be visible.+instance (PlotValue x, PlotValue y1, PlotValue y2) => Default (LayoutLR x y1 y2) where+  def = LayoutLR+    { _layoutlr_background      = solidFillStyle $ opaque white+    , _layoutlr_plot_background = Nothing++    , _layoutlr_title           = ""+    , _layoutlr_title_style     = def { _font_size   = 15+                                      , _font_weight = FontWeightBold }++    , _layoutlr_x_axis                 = def+    , _layoutlr_top_axis_visibility    = def { _axis_show_line   = False+                                             , _axis_show_ticks  = False+                                             , _axis_show_labels = False }+    , _layoutlr_bottom_axis_visibility = def++    , _layoutlr_left_axis           = def+    , _layoutlr_left_axis_visibility  = def+    , _layoutlr_right_axis          = def+    , _layoutlr_right_axis_visibility = def++    , _layoutlr_plots      = []++    , _layoutlr_legend          = Just def+    , _layoutlr_margin          = 10+    , _layoutlr_grid_last       = False+    }++instance PlotValue t => Default (LayoutAxis t) where+  def = LayoutAxis+    { _laxis_title_style = def { _font_size=10 }+    , _laxis_title       = ""+    , _laxis_style       = def+    , _laxis_generate    = autoAxis+    , _laxis_override    = id+    , _laxis_reverse     = False+    }++----------------------------------------------------------------------+-- Template haskell to derive an instance of Data.Accessor.Accessor+-- for each field.+$( makeLenses ''Layout )+$( makeLenses ''LayoutLR )+$( makeLenses ''LayoutAxis )+$( makeLenses ''StackedLayouts )++-- | Setter to update all axis styles on a `Layout`+layout_axes_styles :: Setter' (Layout x y) AxisStyle+layout_axes_styles = sets $ \af ->+    (layout_x_axis . laxis_style %~ af) .+    (layout_y_axis . laxis_style %~ af)++-- | Setter to update all the axes title styles on a `Layout`+layout_axes_title_styles :: Setter' (Layout x y) FontStyle+layout_axes_title_styles = sets $ \af ->+    (layout_x_axis . laxis_title_style %~ af) .+    (layout_y_axis . laxis_title_style %~ af)++-- | Setter to update all the font styles on a `Layout`+layout_all_font_styles :: Setter' (Layout x y) FontStyle+layout_all_font_styles = sets $ \af ->+    (layout_axes_title_styles %~ af) .+    (layout_x_axis . laxis_style . axis_label_style %~ af) .+    (layout_y_axis . laxis_style . axis_label_style %~ af) .+    (layout_legend . _Just . legend_label_style %~ af) .+    (layout_title_style %~ af)++-- | Setter to update the foreground color of core chart elements on a `Layout`+layout_foreground ::  Setter' (Layout x y) (AlphaColour Double)+layout_foreground = sets $ \af ->+    (layout_all_font_styles . font_color %~ af) .+    (layout_axes_styles . axis_line_style . line_color %~ af)++-- | Setter to update all axis styles on a `LayoutLR`+layoutlr_axes_styles :: Setter' (LayoutLR x y1 y2) AxisStyle+layoutlr_axes_styles = sets $ \af ->+    (layoutlr_x_axis . laxis_style %~ af) .+    (layoutlr_left_axis . laxis_style %~ af) .+    (layoutlr_right_axis . laxis_style %~ af)++-- | Setter to update all the axes title styles on a `LayoutLR`+layoutlr_axes_title_styles :: Setter' (LayoutLR x y1 y2) FontStyle+layoutlr_axes_title_styles = sets $ \af ->+    (layoutlr_x_axis . laxis_title_style %~ af) .+    (layoutlr_left_axis . laxis_title_style %~ af) .+    (layoutlr_right_axis . laxis_title_style %~ af)++-- | Setter to update all the font styles on a `LayoutLR`+layoutlr_all_font_styles :: Setter' (LayoutLR x y1 y2) FontStyle+layoutlr_all_font_styles = sets $ \af ->+    (layoutlr_axes_title_styles %~ af) .+    (layoutlr_x_axis . laxis_style . axis_label_style %~ af) .+    (layoutlr_left_axis . laxis_style . axis_label_style %~ af) .+    (layoutlr_right_axis . laxis_style . axis_label_style %~ af) .+    (layoutlr_legend . _Just . legend_label_style %~ af) .+    (layoutlr_title_style %~ af)++-- | Setter to update the foreground color of core chart elements on a `LayoutLR`+layoutlr_foreground ::  Setter' (LayoutLR x y1 y2) (AlphaColour Double)+layoutlr_foreground = sets $ \af ->+    (layoutlr_all_font_styles . font_color %~ af) .+    (layoutlr_axes_styles . axis_line_style . line_color %~ af)
Graphics/Rendering/Chart/Legend.hs view
@@ -1,33 +1,32 @@ ----------------------------------------------------------------------------- -- | -- 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 -- is an area on the chart used to label the plotted values.--{-# OPTIONS_GHC -XTemplateHaskell #-}+{-# LANGUAGE TemplateHaskell #-}  module Graphics.Rendering.Chart.Legend(     Legend(..),     LegendStyle(..),     LegendOrientation(..),-    defaultLegendStyle,+    LegendPosition(..),     legendToRenderable,     legend_label_style,     legend_margin,     legend_plot_size,-    legend_orientation+    legend_orientation,+    legend_position ) where -import qualified Graphics.Rendering.Cairo as C-import Control.Monad-import Data.List (nub, partition,intersperse)-import Data.Accessor.Template+import Data.List (partition,intersperse)+import Control.Lens+import Data.Default.Class -import Graphics.Rendering.Chart.Types-import Graphics.Rendering.Chart.Plot.Types+import Graphics.Rendering.Chart.Geometry+import Graphics.Rendering.Chart.Drawing import Graphics.Rendering.Chart.Renderable import Graphics.Rendering.Chart.Grid @@ -35,10 +34,11 @@ -- Legend  data LegendStyle = LegendStyle {-   legend_label_style_ :: CairoFontStyle,-   legend_margin_      :: Double,-   legend_plot_size_   :: Double,-   legend_orientation_ :: LegendOrientation+   _legend_label_style :: FontStyle,+   _legend_margin      :: Double,+   _legend_plot_size   :: Double,+   _legend_orientation :: LegendOrientation,+   _legend_position    :: LegendPosition }  -- | Legends can be constructed in two orientations: in rows@@ -46,62 +46,80 @@ -- columns (where we specify the maximum number of rows) data LegendOrientation = LORows Int                        | LOCols Int-                        -data Legend x y = Legend LegendStyle [(String, Rect -> CRender ())]+-- | Defines the position of the legend, relative to the plot.+data LegendPosition = LegendAbove+                    | LegendBelow+                    | LegendRight+                    | LegendLeft +data Legend x y = Legend LegendStyle [(String, Rect -> BackendProgram ())]+ instance ToRenderable (Legend x y) where-  toRenderable = setPickFn nullPickFn.legendToRenderable+  toRenderable = setPickFn nullPickFn . legendToRenderable  legendToRenderable :: Legend x y -> Renderable String legendToRenderable (Legend ls lvs) = gridToRenderable grid   where-    grid = case legend_orientation_ ls of+    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 -> CRender ()])]+    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 {-                     minsize = return (legend_plot_size_ ls, 0),-                     render  = \(w,h) -> do -                         rfn (Rect (Point 0 0) (Point w h))++        rp :: (Rect -> BackendProgram ()) -> Grid (Renderable String)+        rp rfn = tval Renderable {+                     minsize = return (_legend_plot_size ls, 0),+                     render  = \(w,h) -> do+                         _ <- rfn (Rect (Point 0 0) (Point w h))                          return (\_-> Just title)                  } -    ggap1 = tval $ spacer (legend_margin_ ls,legend_margin_ ls / 2)+    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 []          = [] -defaultLegendStyle :: LegendStyle-defaultLegendStyle = LegendStyle {-    legend_label_style_ = defaultFontStyle,-    legend_margin_      = 20,-    legend_plot_size_   = 20,-    legend_orientation_ = LORows 4-}+instance Default LegendStyle where+  def = LegendStyle+    { _legend_label_style = def+    , _legend_margin      = 20+    , _legend_plot_size   = 20+    , _legend_orientation = LORows 4+    , _legend_position    = LegendBelow+    } -------------------------------------------------------------------------- Template haskell to derive an instance of Data.Accessor.Accessor--- for each field.-$( deriveAccessors ''LegendStyle )+$( makeLenses ''LegendStyle )
Graphics/Rendering/Chart/Plot.hs view
@@ -7,12 +7,10 @@ -- Code to calculate and render various types of plots. -- -{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# OPTIONS_GHC -XTemplateHaskell #-}- 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,@@ -22,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@@ -35,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,80 +1,101 @@ ----------------------------------------------------------------------------- -- | -- 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. -{-# OPTIONS_GHC -XTemplateHaskell #-}+{-# LANGUAGE TemplateHaskell #-}  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 Data.Accessor.Template-import qualified Graphics.Rendering.Cairo as C-import Graphics.Rendering.Chart.Types+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 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,-      plot_annotation_style_   :: CairoFontStyle,-      plot_annotation_values_  :: [(x,y,String)]+      _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+        vs = _plot_annotation_values p  -renderAnnotation :: PlotAnnotation x y -> PointMapFn x y -> CRender ()--renderAnnotation p pMap = preserveCState $ do-                            setFontStyle style                            +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)--defaultPlotAnnotation = PlotAnnotation {-                          plot_annotation_hanchor_ = HTA_Centre,-                          plot_annotation_vanchor_ = VTA_Centre,-                          plot_annotation_angle_   = 0,-                          plot_annotation_style_   = defaultFontStyle,-                          plot_annotation_values_  = []-}--------------------------------------------------------------------------- Template haskell to derive an instance of Data.Accessor.Accessor--- for each field.+    where hta = _plot_annotation_hanchor p+          vta = _plot_annotation_vanchor p+          values = _plot_annotation_values p+          angle =  _plot_annotation_angle p+          style =  _plot_annotation_style p+          offset = _plot_annotation_offset p+          rectangle = _plot_annotation_background p+          (x1,y1) = _rect_minsize rectangle+          drawRect (x,y,s) = do+              ts <- textSize s+              let (x2,y2) = (textSizeWidth ts, textSizeHeight ts)+                  Point x3 y3 = point x y+                  -- position of top-left vertex of the rectangle+                  xvp HTA_Left = x3 - x1 / 2+                  xvp HTA_Centre = x3 - (x1 + x2) / 2+                  xvp HTA_Right = x3 - x2 - x1 / 2+                  yvp VTA_Top = y3 - y1 / 2+                  yvp VTA_Centre = y3 - (y1 + y2) / 2+                  yvp VTA_Bottom = y3 - y2 - y1 / 2+                  yvp VTA_BaseLine = y3 - y1 / 2 - textSizeAscent ts+              drawRectangle (Point (xvp hta) (yvp vta) `pvadd` offset) rectangle{ _rect_minsize = (x1+x2,y1+y2) }+          drawOne (x,y,s) = drawTextsR hta vta angle (point x y) s+          point x y = pMap (LValue x, LValue y) `pvadd` offset -$( deriveAccessors ''PlotAnnotation )+instance Default (PlotAnnotation x y) where+  def = PlotAnnotation+    { _plot_annotation_hanchor = HTA_Centre+    , _plot_annotation_vanchor = VTA_Centre+    , _plot_annotation_angle   = 0+    , _plot_annotation_style   = def+    , _plot_annotation_background = def+    , _plot_annotation_values  = []+    , _plot_annotation_offset  = Vector 0 0+    } +$( makeLenses ''PlotAnnotation )
Graphics/Rendering/Chart/Plot/AreaSpots.hs view
@@ -7,118 +7,103 @@ -- with x,y position, and an independent z value to be represented -- by the relative area of the spots. -{-# OPTIONS_GHC -XTemplateHaskell #-}+{-# LANGUAGE TemplateHaskell #-}  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 qualified Graphics.Rendering.Cairo as C--import Graphics.Rendering.Chart.Types+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 Data.Accessor.Template-import Data.Colour+import Control.Lens+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-  { area_spots_title_      :: String-  , area_spots_linethick_  :: Double-  , area_spots_linecolour_ :: AlphaColour Double-  , area_spots_fillcolour_ :: Colour Double-  , area_spots_opacity_    :: Double-  , area_spots_max_radius_ :: Double	-- ^ the largest size of spot-  , area_spots_values_     :: [(x,y,z)]+  { _area_spots_title      :: String+  , _area_spots_linethick  :: Double+  , _area_spots_linecolour :: AlphaColour Double+  , _area_spots_fillcolour :: Colour Double+  , _area_spots_opacity    :: Double+  , _area_spots_max_radius :: Double   -- ^ the largest size of spot+  , _area_spots_values     :: [(x,y,z)]   } -defaultAreaSpots :: AreaSpots z x y-defaultAreaSpots = AreaSpots-  { area_spots_title_      = ""-  , area_spots_linethick_  = 0.1-  , area_spots_linecolour_ = opaque blue-  , area_spots_fillcolour_ = blue-  , area_spots_opacity_    = 0.2-  , area_spots_max_radius_ = 20  -- in pixels-  , area_spots_values_     = []-  }+instance Default (AreaSpots z x y) where+  def = AreaSpots+    { _area_spots_title      = ""+    , _area_spots_linethick  = 0.1+    , _area_spots_linecolour = opaque blue+    , _area_spots_fillcolour = blue+    , _area_spots_opacity    = 0.2+    , _area_spots_max_radius = 20  -- in pixels+    , _area_spots_values     = []+    }  instance (PlotValue z) => ToPlot (AreaSpots z) where-    toPlot p = Plot { plot_render_ = renderAreaSpots p-                    , plot_legend_ = [(area_spots_title_ p, renderSpotLegend p)]-                    , plot_all_points_ = ( map fst3 (area_spots_values_ p)-                                         , map snd3 (area_spots_values_ p) )+    toPlot p = Plot { _plot_render = renderAreaSpots p+                    , _plot_legend = [(_area_spots_title p, renderSpotLegend p)]+                    , _plot_all_points = ( map (^._1) (_area_spots_values p)+                                         , map (^._2) (_area_spots_values p) )                     } -renderAreaSpots  :: (PlotValue z) =>-                    AreaSpots z x y -> PointMapFn x y -> CRender ()-renderAreaSpots p pmap = preserveCState $-    forM_ (scaleMax ((area_spots_max_radius_ p)^2)-                    (area_spots_values_ p))+renderAreaSpots  :: (PlotValue z) => AreaSpots z x y -> PointMapFn x y -> BackendProgram ()+renderAreaSpots p pmap = +    forM_ (scaleMax (_area_spots_max_radius p^(2::Integer))+                    (_area_spots_values p))           (\ (x,y,z)-> do               let radius = sqrt z-              let (CairoPointStyle drawSpotAt)    = filledCircles radius $+              let psSpot = filledCircles radius $                                                     flip withOpacity -                                                      (area_spots_opacity_ p) $-                                                    area_spots_fillcolour_ p-              drawSpotAt (pmap (LValue x, LValue y))-              let (CairoPointStyle drawOutlineAt) = hollowCircles radius-                                                      (area_spots_linethick_ p)-                                                      (area_spots_linecolour_ p)-              drawOutlineAt (pmap (LValue x, LValue y))+                                                      (_area_spots_opacity p) $+                                                    _area_spots_fillcolour p+              drawPoint psSpot (pmap (LValue x, LValue y))+              let psOutline = hollowCircles radius+                                                      (_area_spots_linethick p)+                                                      (_area_spots_linecolour p)+              drawPoint psOutline (pmap (LValue x, LValue y))           )   where     scaleMax :: PlotValue z => Double -> [(x,y,z)] -> [(x,y,Double)]-    scaleMax n points = let largest  = maximum (map (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 -> CRender ()-renderSpotLegend p r@(Rect p1 p2) = preserveCState $ 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 (CairoPointStyle drawSpotAt)    = filledCircles radius $-                                          flip withOpacity -                                               (area_spots_opacity_ p) $-                                          area_spots_fillcolour_ p-    drawSpotAt centre-    let (CairoPointStyle drawOutlineAt) = hollowCircles radius-                                            (area_spots_linethick_ p)-                                            (area_spots_linecolour_ p)-    drawOutlineAt centre+        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)@@ -129,56 +114,56 @@ --   from a given palette.  (A linear transfer function from t to palette --   is assumed.) data AreaSpots4D z t x y = AreaSpots4D-  { area_spots_4d_title_      :: String-  , area_spots_4d_linethick_  :: Double-  , area_spots_4d_palette_    :: [Colour Double]-  , area_spots_4d_opacity_    :: Double-  , area_spots_4d_max_radius_ :: Double	-- ^ the largest size of spot-  , area_spots_4d_values_     :: [(x,y,z,t)]+  { _area_spots_4d_title      :: String+  , _area_spots_4d_linethick  :: Double+  , _area_spots_4d_palette    :: [Colour Double]+  , _area_spots_4d_opacity    :: Double+  , _area_spots_4d_max_radius :: Double        -- ^ the largest size of spot+  , _area_spots_4d_values     :: [(x,y,z,t)]   } -defaultAreaSpots4D :: AreaSpots4D z t x y-defaultAreaSpots4D = AreaSpots4D-  { area_spots_4d_title_      = ""-  , area_spots_4d_linethick_  = 0.1-  , area_spots_4d_palette_    = [ blue, green, yellow, orange, red ]-  , area_spots_4d_opacity_    = 0.2-  , area_spots_4d_max_radius_ = 20  -- in pixels-  , area_spots_4d_values_     = []-  }+instance Default (AreaSpots4D z t x y) where+  def = AreaSpots4D+    { _area_spots_4d_title      = ""+    , _area_spots_4d_linethick  = 0.1+    , _area_spots_4d_palette    = [ blue, green, yellow, orange, red ]+    , _area_spots_4d_opacity    = 0.2+    , _area_spots_4d_max_radius = 20  -- in pixels+    , _area_spots_4d_values     = []+    }  instance (PlotValue z, PlotValue t, Show t) => ToPlot (AreaSpots4D z t) where-    toPlot p = Plot { plot_render_ = renderAreaSpots4D p-                    , plot_legend_ = [ (area_spots_4d_title_ p+    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 -> CRender ()-renderAreaSpots4D p pmap = preserveCState $-    forM_ (scaleMax ((area_spots_4d_max_radius_ p)^2)-                    (length (area_spots_4d_palette_ p))-                    (area_spots_4d_values_ p))+                      AreaSpots4D z t x y -> PointMapFn x y -> BackendProgram ()+renderAreaSpots4D p pmap = +    forM_ (scaleMax (_area_spots_4d_max_radius p^(2::Integer))+                    (length (_area_spots_4d_palette p))+                    (_area_spots_4d_values p))           (\ (x,y,z,t)-> do               let radius  = sqrt z-              let colour  = (area_spots_4d_palette_ p) !! t -              let (CairoPointStyle drawSpotAt)+              let colour  = _area_spots_4d_palette p !! t +              let psSpot                     = filledCircles radius $-                          flip withOpacity (area_spots_4d_opacity_ p) $ colour-              drawSpotAt (pmap (LValue x, LValue y))-              let (CairoPointStyle drawOutlineAt)-                    = hollowCircles radius (area_spots_4d_linethick_ p)+                          withOpacity colour (_area_spots_4d_opacity p)+              drawPoint psSpot (pmap (LValue x, LValue y))+              let psOutline+                    = hollowCircles radius (_area_spots_4d_linethick p)                                            (opaque colour)-              drawOutlineAt (pmap (LValue x, LValue y))+              drawPoint psOutline (pmap (LValue x, LValue y))           )   where     scaleMax :: (PlotValue z, PlotValue t, Show t) =>                 Double -> Int -> [(x,y,z,t)] -> [(x,y,Double,Int)]-    scaleMax n c points = let largest  = maximum (map (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) $ @@ -188,25 +173,20 @@                           in map (\ (x,y,z,t) -> (x,y, scale z, select t))                                  points -renderSpotLegend4D :: AreaSpots4D z t x y -> Rect -> CRender ()-renderSpotLegend4D p r@(Rect p1 p2) = preserveCState $ 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 (CairoPointStyle drawSpotAt)    = filledCircles radius $-                                          flip withOpacity-                                               (area_spots_4d_opacity_ p) $-                                          head $ area_spots_4d_palette_ p-    drawSpotAt centre-    let (CairoPointStyle drawOutlineAt) = hollowCircles radius-                                            (area_spots_4d_linethick_ p)-                                            (opaque $-                                             head (area_spots_4d_palette_ p))-    drawOutlineAt centre+        palCol = head $ _area_spots_4d_palette p+        psSpot = filledCircles radius $ withOpacity palCol+                                        (_area_spots_4d_opacity p)+        psOutline = hollowCircles radius (_area_spots_4d_linethick p)+                                         (opaque palCol)+    drawPoint psSpot centre+    drawPoint psOutline centre   where     linearInterpolate (Point x0 y0) (Point x1 y1) =         Point (x0 + abs(x1-x0)/2) (y0 + abs(y1-y0)/2) ----------------------------------------------------------------------------- Template haskell to derive Data.Accessor.Accessor-$( deriveAccessors ''AreaSpots )-$( deriveAccessors ''AreaSpots4D )+$( makeLenses ''AreaSpots )+$( makeLenses ''AreaSpots4D )
Graphics/Rendering/Chart/Plot/Bars.hs view
@@ -1,56 +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 ---{-# OPTIONS_GHC -XTemplateHaskell #-}+{-# 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 Data.Accessor.Template+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 qualified Graphics.Rendering.Cairo as C-import Graphics.Rendering.Chart.Types-import Graphics.Rendering.Chart.Renderable-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 Graphics.Rendering.Chart.Drawing+import Graphics.Rendering.Chart.Geometry hiding (x0, y0)+import Graphics.Rendering.Chart.Plot.Types+import Graphics.Rendering.Chart.Utils class PlotValue a => BarsPlotValue a where-    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.@@ -68,158 +96,316 @@ -- | How bars for a given (x,[y]) are aligned with respect to screen --   coordinate corresponding to x (deviceX). data PlotBarsAlignment = BarsLeft      -- ^ The left edge of bars is at deviceX-                       | BarsCentered  -- ^ The right edge of bars is at deviceX-                       | BarsRight     -- ^ Bars are centered around deviceX+                       | BarsCentered  -- ^ Bars are centered around deviceX+                       | BarsRight     -- ^ The right edge of bars is at deviceX      deriving (Show) +data BarHorizAnchor+    = BHA_Left+    | BHA_Centre+    | BHA_Right+     deriving (Show)++data BarVertAnchor+    = BVA_Bottom+    | BVA_Centre+    | BVA_Top+     deriving (Show)+ -- | Value describing how to plot a set of bars. --   Note that the input data is typed [(x,[y])], ie for each x value --   we plot several y values. Typically the size of each [y] list would --   be the same.-data 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_     :: [ (CairoFillStyle,Maybe CairoLineStyle) ],--   -- | 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, -defaultPlotBars :: BarsPlotValue y => PlotBars x y-defaultPlotBars = PlotBars {-   plot_bars_style_           = BarsClustered,-   plot_bars_item_styles_     = cycle istyles,-   plot_bars_titles_          = [],-   plot_bars_spacing_         = BarsFixGap 10 2,-   plot_bars_alignment_       = BarsCentered,-   plot_bars_values_          = [],-   plot_bars_singleton_width_ = 20,-   plot_bars_reference_       = barsReference-   }-  where-    istyles   = map mkstyle defaultColorSeq-    mkstyle c = (solidFillStyle c, Just (solidLine 1.0 $ opaque black))+    -- | The anchor point on the label.+   _bars_settings_label_text_hanchor :: HTextAnchor, +    -- | The anchor point on the label.+   _bars_settings_label_text_vanchor :: VTextAnchor,++   -- | Angle, in degrees, to rotate the label about the anchor point.+   _bars_settings_label_angle   :: Double,++   -- | The style to use for the label.+   _bars_settings_label_style   :: FontStyle,++   -- | The offset from the anchor point to display the label at.+   _bars_settings_label_offset  :: Vector+}+instance Default BarsSettings where+  def = BarsSettings+    { _bars_settings_style              = BarsClustered+    , _bars_settings_item_styles        = cycle istyles+    , _bars_settings_spacing            = BarsFixGap 10 2+    , _bars_settings_alignment          = BarsCentered+    , _bars_settings_singleton_width    = 20+    , _bars_settings_label_bar_hanchor  = BHA_Centre+    , _bars_settings_label_bar_vanchor  = BVA_Top+    , _bars_settings_label_text_hanchor = HTA_Centre+    , _bars_settings_label_text_vanchor = VTA_Bottom+    , _bars_settings_label_angle        = 0+    , _bars_settings_label_style        = def+    , _bars_settings_label_offset       = Vector 0 0+    }+    where+      istyles   = map mkstyle defaultColorSeq+      mkstyle c = (solidFillStyle c, Just (solidLine 1.0 $ opaque black))+data PlotBars x y = PlotBars {+   _plot_bars_settings :: BarsSettings,+   -- | The title of each element of [y]. These will be shown in the legend.+   _plot_bars_titles :: [String],+   -- | The actual points to be plotted, and their labels+   _plot_bars_values_with_labels :: [(x, [(y, String)])]+}+instance Default (PlotBars x y) where+  def = PlotBars+    { _plot_bars_settings = def+    , _plot_bars_titles = []+    , _plot_bars_values_with_labels = []+    }+ plotBars :: (BarsPlotValue y) => PlotBars x y -> Plot x y plotBars p = Plot {-        plot_render_     = renderPlotBars p,-        plot_legend_     = zip (plot_bars_titles_ 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 -> CRender ()-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) = preserveCState $ do-       forM_ (zip3 [0,1..] ys styles) $ \(i, y, (fstyle,_)) -> do-           setFillStyle fstyle-           fillPath (barPath (offset i) x yref0 y)-           c $ C.fill-       forM_ (zip3 [0,1..] ys styles) $ \(i, y, (_,mlstyle)) -> do-           whenJust mlstyle $ \lstyle -> do-             setLineStyle lstyle-             strokePath (barPath (offset i) x yref0 y)+    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) =  preserveCState $ 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-           setFillStyle fstyle-           fillPath (barPath ofs x y0 y1)-       forM_ (zip y2s styles) $ \((y0,y1), (_,mlstyle)) -> do-           whenJust mlstyle $ \lstyle -> do-               setLineStyle lstyle-               strokePath (barPath ofs x y0 y1)+    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 :: (CairoFillStyle,Maybe CairoLineStyle) -> Rect-                        -> CRender ()-renderPlotLegendBars (fstyle,mlstyle) r@(Rect p1 p2) = do-    setFillStyle fstyle+renderPlotLegendBars :: (FillStyle,Maybe LineStyle) -> Rect -> BackendProgram ()+renderPlotLegendBars (fstyle,_) r =+  withFillStyle fstyle $     fillPath (rectPath r) -------------------------------------------------------------------------- Template haskell to derive an instance of Data.Accessor.Accessor--- for each field.+$( makeLenses ''BarsSettings )+$( makeLenses ''PlotBars ) -$( deriveAccessors ''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,17 +1,16 @@ ----------------------------------------------------------------------------- -- | -- 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 ---{-# OPTIONS_GHC -XTemplateHaskell #-}+{-# LANGUAGE TemplateHaskell #-}  module Graphics.Rendering.Chart.Plot.Candle(     PlotCandle(..),     Candle(..),-    defaultPlotCandle,      plot_candle_title,     plot_candle_line_style,@@ -24,15 +23,15 @@     plot_candle_values, ) where -import Data.Accessor.Template-import qualified Graphics.Rendering.Cairo as C-import Graphics.Rendering.Chart.Types-import Graphics.Rendering.Chart.Renderable+import Control.Lens hiding (op)++import Graphics.Rendering.Chart.Geometry hiding (close)+import Graphics.Rendering.Chart.Drawing import Graphics.Rendering.Chart.Plot.Types import Control.Monad import Data.Colour (opaque)-import Data.Colour.Names (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 --   maxima and minima; and a style in which to render them.@@ -41,15 +40,15 @@ --   (This plot type can also be re-purposed for statistical intervals, e.g. --    minimum, first quartile, median, third quartile, maximum.) data PlotCandle x y = PlotCandle {-    plot_candle_title_           :: String,-    plot_candle_line_style_      :: CairoLineStyle,-    plot_candle_fill_            :: Bool,-    plot_candle_rise_fill_style_ :: CairoFillStyle,-    plot_candle_fall_fill_style_ :: CairoFillStyle,-    plot_candle_tick_length_     :: Double,-    plot_candle_width_           :: Double,-    plot_candle_centre_          :: Double,-    plot_candle_values_          :: [Candle x y]+    _plot_candle_title           :: String,+    _plot_candle_line_style      :: LineStyle,+    _plot_candle_fill            :: Bool,+    _plot_candle_rise_fill_style :: FillStyle,+    _plot_candle_fall_fill_style :: FillStyle,+    _plot_candle_tick_length     :: Double,+    _plot_candle_width           :: Double,+    _plot_candle_centre          :: Double,+    _plot_candle_values          :: [Candle x y] }  -- | A Value holding price intervals for a given x-coord.@@ -65,18 +64,18 @@  instance ToPlot PlotCandle where     toPlot p = Plot {-        plot_render_     = renderPlotCandle p,-        plot_legend_     = [(plot_candle_title_ p, renderPlotLegendCandle p)],-        plot_all_points_ = ( map candle_x pts+        _plot_render     = renderPlotCandle p,+        _plot_legend     = [(_plot_candle_title p, renderPlotLegendCandle p)],+        _plot_all_points = ( map candle_x pts                            , concat [ [candle_low c, candle_high c]                                     | c <- pts ] )     }       where-        pts = plot_candle_values_ p+        pts = _plot_candle_values p -renderPlotCandle :: PlotCandle x y -> PointMapFn x y -> CRender ()-renderPlotCandle p pmap = preserveCState $ do-    mapM_ (drawCandle p . candlemap) (plot_candle_values_ p)+renderPlotCandle :: PlotCandle x y -> PointMapFn x y -> BackendProgram ()+renderPlotCandle p pmap =+    mapM_ (drawCandle p . candlemap) (_plot_candle_values p)   where     candlemap (Candle x lo op mid cl hi) =         Candle x' lo' op' mid' cl' hi'@@ -87,79 +86,66 @@               (Point _  hi')   = pmap' (x,hi)     pmap' = mapXY pmap +drawCandle :: PlotCandle x y -> Candle Double Double -> BackendProgram () drawCandle ps (Candle x lo open mid close hi) = do-        let tl = plot_candle_tick_length_ ps-        let wd = plot_candle_width_ ps-        let ct = plot_candle_centre_ ps-        let f  = plot_candle_fill_ ps+        let tl = _plot_candle_tick_length ps+        let wd = _plot_candle_width ps+        let ct = _plot_candle_centre ps+        let f  = _plot_candle_fill ps         -- the pixel coordinate system is inverted wrt the value coords.-        when f $ do setFillStyle (if open >= close-                                  then plot_candle_rise_fill_style_ ps-                                  else plot_candle_fall_fill_style_ ps)--                    c $ C.newPath-                    c $ C.moveTo (x-wd) open-                    c $ C.lineTo (x-wd) close-                    c $ C.lineTo (x+wd) close-                    c $ C.lineTo (x+wd) open-                    c $ C.lineTo (x-wd) open-                    c $ C.fill+        when f $ withFillStyle (if open >= close+                                   then _plot_candle_rise_fill_style ps+                                   else _plot_candle_fall_fill_style ps) $+                    fillPath $ moveTo' (x-wd) open+                            <> lineTo' (x-wd) close+                            <> lineTo' (x+wd) close+                            <> lineTo' (x+wd) open+                            <> lineTo' (x-wd) open -        setLineStyle (plot_candle_line_style_ ps)-        c $ C.newPath-        c $ C.moveTo (x-wd) open-        c $ C.lineTo (x-wd) close-        c $ C.lineTo (x+wd) close-        c $ C.lineTo (x+wd) open-        c $ C.lineTo (x-wd) open-        c $ C.stroke+        withLineStyle (_plot_candle_line_style ps) $ do+          strokePath $ moveTo' (x-wd) open+                    <> lineTo' (x-wd) close+                    <> lineTo' (x+wd) close+                    <> lineTo' (x+wd) open+                    <> lineTo' (x-wd) open -        c $ C.newPath-        c $ C.moveTo x (min lo hi)-        c $ C.lineTo x (min open close)-        c $ C.moveTo x (max open close)-        c $ C.lineTo x (max hi lo)-        c $ C.stroke+          strokePath $ moveTo' x (min lo hi)+                    <> lineTo' x (min open close)+                    <> moveTo' x (max open close)+                    <> lineTo' x (max hi lo) -        when (tl > 0) $ do c $ C.newPath-                           c $ C.moveTo (x-tl) lo-                           c $ C.lineTo (x+tl) lo-                           c $ C.moveTo (x-tl) hi-                           c $ C.lineTo (x+tl) hi-                           c $ C.stroke+          when (tl > 0) $ strokePath $ moveTo' (x-tl) lo+                                    <> lineTo' (x+tl) lo+                                    <> moveTo' (x-tl) hi+                                    <> lineTo' (x+tl) hi -        when (ct > 0) $ do c $ C.moveTo (x-ct) mid-                           c $ C.lineTo (x+ct) mid-                           c $ C.stroke+          when (ct > 0) $ strokePath $ moveTo' (x-ct) mid+                                    <> lineTo' (x+ct) mid -renderPlotLegendCandle :: PlotCandle x y -> Rect -> CRender ()-renderPlotLegendCandle p r@(Rect p1 p2) = preserveCState $ 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)+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 -defaultPlotCandle :: PlotCandle x y-defaultPlotCandle = PlotCandle {-    plot_candle_title_       = "",-    plot_candle_line_style_  = solidLine 1 $ opaque blue,-    plot_candle_fill_        = False,-    plot_candle_rise_fill_style_  = solidFillStyle $ opaque white,-    plot_candle_fall_fill_style_  = solidFillStyle $ opaque blue,-    plot_candle_tick_length_ = 2,-    plot_candle_width_       = 5,-    plot_candle_centre_      = 0,-    plot_candle_values_      = []-}--------------------------------------------------------------------------- Template haskell to derive an instance of Data.Accessor.Accessor--- for each field.+instance Default (PlotCandle x y) where+  def = PlotCandle+    { _plot_candle_title       = ""+    , _plot_candle_line_style  = solidLine 1 $ opaque blue+    , _plot_candle_fill        = False+    , _plot_candle_rise_fill_style  = solidFillStyle $ opaque white+    , _plot_candle_fall_fill_style  = solidFillStyle $ opaque blue+    , _plot_candle_tick_length = 2+    , _plot_candle_width       = 5+    , _plot_candle_centre      = 0+    , _plot_candle_values      = []+    } -$( deriveAccessors ''PlotCandle )+$( makeLenses ''PlotCandle )
Graphics/Rendering/Chart/Plot/ErrBars.hs view
@@ -1,16 +1,15 @@ ----------------------------------------------------------------------------- -- | -- 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. ---{-# OPTIONS_GHC -XTemplateHaskell #-}+{-# LANGUAGE TemplateHaskell #-}  module Graphics.Rendering.Chart.Plot.ErrBars(     PlotErrBars(..),-    defaultPlotErrBars,     ErrPoint(..),     ErrValue(..),     symErrPoint,@@ -25,14 +24,14 @@     plot_errbars_values, ) where -import Data.Accessor.Template-import qualified Graphics.Rendering.Cairo as C-import Graphics.Rendering.Chart.Types-import Graphics.Rendering.Chart.Renderable+import Control.Lens++import Graphics.Rendering.Chart.Geometry+import Graphics.Rendering.Chart.Drawing import Graphics.Rendering.Chart.Plot.Types import Data.Colour (opaque)-import Data.Colour.Names (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. @@ -55,29 +54,29 @@ -- | Value defining a series of error intervals, and a style in --   which to render them. data PlotErrBars x y = PlotErrBars {-    plot_errbars_title_       :: String,-    plot_errbars_line_style_  :: CairoLineStyle,-    plot_errbars_tick_length_ :: Double,-    plot_errbars_overhang_    :: Double,-    plot_errbars_values_      :: [ErrPoint x y]+    _plot_errbars_title       :: String,+    _plot_errbars_line_style  :: LineStyle,+    _plot_errbars_tick_length :: Double,+    _plot_errbars_overhang    :: Double,+    _plot_errbars_values      :: [ErrPoint x y] }   instance ToPlot PlotErrBars where     toPlot p = Plot {-        plot_render_     = renderPlotErrBars p,-        plot_legend_     = [(plot_errbars_title_ p, renderPlotLegendErrBars p)],-        plot_all_points_ = ( concat [ [ev_low x,ev_high x]+        _plot_render     = renderPlotErrBars p,+        _plot_legend     = [(_plot_errbars_title p, renderPlotLegendErrBars p)],+        _plot_all_points = ( concat [ [ev_low x,ev_high x]                                     | ErrPoint x _ <- pts ]                            , concat [ [ev_low y,ev_high y]                                     | ErrPoint _ y <- pts ] )     }       where-        pts = plot_errbars_values_ p+        pts = _plot_errbars_values p -renderPlotErrBars :: PlotErrBars x y -> PointMapFn x y -> CRender ()-renderPlotErrBars p pmap = preserveCState $ do-    mapM_ (drawErrBar.epmap) (plot_errbars_values_ p)+renderPlotErrBars :: PlotErrBars x y -> PointMapFn x y -> BackendProgram ()+renderPlotErrBars p pmap =+    mapM_ (drawErrBar.epmap) (_plot_errbars_values p)   where     epmap (ErrPoint (ErrValue xl x xh) (ErrValue yl y yh)) =         ErrPoint (ErrValue xl' x' xh') (ErrValue yl' y' yh')@@ -87,46 +86,42 @@     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-        setLineStyle (plot_errbars_line_style_ ps)-        c $ C.newPath-        c $ C.moveTo (xl-oh) y-        c $ C.lineTo (xh+oh) y-        c $ C.moveTo x (yl-oh)-        c $ C.lineTo x (yh+oh)-        c $ C.moveTo xl (y-tl)-        c $ C.lineTo xl (y+tl)-        c $ C.moveTo (x-tl) yl-        c $ C.lineTo (x+tl) yl-        c $ C.moveTo xh (y-tl)-        c $ C.lineTo xh (y+tl)-        c $ C.moveTo (x-tl) yh-        c $ C.lineTo (x+tl) yh-	c $ C.stroke+        let tl = _plot_errbars_tick_length ps+        let oh = _plot_errbars_overhang ps+        withLineStyle (_plot_errbars_line_style ps) $+          strokePath $ moveTo' (xl-oh) y+                    <> lineTo' (xh+oh) y+                    <> moveTo' x (yl-oh)+                    <> lineTo' x (yh+oh)+                    <> moveTo' xl (y-tl)+                    <> lineTo' xl (y+tl)+                    <> moveTo' (x-tl) yl+                    <> lineTo' (x+tl) yl+                    <> moveTo' xh (y-tl)+                    <> lineTo' xh (y+tl)+                    <> moveTo' (x-tl) yh+                    <> lineTo' (x+tl) yh -renderPlotLegendErrBars :: PlotErrBars x y -> Rect -> CRender ()-renderPlotLegendErrBars p r@(Rect p1 p2) = preserveCState $ do-    drawErrBar (symErrPoint (p_x p1)              ((p_y p1 + p_y p2)/2) dx dx)-    drawErrBar (symErrPoint ((p_x p1 + p_x p2)/2) ((p_y p1 + p_y p2)/2) dx dx)-    drawErrBar (symErrPoint (p_x p2)              ((p_y p1 + p_y p2)/2) dx dx)+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)--defaultPlotErrBars :: PlotErrBars x y-defaultPlotErrBars = PlotErrBars {-    plot_errbars_title_       = "",-    plot_errbars_line_style_  = solidLine 1 $ opaque blue,-    plot_errbars_tick_length_ = 3,-    plot_errbars_overhang_    = 0,-    plot_errbars_values_      = []-}+    y          = (p_y p1 + p_y p2)/2 -------------------------------------------------------------------------- Template haskell to derive an instance of Data.Accessor.Accessor--- for each field.+instance Default (PlotErrBars x y) where+  def = PlotErrBars+    { _plot_errbars_title       = ""+    , _plot_errbars_line_style  = solidLine 1 $ opaque blue+    , _plot_errbars_tick_length = 3+    , _plot_errbars_overhang    = 0+    , _plot_errbars_values      = []+    } -$( deriveAccessors ''PlotErrBars )+$( makeLenses ''PlotErrBars )
Graphics/Rendering/Chart/Plot/FillBetween.hs view
@@ -1,84 +1,89 @@ ----------------------------------------------------------------------------- -- | -- 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. ---{-# OPTIONS_GHC -XTemplateHaskell #-}+{-# LANGUAGE TemplateHaskell #-}  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 Data.Accessor.Template-import qualified Graphics.Rendering.Cairo as C-import Graphics.Rendering.Chart.Types-import Graphics.Rendering.Chart.Renderable+import Control.Lens+import Graphics.Rendering.Chart.Geometry+import Graphics.Rendering.Chart.Drawing import Graphics.Rendering.Chart.Plot.Types import Data.Colour (opaque)-import Data.Colour.Names (black, blue) import Data.Colour.SRGB (sRGB)+import Data.Default.Class  -- | Value specifying a plot filling the area between two sets of Y --   coordinates, given common X coordinates.  data PlotFillBetween x y = PlotFillBetween {-    plot_fillbetween_title_  :: String,-    plot_fillbetween_style_  :: CairoFillStyle,-    plot_fillbetween_values_ :: [ (x, (y,y))]+    _plot_fillbetween_title  :: String,+    _plot_fillbetween_style  :: FillStyle,+    _plot_fillbetween_line  :: Maybe LineStyle,+    _plot_fillbetween_values :: [ (x, (y,y))] }   instance ToPlot PlotFillBetween where     toPlot p = Plot {-        plot_render_     = renderPlotFillBetween p,-        plot_legend_     = [(plot_fillbetween_title_ p,renderPlotLegendFill p)],-        plot_all_points_ = plotAllPointsFillBetween p+        _plot_render     = renderPlotFillBetween p,+        _plot_legend     = [(_plot_fillbetween_title p,renderPlotLegendFill p)],+        _plot_all_points = plotAllPointsFillBetween p     } -renderPlotFillBetween :: PlotFillBetween x y -> PointMapFn x y -> CRender ()-renderPlotFillBetween p pmap =-    renderPlotFillBetween' p (plot_fillbetween_values_ p) pmap+renderPlotFillBetween :: PlotFillBetween x y -> PointMapFn x y -> BackendProgram ()+renderPlotFillBetween p =+    renderPlotFillBetween' p (_plot_fillbetween_values p) -renderPlotFillBetween' p [] _     = return ()-renderPlotFillBetween' p vs pmap  = preserveCState $ do-    setFillStyle (plot_fillbetween_style_ p)-    fillPath ([p0] ++ p1s ++ reverse p2s ++ [p0])+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 -> CRender ()-renderPlotLegendFill p r = preserveCState $ do-    setFillStyle (plot_fillbetween_style_ p)+renderPlotLegendFill :: PlotFillBetween x y -> Rect -> BackendProgram ()+renderPlotLegendFill p r = +  withFillStyle (_plot_fillbetween_style p) $      fillPath (rectPath r)  plotAllPointsFillBetween :: PlotFillBetween x y -> ([x],[y]) plotAllPointsFillBetween p = ( [ x | (x,(_,_)) <- pts ]                              , concat [ [y1,y2] | (_,(y1,y2)) <- pts ] )   where-    pts = plot_fillbetween_values_ p---defaultPlotFillBetween :: PlotFillBetween x y-defaultPlotFillBetween = PlotFillBetween {-    plot_fillbetween_title_  = "",-    plot_fillbetween_style_  = solidFillStyle (opaque $ sRGB 0.5 0.5 1.0),-    plot_fillbetween_values_ = []-}+    pts = _plot_fillbetween_values p -------------------------------------------------------------------------- Template haskell to derive an instance of Data.Accessor.Accessor--- for each field.+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 = []+    } -$( deriveAccessors ''PlotFillBetween )+$( makeLenses ''PlotFillBetween )
Graphics/Rendering/Chart/Plot/Hidden.hs view
@@ -1,41 +1,36 @@ ----------------------------------------------------------------------------- -- | -- 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 -- scaling ---{-# OPTIONS_GHC -XTemplateHaskell #-}+{-# LANGUAGE TemplateHaskell #-}  module Graphics.Rendering.Chart.Plot.Hidden(     PlotHidden(..),+    +    plot_hidden_x_values,+    plot_hidden_y_values ) where -import Data.Accessor.Template-import qualified Graphics.Rendering.Cairo as C-import Graphics.Rendering.Chart.Types-import Graphics.Rendering.Chart.Renderable+import Control.Lens 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]+    _plot_hidden_x_values :: [x],+    _plot_hidden_y_values :: [y] }  instance ToPlot PlotHidden where     toPlot ph = Plot {-        plot_render_     = \_ -> return (),-        plot_legend_     = [],-        plot_all_points_ = (plot_hidden_x_values_ ph, plot_hidden_y_values_ ph)+        _plot_render     = \_ -> return (),+        _plot_legend     = [],+        _plot_all_points = (_plot_hidden_x_values ph, _plot_hidden_y_values ph)     } -------------------------------------------------------------------------- Template haskell to derive an instance of Data.Accessor.Accessor--- for each field.--$( deriveAccessors ''PlotHidden )-+$( makeLenses ''PlotHidden )
+ Graphics/Rendering/Chart/Plot/Histogram.hs view
@@ -0,0 +1,188 @@+{-# LANGUAGE TemplateHaskell, FlexibleInstances #-}++module Graphics.Rendering.Chart.Plot.Histogram+  ( -- * Histograms+    PlotHist (..)+  , histToPlot+  , defaultPlotHist+  , defaultFloatPlotHist+  , defaultNormedPlotHist+  , histToBins+    -- * Accessors+  , plot_hist_title+  , plot_hist_bins+  , plot_hist_values+  , plot_hist_no_zeros+  , plot_hist_range+  , plot_hist_drop_lines+  , plot_hist_line_style+  , plot_hist_fill_style+  , plot_hist_norm_func+  ) where++import Control.Monad (when)+import Data.Maybe (fromMaybe)+import qualified Data.Foldable as F+import qualified Data.Vector as V++import Control.Lens+import Graphics.Rendering.Chart.Plot.Types+import Graphics.Rendering.Chart.Geometry+import Graphics.Rendering.Chart.Drawing+import Data.Default.Class++import Data.Colour (opaque)+import Data.Colour.Names (blue)+import Data.Colour.SRGB (sRGB)++import Numeric.Histogram++data PlotHist x y = PlotHist+    { -- | Plot title+      _plot_hist_title                :: String++      -- | Number of bins+    , _plot_hist_bins                 :: Int++      -- | Values to histogram+    , _plot_hist_values               :: [x]++      -- | Don't attempt to plot bins with zero counts. Useful when+      -- the y-axis is logarithmically scaled.+    , _plot_hist_no_zeros             :: Bool++      -- | Override the range of the histogram. If @Nothing@ the+      -- range of @_plot_hist_values@ is used.+      --+      -- Note that any normalization is always computed over the full+      -- data set, including samples not falling in the histogram range.+    , _plot_hist_range                :: Maybe (x,x)++      -- | Plot vertical lines between bins+    , _plot_hist_drop_lines           :: Bool++      -- | Fill style of the bins+    , _plot_hist_fill_style           :: FillStyle++      -- | Line style of the bin outlines+    , _plot_hist_line_style           :: LineStyle++      -- | Normalization function+    , _plot_hist_norm_func            :: Double -> Int -> y+    }++instance Default (PlotHist x Int) where+    def = defaultPlotHist++-- | The default style is an unnormalized histogram of 20 bins.+defaultPlotHist :: PlotHist x Int+defaultPlotHist = PlotHist { _plot_hist_bins        = 20+                           , _plot_hist_title       = ""+                           , _plot_hist_values      = []+                           , _plot_hist_no_zeros    = False+                           , _plot_hist_range       = Nothing+                           , _plot_hist_drop_lines  = False+                           , _plot_hist_line_style  = defaultLineStyle+                           , _plot_hist_fill_style  = defaultFillStyle+                           , _plot_hist_norm_func   = const id+                           }++-- | @defaultPlotHist@ but with real counts+defaultFloatPlotHist :: PlotHist x Double+defaultFloatPlotHist = defaultPlotHist { _plot_hist_norm_func = const realToFrac }++-- | @defaultPlotHist@ but normalized such that the integral of the+-- histogram is one.+defaultNormedPlotHist :: PlotHist x Double+defaultNormedPlotHist = defaultPlotHist { _plot_hist_norm_func = \n y->realToFrac y / n }++defaultFillStyle :: FillStyle+defaultFillStyle = solidFillStyle (opaque $ sRGB 0.5 0.5 1.0)++defaultLineStyle :: LineStyle+defaultLineStyle = (solidLine 1 $ opaque blue)+     { _line_cap  = LineCapButt+     , _line_join = LineJoinMiter+     }++-- | Convert a @PlotHist@ to a @Plot@+--+-- N.B. In principle this should be Chart's @ToPlot@ class but unfortunately+-- this does not allow us to set bounds on the x and y axis types, hence+-- the need for this function.+histToPlot :: (RealFrac x, Num y, Ord y) => PlotHist x y -> Plot x y+histToPlot p = Plot {+        _plot_render      = renderPlotHist p,+        _plot_legend      = [(_plot_hist_title p, renderPlotLegendHist p)],+        _plot_all_points  = unzip+                            $ concatMap (\((x1,x2), y)->[ (x1,y)+                                                        , (x2,y)+                                                        , (x1,0)+                                                        , (x2,0)+                                                        ])+                            $ histToBins p+    }++buildHistPath :: (RealFrac x, Num y)+              => PointMapFn x y -> [((x,x), y)] -> Path+buildHistPath _ [] = End+buildHistPath pmap bins = MoveTo (pt xb 0) (go bins)+    where go [((x1,x2),y)]      = LineTo (pt x1 y)+                                $ LineTo (pt x2 y)+                                $ LineTo (pt x2 0)+                                $ End+          go (((x1,x2),y):rest) = LineTo (pt x1 y)+                                $ LineTo (pt x2 y)+                                $ go rest+          go []                 = End+          ((xb,_),_) = head bins+          pt x y = pmap (LValue x, LValue y)++renderPlotHist :: (RealFrac x, Num y, Ord y)+               => PlotHist x y -> PointMapFn x y -> BackendProgram ()+renderPlotHist p pmap+    | null bins = return ()+    | otherwise = do+        withFillStyle (_plot_hist_fill_style p) $+            alignFillPath (buildHistPath pmap bins) >>= fillPath+        withLineStyle (_plot_hist_line_style p) $ do+            when (_plot_hist_drop_lines p) $+                alignStrokePath dropLinesPath >>= strokePath+            alignStrokePath (buildHistPath pmap bins) >>= strokePath+    where bins = histToBins p+          pt x y = pmap (LValue x, LValue y)+          dropLinesPath = F.foldMap (\((x1,_), y)->moveTo (pt x1 0)+                                                <> lineTo (pt x1 y)+                                    ) $ tail bins++renderPlotLegendHist :: PlotHist x y -> Rect -> BackendProgram ()+renderPlotLegendHist p (Rect p1 p2) =+    withLineStyle (_plot_hist_line_style p) $+        let y = (p_y p1 + p_y p2) / 2+        in strokePath $ moveTo' (p_x p1) y <> lineTo' (p_x p2) y++-- | Obtain the bin dimensions of a given @PlotHist@.+histToBins :: (RealFrac x, Num y, Ord y) => PlotHist x y -> [((x,x), y)]+histToBins hist =+    filter_zeros $ zip bounds $ counts+    where n = _plot_hist_bins hist+          (a,b) = realHistRange hist+          dx = realToFrac (b-a) / realToFrac n+          bounds = binBounds a b n+          values = V.fromList (_plot_hist_values hist)+          filter_zeros | _plot_hist_no_zeros hist  = filter (\(_,c)->c > 0)+                       | otherwise                 = id+          norm = dx * realToFrac (V.length values)+          normalize = _plot_hist_norm_func hist norm+          counts = V.toList $ V.map (normalize . snd)+                   $ histWithBins (V.fromList bounds)+                   $ zip (repeat 1) (V.toList values)++realHistRange :: (RealFrac x) => PlotHist x y -> (x,x)+realHistRange hist = fromMaybe range $ _plot_hist_range hist+    where values = V.fromList (_plot_hist_values hist)+          range = if V.null values+                    then (0,0)+                    else (V.minimum values, V.maximum values)++$( makeLenses ''PlotHist )
Graphics/Rendering/Chart/Plot/Lines.hs view
@@ -1,16 +1,15 @@ ----------------------------------------------------------------------------- -- | -- 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 ---{-# OPTIONS_GHC -XTemplateHaskell #-}+{-# LANGUAGE TemplateHaskell #-}  module Graphics.Rendering.Chart.Plot.Lines(     PlotLines(..),-    defaultPlotLines,     defaultPlotLineStyle,     hlinePlot,     vlinePlot,@@ -21,89 +20,83 @@     plot_lines_limit_values, ) where -import Data.Accessor.Template-import qualified Graphics.Rendering.Cairo as C-import Graphics.Rendering.Chart.Types-import Graphics.Rendering.Chart.Renderable+import Control.Lens+import Graphics.Rendering.Chart.Geometry+import Graphics.Rendering.Chart.Drawing import Graphics.Rendering.Chart.Plot.Types import Data.Colour (opaque)-import Data.Colour.Names (black, blue)+import Data.Colour.Names (blue)+import Data.Default.Class  -- | Value defining a series of (possibly disjointed) lines, --   and a style in which to render them. data PlotLines x y = PlotLines {-    plot_lines_title_        :: String,-    plot_lines_style_        :: CairoLineStyle,+    _plot_lines_title        :: String,+    _plot_lines_style        :: LineStyle,      -- | The lines to be plotted-    plot_lines_values_       :: [[(x,y)]],+    _plot_lines_values       :: [[(x,y)]],      -- | Additional lines to be plotted, specified using     -- the Limit type to allow referencing the edges of     -- the plot area.-    plot_lines_limit_values_ :: [[(Limit x, Limit y)]]+    _plot_lines_limit_values :: [[(Limit x, Limit y)]] }  instance ToPlot PlotLines where     toPlot p = Plot {-        plot_render_     = renderPlotLines p,-        plot_legend_     = [(plot_lines_title_ p, renderPlotLegendLines p)],-        plot_all_points_ = ( map fst pts ++ xs, map snd pts ++ ys )+        _plot_render     = renderPlotLines p,+        _plot_legend     = [(_plot_lines_title p, renderPlotLegendLines p)],+        _plot_all_points = ( map fst pts ++ xs, map snd pts ++ ys )     }       where-        pts = concat (plot_lines_values_ p)-        xs = [ x | (LValue x,_) <- concat (plot_lines_limit_values_ p)]-        ys = [ y | (_,LValue y) <- concat (plot_lines_limit_values_ p)]+        pts = concat (_plot_lines_values p)+        xs = [ x | (LValue x,_) <- concat (_plot_lines_limit_values p)]+        ys = [ y | (_,LValue y) <- concat (_plot_lines_limit_values p)] -renderPlotLines :: PlotLines x y -> PointMapFn x y -> CRender ()-renderPlotLines p pmap = preserveCState $ do-    setLineStyle (plot_lines_style_ p)-    mapM_ (drawLines (mapXY pmap)) (plot_lines_values_ p)-    mapM_ (drawLines pmap) (plot_lines_limit_values_ p)+renderPlotLines :: PlotLines x y -> PointMapFn x y -> BackendProgram ()+renderPlotLines p pmap = +  withLineStyle (_plot_lines_style p) $ do+    mapM_ (drawLines (mapXY pmap)) (_plot_lines_values p)+    mapM_ (drawLines pmap) (_plot_lines_limit_values p)   where-    drawLines mapfn pts = strokePath (map mapfn pts)+    drawLines mapfn pts = alignStrokePoints (map mapfn pts) >>= strokePointPath  -renderPlotLegendLines :: PlotLines x y -> Rect -> CRender ()-renderPlotLegendLines p r@(Rect p1 p2) = preserveCState $ do-    setLineStyle (plot_lines_style_ p)+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-    strokePath [Point (p_x p1) y, Point (p_x p2) y]+    ps <- alignStrokePoints [Point (p_x p1) y, Point (p_x p2) y]+    strokePointPath ps -defaultPlotLineStyle :: CairoLineStyle+defaultPlotLineStyle :: LineStyle defaultPlotLineStyle = (solidLine 1 $ opaque blue){-     line_cap_  = C.LineCapRound,-     line_join_ = C.LineJoinRound+     _line_cap  = LineCapRound,+     _line_join = LineJoinRound  } -defaultPlotLines :: PlotLines x y-defaultPlotLines = PlotLines {-    plot_lines_title_        = "",-    plot_lines_style_        = defaultPlotLineStyle,-    plot_lines_values_       = [],-    plot_lines_limit_values_ = []-}+instance Default (PlotLines x y) where+  def = PlotLines +    { _plot_lines_title        = ""+    , _plot_lines_style        = defaultPlotLineStyle+    , _plot_lines_values       = []+    , _plot_lines_limit_values = []+    }  -- | Helper function to plot a single horizontal line.-hlinePlot :: String -> CairoLineStyle -> b -> Plot a b-hlinePlot t ls v = toPlot defaultPlotLines {-    plot_lines_title_        = t,-    plot_lines_style_        = ls,-    plot_lines_limit_values_ = [[(LMin, LValue v),(LMax, LValue v)]]+hlinePlot :: String -> LineStyle -> b -> Plot a b+hlinePlot t ls v = toPlot def {+    _plot_lines_title        = t,+    _plot_lines_style        = ls,+    _plot_lines_limit_values = [[(LMin, LValue v),(LMax, LValue v)]]     }  -- | Helper function to plot a single vertical line.-vlinePlot :: String -> CairoLineStyle -> a -> Plot a b-vlinePlot t ls v = toPlot defaultPlotLines {-    plot_lines_title_        = t,-    plot_lines_style_        = ls,-    plot_lines_limit_values_ = [[(LValue v,LMin),(LValue v,LMax)]]+vlinePlot :: String -> LineStyle -> a -> Plot a b+vlinePlot t ls v = toPlot def {+    _plot_lines_title        = t,+    _plot_lines_style        = ls,+    _plot_lines_limit_values = [[(LValue v,LMin),(LValue v,LMax)]]     } -------------------------------------------------------------------------- Template haskell to derive an instance of Data.Accessor.Accessor--- for each field.-$( deriveAccessors ''PlotLines )----+$( makeLenses ''PlotLines )
Graphics/Rendering/Chart/Plot/Pie.hs view
@@ -1,224 +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
--- @
-
-{-# OPTIONS_GHC -XTemplateHaskell #-}
-
-module Graphics.Rendering.Chart.Plot.Pie(
-    PieLayout(..),
-    PieChart(..),
-    PieItem(..),
-    defaultPieLayout,
-    defaultPieChart,
-    defaultPieItem,
-
-    pie_title,
-    pie_title_style,
-    pie_plot,
-    pie_background,
-    pie_margin,
-    pie_data,
-    pie_colors,
-    pie_label_style,
-    pie_label_line_style,
-    pie_start_angle,
-    pitem_label,
-    pitem_offset,
-    pitem_value,
-
-) where
--- original code thanks to Neal Alexander
-
-import qualified Graphics.Rendering.Cairo as C
-
-import Data.List
-import Data.Bits
-import Data.Accessor.Template
-import Data.Colour
-import Data.Colour.Names (black, white)
-import Control.Monad
-
-import Graphics.Rendering.Chart.Types
-import Graphics.Rendering.Chart.Legend
-import Graphics.Rendering.Chart.Renderable
-import Graphics.Rendering.Chart.Grid
-import Graphics.Rendering.Chart.Plot.Types
-
-data PieLayout = PieLayout {
-   pie_title_       :: String,
-   pie_title_style_ :: CairoFontStyle,
-   pie_plot_        :: PieChart,
-   pie_background_  :: CairoFillStyle,
-   pie_margin_      :: Double
-}
-
-data PieChart = PieChart {
-   pie_data_             :: [PieItem],
-   pie_colors_           :: [AlphaColour Double],
-   pie_label_style_      :: CairoFontStyle,
-   pie_label_line_style_ :: CairoLineStyle, 
-   pie_start_angle_      :: Double
-
-}
-
-data PieItem = PieItem {
-   pitem_label_  :: String,
-   pitem_offset_ :: Double,
-   pitem_value_  :: Double
-}
-
-defaultPieChart :: PieChart
-defaultPieChart = PieChart {
-    pie_data_             = [], 
-    pie_colors_           = defaultColorSeq,
-    pie_label_style_      = defaultFontStyle,
-    pie_label_line_style_ = solidLine 1 $ opaque black,
-    pie_start_angle_      = 0
-}
-
-defaultPieItem :: PieItem
-defaultPieItem = PieItem "" 0 0
-
-defaultPieLayout :: PieLayout
-defaultPieLayout = PieLayout {
-    pie_background_  = solidFillStyle $ opaque white,
-    pie_title_       = "",
-    pie_title_style_ = defaultFontStyle{ font_size_   = 15
-                                       , font_weight_ = C.FontWeightBold },
-    pie_plot_        = defaultPieChart,
-    pie_margin_      = 10
-}
-
-instance ToRenderable PieLayout where
-    toRenderable p = fillBackground (pie_background_ p) (
-       gridToRenderable $ aboveN
-         [ tval $ addMargins (lm/2,0,0,0) (setPickFn nullPickFn title)
-         , weights (1,1) $ tval $ addMargins (lm,lm,lm,lm)
-                                             (toRenderable $ pie_plot_ p)
-         ] )
-      where
-        title = label (pie_title_style_ p) HTA_Centre VTA_Top (pie_title_ p)
-        lm    = pie_margin_ p
-
-instance ToRenderable PieChart where
-    toRenderable p = Renderable {
-      minsize = minsizePie p,
-      render  = renderPie p
-    }
-
-extraSpace p = do
-    textSizes <- mapM textSize (map pitem_label_ (pie_data_ p))
-    let maxw  = foldr (max.fst) 0 textSizes
-    let maxh  = foldr (max.snd) 0 textSizes
-    let maxo  = foldr (max.pitem_offset_) 0 (pie_data_ p)
-    let extra = label_rgap + label_rlength + maxo
-    return (extra + maxw, extra + maxh )
-
-minsizePie p = do
-    (extraw,extrah) <- extraSpace p
-    return (extraw * 2, extrah * 2)
-
-renderPie p (w,h) = do
-    (extraw,extrah) <- extraSpace p
-    let (w,h)  = (p_x p2 - p_x p1, p_y p2 - p_y p1)
-    let center = Point (p_x p1 + w/2)  (p_y p1 + h/2)
-    let radius = (min (w - 2*extraw) (h - 2*extrah)) / 2
-
-    foldM_ (paint center radius) (pie_start_angle_ p)
-           (zip (pie_colors_ p) content)
-    return nullPickFn
- 
-    where
-        p1 = Point 0 0 
-        p2 = Point w h 
-        content = let total = sum (map pitem_value_ (pie_data_ p))
-                  in [ pi{pitem_value_=pitem_value_ pi/total}
-                     | pi <- pie_data_ p ]
-
-        paint :: Point -> Double -> Double -> (AlphaColour Double, PieItem)
-                 -> CRender Double
-        paint center radius a1 (color,pitem) = do
-            let ax     = 360.0 * (pitem_value_ pitem)
-            let a2     = a1 + (ax / 2)
-            let a3     = a1 + ax
-            let offset = pitem_offset_ pitem
-
-            pieSlice (ray a2 offset) a1 a3 color
-            pieLabel (pitem_label_ pitem) a2 offset
-
-            return a3
-
-            where
-                pieLabel :: String -> Double -> Double -> CRender ()
-                pieLabel name angle offset = do
-                    setFontStyle (pie_label_style_ p)
-                    setLineStyle (pie_label_line_style_ p)
-
-                    moveTo (ray angle (radius + label_rgap+offset))
-                    let p1 = ray angle (radius+label_rgap+label_rlength+offset)
-                    lineTo p1
-                    (tw,th) <- textSize name
-                    let (offset,anchor) = if angle < 90 || angle > 270 
-                                          then ((0+),HTA_Left)
-                                          else ((0-),HTA_Right)
-                    c $ C.relLineTo (offset (tw + label_rgap)) 0
-                    c $ C.stroke
-
-                    let p2 = p1 `pvadd` (Vector (offset label_rgap) 0)
-                    drawText anchor VTA_Bottom p2 name
-
-                pieSlice :: Point -> Double -> Double -> AlphaColour Double
-                            -> CRender ()
-                pieSlice (Point x y) a1 a2 color = c $ do
-                    C.newPath
-                    C.arc x y radius (radian a1) (radian a2)
-                    C.lineTo x y
-                    C.lineTo x y
-                    C.closePath
-
-                    setSourceColor color
-                    C.fillPreserve
-                    C.setSourceRGBA 1 1 1 0.1
-
-                    C.stroke
-
-                ray :: Double -> Double -> Point
-                ray angle r = Point x' y'
-                  where
-                    x'   = x + (cos' * x'')
-                    y'   = y + (sin' * x'')
-                    cos' = (cos . radian) angle
-                    sin' = (sin . radian) angle
-                    x''  = ((x + r) - x)
-                    x    = p_x center
-                    y    = p_y center
-
-                radian = (*(pi / 180.0))
-
-
-label_rgap = 5
-label_rlength = 15
-
-----------------------------------------------------------------------
--- Template haskell to derive an instance of Data.Accessor.Accessor
--- for each field.
-$( deriveAccessors ''PieLayout )
-$( deriveAccessors ''PieChart )
-$( deriveAccessors ''PieItem )
+-----------------------------------------------------------------------------+-- |+-- 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,16 +1,15 @@ ----------------------------------------------------------------------------- -- | -- 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. -{-# OPTIONS_GHC -XTemplateHaskell #-}+{-# LANGUAGE TemplateHaskell #-}  module Graphics.Rendering.Chart.Plot.Points(     PlotPoints(..),-    defaultPlotPoints,      -- * Accessors     -- | These accessors are generated by template haskell@@ -20,56 +19,51 @@     plot_points_values, ) where     -import Data.Accessor.Template-import qualified Graphics.Rendering.Cairo as C-import Graphics.Rendering.Chart.Types-import Graphics.Rendering.Chart.Renderable+import Control.Lens+import Graphics.Rendering.Chart.Geometry+import Graphics.Rendering.Chart.Drawing import Graphics.Rendering.Chart.Plot.Types-import Data.Colour (opaque)-import Data.Colour.Names (black, blue)+import Data.Default.Class  -- | Value defining a series of datapoints, and a style in --   which to render them. data PlotPoints x y = PlotPoints {-    plot_points_title_  :: String,-    plot_points_style_  :: CairoPointStyle,-    plot_points_values_ :: [(x,y)]+    _plot_points_title  :: String,+    _plot_points_style  :: PointStyle,+    _plot_points_values :: [(x,y)] }  instance ToPlot PlotPoints where     toPlot p = Plot {-        plot_render_     = renderPlotPoints p,-        plot_legend_     = [(plot_points_title_ p, renderPlotLegendPoints p)],-        plot_all_points_ = (map fst pts, map snd pts)+        _plot_render     = renderPlotPoints p,+        _plot_legend     = [(_plot_points_title p, renderPlotLegendPoints p)],+        _plot_all_points = (map fst pts, map snd pts)     }       where-        pts = plot_points_values_ p+        pts = _plot_points_values p -renderPlotPoints :: PlotPoints x y -> PointMapFn x y -> CRender ()-renderPlotPoints p pmap = preserveCState $ do-    mapM_ (drawPoint.pmap') (plot_points_values_ p)+renderPlotPoints :: PlotPoints x y -> PointMapFn x y -> BackendProgram ()+renderPlotPoints p pmap = +    mapM_ (drawPoint ps . pmap') (_plot_points_values p)   where     pmap' = mapXY pmap-    (CairoPointStyle drawPoint) = (plot_points_style_ p)+    ps = _plot_points_style p -renderPlotLegendPoints :: PlotPoints x y -> Rect -> CRender ()-renderPlotLegendPoints p r@(Rect p1 p2) = preserveCState $ do-    drawPoint (Point (p_x p1)              ((p_y p1 + p_y p2)/2))-    drawPoint (Point ((p_x p1 + p_x p2)/2) ((p_y p1 + p_y p2)/2))-    drawPoint (Point (p_x p2)              ((p_y p1 + p_y p2)/2))+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-    (CairoPointStyle drawPoint) = (plot_points_style_ p)--defaultPlotPoints :: PlotPoints x y-defaultPlotPoints = PlotPoints {-    plot_points_title_  = "",-    plot_points_style_  = defaultPointStyle,-    plot_points_values_ = []-}+    ps = _plot_points_style p+    y = (p_y p1 + p_y p2)/2 -------------------------------------------------------------------------- Template haskell to derive an instance of Data.Accessor.Accessor--- for each field.+instance Default (PlotPoints x y) where+  def = PlotPoints +    { _plot_points_title  = ""+    , _plot_points_style  = def+    , _plot_points_values = []+    } -$( deriveAccessors ''PlotPoints )+$( makeLenses ''PlotPoints )
Graphics/Rendering/Chart/Plot/Types.hs view
@@ -1,13 +1,13 @@ ----------------------------------------------------------------------------- -- | -- 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 -- plot types. ---{-# OPTIONS_GHC -XTemplateHaskell #-}+{-# LANGUAGE TemplateHaskell #-}  module Graphics.Rendering.Chart.Plot.Types(     Plot(..),@@ -22,53 +22,52 @@      ) where -import qualified Graphics.Rendering.Cairo as C-import Graphics.Rendering.Chart.Types-import Graphics.Rendering.Chart.Renderable-import Control.Monad-import Data.Accessor.Template-import Data.Colour-import Data.Colour.Names+import Graphics.Rendering.Chart.Geometry+import Graphics.Rendering.Chart.Drawing+import Control.Lens  -- | Interface to control plotting on a 2D area. data Plot x y = Plot {      -- | Given the mapping between model space coordinates and device     --   coordinates, render this plot into a chart.-    plot_render_     :: PointMapFn x y -> CRender (),+    _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 -> CRender ()) ],+    _plot_legend     :: [ (String, Rect -> BackendProgram ()) ],      -- | All of the model space coordinates to be plotted. These are     --   used to autoscale the axes where necessary.-    plot_all_points_ :: ([x],[y])+    _plot_all_points :: ([x],[y]) }  -- | A type class abstracting the conversion of a value to a Plot. class ToPlot a where    toPlot :: a x y -> Plot x y +instance ToPlot Plot where+  toPlot p = p+ -- | Join any two plots together (they will share a legend). joinPlot :: Plot x y -> Plot x y -> Plot x y-joinPlot Plot{ plot_render_     = renderP-             , plot_legend_     = legendP-             , plot_all_points_ = (xsP,ysP) }-         Plot{ plot_render_     = renderQ-             , plot_legend_     = legendQ-             , plot_all_points_ = (xsQ,ysQ) }+joinPlot Plot{ _plot_render     = renderP+             , _plot_legend     = legendP+             , _plot_all_points = (xsP,ysP) }+         Plot{ _plot_render     = renderQ+             , _plot_legend     = legendQ+             , _plot_all_points = (xsQ,ysQ) } -       = Plot{ plot_render_     = \a-> renderP a >> renderQ a-             , plot_legend_     = legendP ++ legendQ-             , plot_all_points_ = ( xsP++xsQ, ysP++ysQ )+       = Plot{ _plot_render     = \a-> renderP a >> renderQ a+             , _plot_legend     = legendP ++ legendQ+             , _plot_all_points = ( xsP++xsQ, ysP++ysQ )              }   ---------------------------------------------------------------------- -mapXY :: PointMapFn x y -> ((x,y) -> Point)+mapXY :: PointMapFn x y -> (x,y) -> Point mapXY f (x,y) = f (LValue x, LValue y)  ----------------------------------------------------------------------@@ -77,7 +76,4 @@  ---------------------------------------------------------------------- -------------------------------------------------------------------------- Template haskell to derive an instance of Data.Accessor.Accessor--- for each field.-$( deriveAccessors ''Plot )+$( makeLenses ''Plot )
+ Graphics/Rendering/Chart/Plot/Vectors.hs view
@@ -0,0 +1,145 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Graphics.Rendering.Chart.Plot.Vectors+-- Copyright   :  (c) Anton Vorontsov <anton@enomsg.org> 2014+-- License     :  BSD-style (see chart/COPYRIGHT)+--+-- Vector plots+--+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}++module Graphics.Rendering.Chart.Plot.Vectors(+    PlotVectors(..),+    VectorStyle(..),+    plotVectorField,+    plot_vectors_mapf,+    plot_vectors_grid,+    plot_vectors_title,+    plot_vectors_style,+    plot_vectors_scale,+    plot_vectors_values,+    vector_line_style,+    vector_head_style,+) where++import Control.Lens+import Control.Monad+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif+import Data.Tuple+import Data.Colour hiding (over)+import Data.Colour.Names+import Data.Default.Class+import Graphics.Rendering.Chart.Axis+import Graphics.Rendering.Chart.Drawing+import Graphics.Rendering.Chart.Geometry+import Graphics.Rendering.Chart.Plot.Types++data VectorStyle = VectorStyle+    { _vector_line_style :: LineStyle+    , _vector_head_style :: PointStyle+    }++$( makeLenses ''VectorStyle )++data PlotVectors x y = PlotVectors+    { _plot_vectors_title        :: String+    , _plot_vectors_style        :: VectorStyle+    -- | Set to 1 (default) to normalize the length of vectors to a space+    --   between them (so that the vectors never overlap on the graph).+    --   Set to 0 to disable any scaling.+    --   Values in between 0 and 1 are also permitted to adjust scaling.+    , _plot_vectors_scale        :: Double+    -- | Provide a square-tiled regular grid.+    , _plot_vectors_grid         :: [(x,y)]+    -- | Provide a vector field (R^2 -> R^2) function.+    , _plot_vectors_mapf         :: (x,y) -> (x,y)+    -- | Provide a prepared list of (start,vector) pairs.+    , _plot_vectors_values       :: [((x,y),(x,y))]+    }++$( makeLenses ''PlotVectors )++mapGrid :: (PlotValue y, PlotValue x)+        => [(x,y)] -> ((x,y) -> (x,y)) -> [((x,y),(x,y))]+mapGrid grid f = zip grid (f <$> grid)++plotVectorField :: (PlotValue x, PlotValue y) => PlotVectors x y -> Plot x y+plotVectorField pv = Plot+    { _plot_render     = renderPlotVectors pv+    , _plot_legend     = [(_plot_vectors_title pv, renderPlotLegendVectors pv)]+    , _plot_all_points = (map fst pts, map snd pts)+    }+  where+    pvals = _plot_vectors_values pv+    mvals = mapGrid (_plot_vectors_grid pv) (_plot_vectors_mapf pv)+    pts = concatMap (\(a,b) -> [a,b]) (pvals ++ mvals)++renderPlotVectors :: (PlotValue x, PlotValue y)+                  => PlotVectors x y -> PointMapFn x y -> BackendProgram ()+renderPlotVectors pv pmap = do+    let pvals   = _plot_vectors_values pv+        mvals   = mapGrid (_plot_vectors_grid pv) (_plot_vectors_mapf pv)+        trans   = translateToStart <$> (pvals ++ mvals)+        pvecs   = filter (\v -> vlen' v > 0) $ over both (mapXY pmap) <$> trans+        mgrid   = take 2 $ fst <$> pvecs+        maxLen  = maximum $ vlen' <$> pvecs+        spacing = (!!1) $ (vlen <$> zipWith psub mgrid (reverse mgrid)) ++ [maxLen]+        sfactor = spacing/maxLen                  -- Non-adjusted scale factor+        afactor = sfactor + (1 - sfactor)*(1 - _plot_vectors_scale pv)+        tails   = pscale afactor <$> pvecs          -- Paths of arrows' tails+        angles  = (vangle . psub' . swap) <$> pvecs -- Angles of the arrows+        centers = snd <$> tails                     -- Where to draw arrow heads+    mapM_ (drawTail radius) tails+    zipWithM_ (drawArrowHead radius) centers angles+  where+    psub' = uncurry psub+    vlen' = vlen . psub'+    pvs = _plot_vectors_style pv+    radius = _point_radius $ _vector_head_style pvs+    hs angle = _vector_head_style pvs & point_shape+                  %~ (\(PointShapeArrowHead a) -> PointShapeArrowHead $ a+angle)+    translateToStart (s@(x,y),(vx,vy)) = (s,(tr x vx,tr y vy))+      where tr p t = fromValue $ toValue p + toValue t+    pscale w v@(s,_) = (s,translateP (vscale w . psub' $ swap v) s)+    drawTail r v = withLineStyle (_vector_line_style pvs) $+        strokePointPath $ (^..each) v'+      where+        v'  = pscale (1-(3/2)*r/l) v+        l   = vlen' v+    drawArrowHead r (Point x y) theta =+        withTranslation (Point (-r*cos theta) (-r*sin theta))+                        (drawPoint (hs theta) (Point x y))++renderPlotLegendVectors :: (PlotValue x, PlotValue y)+                        => PlotVectors x y -> Rect -> BackendProgram ()+renderPlotLegendVectors pv (Rect p1 p2) = do+    let y = (p_y p1 + p_y p2)/2+        pv' = plot_vectors_grid .~ []+            $ plot_vectors_values .~ [((fromValue $ p_x p1, fromValue y),+                                       (fromValue $ p_x p2, fromValue 0))]+            $ pv+    renderPlotVectors pv' pmap+  where+    pmap (LValue x,LValue y) = Point (toValue x) (toValue y)+    pmap _ = Point 0 0++instance Default VectorStyle where+  def = VectorStyle+    { _vector_line_style = (solidLine lw $ opaque blue)+                              { _line_cap = LineCapSquare }+    , _vector_head_style = PointStyle (opaque red) transparent lw (2*lw)+                                      (PointShapeArrowHead 0)+    } where lw = 2++instance Default (PlotVectors x y) where+  def = PlotVectors+    { _plot_vectors_title        = ""+    , _plot_vectors_style        = def+    , _plot_vectors_scale        = 1+    , _plot_vectors_grid         = []+    , _plot_vectors_mapf         = id+    , _plot_vectors_values       = []+    }
Graphics/Rendering/Chart/Renderable.hs view
@@ -1,26 +1,25 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Graphics.Rendering.Chart.Renderable--- Copyright   :  (c) Tim Docker 2006+-- Copyright   :  (c) Tim Docker 2006, 2014 -- License     :  BSD-style (see chart/COPYRIGHT) -- -- This module contains the definition of the 'Renderable' type, which -- is a composable drawing element, along with assorted functions to -- them. --+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE TemplateHaskell #-}  module Graphics.Rendering.Chart.Renderable(     Renderable(..),     ToRenderable(..),     PickFn,--    renderableToPNGFile,-    renderableToPDFFile,-    renderableToPSFile,-    renderableToSVGFile,+    Rectangle(..),+    RectCornerStyle(..), -    vectorEnv,-    bitmapEnv,+    rectangleToRenderable,+    drawRectangle,      fillBackground,     addMargins,@@ -41,19 +40,19 @@     rect_cornerStyle, ) where -import qualified Graphics.Rendering.Cairo as C-import qualified Graphics.Rendering.Cairo.Matrix as Matrix import Control.Monad-import Data.Accessor-import Data.List ( nub, transpose, sort )+import Control.Lens+import Data.Default.Class -import Graphics.Rendering.Chart.Types+import Graphics.Rendering.Chart.Geometry+import Graphics.Rendering.Chart.Drawing+import Graphics.Rendering.Chart.Utils  -- | A function that maps a point in device coordinates to some value. -- --   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@@ -62,25 +61,29 @@ --   graphic element. data Renderable a = Renderable { -   -- | A Cairo action to calculate a minimum size.-   minsize :: CRender RectSize,+   -- | Calculate the minimum size of the renderable.+   minsize :: BackendProgram RectSize, -   -- | A Cairo action for drawing it within a rectangle.-   --   The rectangle is from the origin to the given point.+   -- | Draw the renderable with a rectangle, which covers+   --   the origin to a given point.    --    --   The resulting "pick" function  maps a point in the image to a value.-   render  ::  RectSize -> CRender (PickFn a)+   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 ()+  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@@ -94,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@@ -115,76 +118,28 @@         (w,h) <- minsize rd         return (w+l+r,h+t+b) -    rf (w,h) = do-        preserveCState $ do-            c $ C.translate l t-            pickf <- render rd (w-l-r,h-t-b)-            return (mkpickf pickf (t,b,l,r) (w,h))+    rf (w,h) =+        withTranslation (Point l t) $ do+          pickf <- render rd (w-l-r,h-t-b)+          return (mkpickf pickf (t,b,l,r) (w,h)) -    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 :: CairoFillStyle -> Renderable a -> Renderable a+fillBackground :: FillStyle -> Renderable a -> Renderable a fillBackground fs r = r{ render = rf }   where     rf rsize@(w,h) = do-        preserveCState $ do-            setClipRegion (Point 0 0) (Point w h)-            setFillStyle fs-            c $ C.paint-	render r rsize---- | Output the given renderable to a PNG file of the specifed size---   (in pixels), to the specified file.-renderableToPNGFile :: Renderable a -> Int -> Int -> FilePath -> IO (PickFn a)-renderableToPNGFile chart width height path = -    C.withImageSurface C.FormatARGB32 width height $ \result -> do-    pick <- C.renderWith result $ runCRender rfn bitmapEnv-    C.surfaceWriteToPNG result path-    return pick-  where-    rfn = do-	render chart (fromIntegral width, fromIntegral height)--renderableToFile withSurface chart width height path = -    withSurface path (fromIntegral width) (fromIntegral height) $ \result -> do-    C.renderWith result $ runCRender rfn vectorEnv-    C.surfaceFinish result-  where-    rfn = do-        render chart (fromIntegral width, fromIntegral height)-        c $ C.showPage---- | Output the given renderable to a PDF file of the specifed size---   (in points), to the specified file.-renderableToPDFFile :: Renderable a -> Int -> Int -> FilePath -> IO ()-renderableToPDFFile = renderableToFile C.withPDFSurface---- | Output the given renderable to a postscript file of the specifed size---   (in points), to the specified file.-renderableToPSFile  :: Renderable a -> Int -> Int -> FilePath -> IO ()-renderableToPSFile  = renderableToFile C.withPSSurface---- | Output the given renderable to an SVG file of the specifed size---   (in points), to the specified file.-renderableToSVGFile :: Renderable a -> Int -> Int -> FilePath -> IO ()-renderableToSVGFile = renderableToFile C.withSVGSurface--bitmapEnv :: CEnv-bitmapEnv = CEnv (adjfn 0.5) (adjfn 0.0)-  where-    adjfn offset (Point x y) = Point (adj x) (adj y)-      where-        adj v = (fromIntegral.round) v +offset--vectorEnv :: CEnv-vectorEnv = CEnv id id+      withFillStyle fs $ do+        p <- alignFillPath $ rectPath (Rect (Point 0 0) (Point w h))+        fillPath p+      render r rsize  -- | Helper function for using a renderable, when we generate it---   in the CRender monad.-embedRenderable :: CRender (Renderable a) -> Renderable a+--   in the BackendProgram monad.+embedRenderable :: BackendProgram (Renderable a) -> Renderable a embedRenderable ca = Renderable {    minsize = do { a <- ca; minsize a },    render  = \ r -> do { a <- ca; render a r }@@ -195,41 +150,46 @@ -- Labels  -- | Construct a renderable from a text string, aligned with the axes.-label :: CairoFontStyle -> HTextAnchor -> VTextAnchor -> String-         -> Renderable String+label :: FontStyle -> HTextAnchor -> VTextAnchor -> String -> Renderable String label fs hta vta = rlabel fs hta vta 0  -- | Construct a renderable from a text string, rotated wrt to axes. The angle---   of rotation is in degrees.-rlabel :: CairoFontStyle -> HTextAnchor -> VTextAnchor -> Double -> String-          -> Renderable String+--   of rotation is in degrees, measured clockwise from the horizontal.+rlabel :: FontStyle -> HTextAnchor -> VTextAnchor -> Double -> String -> Renderable String rlabel fs hta vta rot s = Renderable { minsize = mf, render = rf }   where-    mf = preserveCState $ do-       setFontStyle fs-       (w,h) <- textSize s-       return (w*acr+h*asr,w*asr+h*acr)-    rf (w0,h0) = preserveCState $ do-       setFontStyle fs-       sz@(w,h) <- textSize s-       fe <- c $ C.fontExtents-       c $ C.translate 0 (-C.fontExtentsDescent fe)-       c $ C.translate (xadj sz hta 0 w0) (yadj sz vta 0 h0)-       c $ C.rotate rot'-       c $ C.moveTo (-w/2) (h/2)-       c $ C.showText s-       return (\_-> 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+    mf = withFontStyle fs $ do+       ts <- textSize s+       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)+          descent = textSizeDescent ts++          xadj HTA_Left   = xwid sz/2+          xadj HTA_Centre = w0/2+          xadj HTA_Right  = w0 - xwid sz/2++          yadj VTA_Top      = ywid sz/2+          yadj VTA_Centre   = h0/2+          yadj VTA_Bottom   = h0 - ywid sz/2+          yadj VTA_BaseLine = h0 - ywid sz/2 + descent*acr++      withTranslation (Point 0 (-descent)) $+        withTranslation (Point (xadj hta) (yadj vta)) $+          withRotation rot' $ do+            drawText (Point (-w/2) (h/2)) s+            return (\_-> Just s)  -- PickFn String+     rot'      = rot / 180 * pi     (cr,sr)   = (cos rot', sin rot')     (acr,asr) = (abs cr, abs sr) +    xwid (w,h) = w*acr + h*asr+    ywid (w,h) = w*asr + h*acr+ ---------------------------------------------------------------------- -- Rectangles @@ -238,89 +198,74 @@                      | RCornerRounded Double  data Rectangle = Rectangle {-  rect_minsize_     :: RectSize,-  rect_fillStyle_   :: Maybe CairoFillStyle,-  rect_lineStyle_   :: Maybe CairoLineStyle,-  rect_cornerStyle_ :: RectCornerStyle+  _rect_minsize     :: RectSize,+  _rect_fillStyle   :: Maybe FillStyle,+  _rect_lineStyle   :: Maybe LineStyle,+  _rect_cornerStyle :: RectCornerStyle } --- | Accessor for field rect_minsize_.-rect_minsize :: Accessor Rectangle RectSize-rect_minsize     = accessor (\v->rect_minsize_ v)-                            (\a v -> v{rect_minsize_=a})---- | Accessor for field rect_fillStyle_.-rect_fillStyle :: Accessor Rectangle (Maybe CairoFillStyle)-rect_fillStyle   = accessor (\v->rect_fillStyle_ v)-                            (\a v -> v{rect_fillStyle_=a})---- | Accessor for field rect_lineStyle_.-rect_lineStyle :: Accessor Rectangle (Maybe CairoLineStyle)-rect_lineStyle   = accessor (\v->rect_lineStyle_ v)-                            (\a v -> v{rect_lineStyle_=a})+instance Default Rectangle where+  def = Rectangle+    { _rect_minsize     = (0,0)+    , _rect_fillStyle   = Nothing+    , _rect_lineStyle   = Nothing+    , _rect_cornerStyle = RCornerSquare+    } --- | Accessor for field rect_cornerStyle_.-rect_cornerStyle :: Accessor Rectangle RectCornerStyle-rect_cornerStyle = accessor (\v->rect_cornerStyle_ v)-                            (\a v -> v{rect_cornerStyle_=a})+instance ToRenderable Rectangle where+  toRenderable = rectangleToRenderable +rectangleToRenderable :: Rectangle -> Renderable a+rectangleToRenderable rectangle = Renderable mf rf+  where+    mf = return (_rect_minsize rectangle)+    rf = \rectSize -> drawRectangle (Point 0 0)+                                    rectangle{ _rect_minsize = rectSize } -defaultRectangle :: Rectangle-defaultRectangle = Rectangle {-  rect_minsize_     = (0,0),-  rect_fillStyle_   = Nothing,-  rect_lineStyle_   = Nothing,-  rect_cornerStyle_ = RCornerSquare-}+-- | Draw the specified rectangle such that its top-left vertex is placed at+--   the given position+drawRectangle :: Point -> Rectangle -> BackendProgram (PickFn a)+drawRectangle point rectangle = do+  maybeM () (fill point size) (_rect_fillStyle rectangle)+  maybeM () (stroke point size) (_rect_lineStyle rectangle)+  return nullPickFn+    where+      size = _rect_minsize rectangle -instance ToRenderable Rectangle where-   toRenderable rectangle = Renderable mf rf-     where-      mf    = return (rect_minsize_ rectangle)-      rf sz = preserveCState $ do-        maybeM () (fill sz) (rect_fillStyle_ rectangle)-        maybeM () (stroke sz) (rect_lineStyle_ rectangle)-        return nullPickFn+      fill p sz fs =+          withFillStyle fs $+            fillPath $ strokeRectangleP p sz (_rect_cornerStyle rectangle) -      fill sz fs = do-          setFillStyle fs-          strokeRectangle sz (rect_cornerStyle_ rectangle)-          c $ C.fill+      stroke p sz ls =+          withLineStyle ls $+            strokePath $ strokeRectangleP p sz (_rect_cornerStyle rectangle) -      stroke sz ls = do-          setLineStyle ls-          strokeRectangle sz (rect_cornerStyle_ rectangle)-          c $ C.stroke+      strokeRectangleP (Point x1 y1) (x2,y2) RCornerSquare =+          let (x3,y3) = (x1+x2,y1+y2) in moveTo' x1 y1+                                      <> lineTo' x1 y3+                                      <> lineTo' x3 y3+                                      <> lineTo' x3 y1+                                      <> lineTo' x1 y1 -      strokeRectangle (x2,y2) RCornerSquare = c $ do-          let (x1,y1) = (0,0)-          C.moveTo x1 y1-          C.lineTo x1 y2-          C.lineTo x2 y2-          C.lineTo x2 y1-          C.lineTo x1 y1-          C.lineTo x1 y2-                                  -      strokeRectangle (x2,y2) (RCornerBevel s) = c $ do-          let (x1,y1) = (0,0)-          C.moveTo x1 (y1+s)-          C.lineTo x1 (y2-s)-          C.lineTo (x1+s) y2-          C.lineTo (x2-s) y2-          C.lineTo x2 (y2-s)-          C.lineTo x2 (y1+s)-          C.lineTo (x2-s) y1-          C.lineTo (x1+s) y1-          C.lineTo x1 (y1+s)-          C.lineTo x1 (y2-s)+      strokeRectangleP (Point x1 y1) (x2,y2) (RCornerBevel s) =+          let (x3,y3) = (x1+x2,y1+y2) in moveTo' x1 (y1+s)+                                      <> lineTo' x1 (y3-s)+                                      <> lineTo' (x1+s) y3+                                      <> lineTo' (x3-s) y3+                                      <> lineTo' x3 (y3-s)+                                      <> lineTo' x3 (y1+s)+                                      <> lineTo' (x3-s) y1+                                      <> lineTo' (x1+s) y1+                                      <> lineTo' x1 (y1+s) -      strokeRectangle (x2,y2) (RCornerRounded s) = c $ do-          let (x1,y1) = (0,0)-          C.arcNegative (x1+s) (y2-s) s (pi2*2) pi2 -          C.arcNegative (x2-s) (y2-s) s pi2 0-          C.arcNegative (x2-s) (y1+s) s 0 (pi2*3)-          C.arcNegative (x1+s) (y1+s) s (pi2*3) (pi2*2)-          C.lineTo x1 (y2-s)+      strokeRectangleP (Point x1 y1) (x2,y2) (RCornerRounded s) =+          let (x3,y3) = (x1+x2,y1+y2) in+            arcNeg (Point (x1+s) (y3-s)) s (pi2*2) pi2+            <> arcNeg (Point (x3-s) (y3-s)) s pi2 0+            <> arcNeg (Point (x3-s) (y1+s)) s 0 (pi2*3)+            <> arcNeg (Point (x1+s) (y1+s)) s (pi2*3) (pi2*2)+            <> lineTo' x1 (y3-s)        pi2 = pi / 2 +$( makeLenses ''Rectangle )
− Graphics/Rendering/Chart/Simple.hs 
@@ -1,33 +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, Layout1DDD-                                      ) where--import Graphics.Rendering.Chart.Simple.Internal
− Graphics/Rendering/Chart/Simple/Internal.hs 
@@ -1,277 +0,0 @@-module Graphics.Rendering.Chart.Simple.Internal where--import Data.Maybe ( catMaybes )-import Data.Colour-import Data.Colour.Names--import Graphics.Rendering.Chart--styleColor :: Int -> AlphaColour Double-styleColor ind = colorSequence !! ind-    where colorSequence = cycle $ map opaque [ blue, red, green, yellow-                                             , cyan, magenta, black ]--styleSymbol :: Int -> PlotKind-styleSymbol ind = symbolSequence !! ind-    where symbolSequence = cycle [ Ex, HollowCircle, Square, Diamond-                                 , Triangle, DownTriangle, Plus, Star-                                 , FilledCircle ]---- When defaultLayout1 has been generalized, change this signature to --- [InternalPlot x y] -> Layout1 x y z-iplot :: [InternalPlot Double Double] -> Layout1 Double Double-iplot foobar = defaultLayout1 {-        layout1_plots_ = concat $ zipWith toplot (ip foobar) [0..]-    }-  where-    ip (xs@(IPX _ _):xyss) = map (\ys -> (xs,ys)) yss ++ ip rest-                where yss  = takeWhile isIPY xyss-                      rest = dropWhile isIPY xyss-    ip (_:xyss) = ip xyss-    ip   []     = []-    isIPY (IPY _ _) = True-    isIPY _         = False-    toplot (IPX xs _, IPY ys yks) ind = map Left plots-      where-        vs = zip xs ys-        plots = case catMaybes $ map plotas yks of-                    [] -> [ toPlot $ defaultPlotLines-                           { plot_lines_title_  = name yks,-                             plot_lines_values_ = [vs],-                             plot_lines_style_  = solidLine 1 (styleColor ind)-                           } ]-                    xs -> xs-        plotas Solid = Just $ toPlot $ defaultPlotLines-                         { plot_lines_title_  = name yks,-                           plot_lines_values_ = [vs],-                           plot_lines_style_  = solidLine 1 (styleColor ind) }-        plotas Dashed = Just $ toPlot $ defaultPlotLines-                         { plot_lines_title_  = name yks,-                           plot_lines_values_ = [vs],-                           plot_lines_style_  = dashedLine 1 [10,10]-                                                           (styleColor ind) }-        plotas Dotted = Just $ toPlot $ defaultPlotLines-                         { plot_lines_title_  = name yks,-                           plot_lines_values_ = [vs],-                           plot_lines_style_  = dashedLine 1 [1,11]-                                                           (styleColor ind) }-        plotas FilledCircle = Just $ toPlot $ defaultPlotPoints-                         { plot_points_title_  = name yks,-                           plot_points_values_ = vs,-                           plot_points_style_  = filledCircles 4-                                                           (styleColor ind) }-        plotas HollowCircle = Just $ toPlot $ defaultPlotPoints-                         { plot_points_title_  = name yks,-                           plot_points_values_ = vs,-                           plot_points_style_  = hollowCircles 5 1-                                                           (styleColor ind) }-        plotas Triangle = Just $ toPlot $ defaultPlotPoints-                         { plot_points_title_  = name yks,-                           plot_points_values_ = vs,-                           plot_points_style_  = hollowPolygon 7 1 3 False-                                                           (styleColor ind) }-        plotas DownTriangle = Just $ toPlot $ defaultPlotPoints-                         { plot_points_title_  = name yks,-                           plot_points_values_ = vs,-                           plot_points_style_  = hollowPolygon 7 1 3 True-                                                           (styleColor ind) }-        plotas Square = Just $ toPlot $ defaultPlotPoints-                         { plot_points_title_  = name yks,-                           plot_points_values_ = vs,-                           plot_points_style_  = hollowPolygon 7 1 4 False-                                                           (styleColor ind) }-        plotas Diamond = Just $ toPlot $ defaultPlotPoints-                         { plot_points_title_  = name yks,-                           plot_points_values_ = vs,-                           plot_points_style_  = hollowPolygon 7 1 4 True-                                                           (styleColor ind) }-        plotas Plus = Just $ toPlot $ defaultPlotPoints-                         { plot_points_title_  = name yks,-                           plot_points_values_ = vs,-                           plot_points_style_  = plusses 7 1 (styleColor ind) }-        plotas Ex = Just $ toPlot $ defaultPlotPoints-                         { plot_points_title_  = name yks,-                           plot_points_values_ = vs,-                           plot_points_style_  = exes 7 1 (styleColor ind) }-        plotas Star = Just $ toPlot $ defaultPlotPoints-                         { plot_points_title_  = name yks,-                           plot_points_values_ = vs,-                           plot_points_style_  = stars 7 1 (styleColor ind) }-        plotas Symbols = plotas (styleSymbol ind)-        plotas _ = Nothing--name :: [PlotKind] -> String-name (Name s:_) = s-name (_:ks)     = name ks-name []         = ""--str2k :: String -> [PlotKind]-str2k ""        = []-str2k ". "      = [Dotted]-str2k s@('?':_) = str2khelper s Symbols-str2k s@('@':_) = str2khelper s FilledCircle-str2k s@('#':_) = str2khelper s Square-str2k s@('v':_) = str2khelper s DownTriangle-str2k s@('^':_) = str2khelper s Triangle-str2k s@('o':_) = str2khelper s HollowCircle-str2k s@('+':_) = str2khelper s Plus-str2k s@('x':_) = str2khelper s Ex-str2k s@('*':_) = str2khelper s Star-str2k s@('.':_) = str2khelper s LittleDot-str2k "- "      = [Dashed]-str2k "-"       = [Solid]-str2k n         = [Name n]--str2khelper :: String -> PlotKind -> [PlotKind]-str2khelper s@(_:r) x = case str2k r of-                          []       -> [x]-                          [Name _] -> [Name s]-                          xs       -> x:xs---- | Type to define a few simple properties of each plot.-data PlotKind = Name String | FilledCircle | HollowCircle-              | Triangle | DownTriangle | Square | Diamond-              | Plus | Ex | Star | Symbols-              | LittleDot | Dashed | Dotted | Solid-              deriving ( Eq, Show, Ord )-data InternalPlot x y = IPY [y] [PlotKind] | IPX [x] [PlotKind]--newtype Layout1DDD = Layout1DDD { plotLayout :: Layout1 Double Double }-instance ToRenderable Layout1DDD where- toRenderable = toRenderable . plotLayout--uplot :: [UPlot] -> Layout1DDD-uplot us = Layout1DDD $ iplot $ nameDoubles $ evalfuncs us-  where-    nameDoubles :: [UPlot] -> [InternalPlot Double Double]-    nameDoubles (X xs: uus)      = case grabName uus of-                                   (ks,uus') -> IPX (filter isValidNumber xs) ks-                                                : nameDoubles uus'-    nameDoubles (UDoubles xs:uus)= case grabName uus of-                                   (ks,uus') -> IPY (filter isValidNumber xs) ks-                                                : nameDoubles uus'-    nameDoubles (_:uus)          = nameDoubles uus-    nameDoubles []               = []-    evalfuncs :: [UPlot] -> [UPlot]-    evalfuncs (UDoubles xs:uus) = X xs : map ef (takeWhile (not.isX) uus)-                                  ++ evalfuncs (dropWhile (not.isX) uus)-        where ef (UFunction f) = UDoubles (map f xs)-              ef u             = u-    evalfuncs (X xs:uus) = X xs : map ef (takeWhile (not.isX) uus)-                           ++ evalfuncs (dropWhile (not.isX) uus)-        where ef (UFunction f) = UDoubles (map f xs)-              ef u             = u-    evalfuncs (u:uus) = u : evalfuncs uus-    evalfuncs []      = []-    grabName :: [UPlot] -> ([PlotKind],[UPlot])-    grabName (UString n:uus) = case grabName uus of-                               (ks,uus') -> (str2k n++ks,uus')-    grabName (UKind ks:uus)  = case grabName uus of-                               (ks',uus') -> (ks++ks',uus')-    grabName uus             = ([],uus)-    isX (X _) = True-    isX _     = False---- | The main plotting function.  The idea behind PlotType is shamelessly---   copied from Text.Printf (and is not exported).  All you need to know is---   that your arguments need to be in class PlotArg.  And PlotArg consists---   of functions and [Double] and String and PlotKind or [PlotKind].--plot :: PlotType a => a-plot = pl []-class PlotType t where-    pl     :: [UPlot] -> t-instance (PlotArg a, PlotType r) => PlotType (a -> r) where-    pl args = \ a -> pl (toUPlot a ++ args)-instance PlotType Layout1DDD where-    pl args = uplot (reverse args)---- | Save a plot as a PDF file.--plotPDF :: PlotPDFType a => String -> a-plotPDF fn = pld fn []-class PlotPDFType t where-    pld        :: FilePath -> [UPlot] -> t-instance (PlotArg a, PlotPDFType r) => PlotPDFType (a -> r) where-    pld fn args = \ a -> pld fn (toUPlot a ++ args)-instance PlotPDFType (IO a) where-    pld fn args = do-        renderableToPDFFile (toRenderable $ uplot (reverse args)) 640 480 fn-        return undefined---- | Save a plot as a postscript file.--plotPS :: PlotPSType a => String -> a-plotPS fn = pls fn []-class PlotPSType t where-    pls        :: FilePath -> [UPlot] -> t-instance (PlotArg a, PlotPSType r) => PlotPSType (a -> r) where-    pls fn args = \ a -> pls fn (toUPlot a ++ args)-instance PlotPSType (IO a) where-    pls fn args = do-        renderableToPSFile (toRenderable $ uplot (reverse args)) 640 480 fn-        return undefined---- | Save a plot as a png file.-plotPNG :: PlotPNGType a => String -> a-plotPNG fn = plp fn []--class PlotPNGType t where-    plp        :: FilePath -> [UPlot] -> t-instance (PlotArg a, PlotPNGType r) => PlotPNGType (a -> r) where-    plp fn args = \ a -> plp fn (toUPlot a ++ args)-instance PlotPNGType (IO a) where-    plp fn args = do-        renderableToPNGFile (toRenderable $ uplot (reverse args)) 640 480 fn-        return undefined----data UPlot = UString String | UDoubles [Double] | UFunction (Double -> Double)-           | UKind [PlotKind] | X [Double]--xcoords :: [Double] -> UPlot-xcoords = X--class PlotArg a where-    toUPlot :: a -> [UPlot]--instance IsPlot p => PlotArg [p] where-    toUPlot = toUPlot'--instance (Real a, Real b, Fractional a, Fractional b) => PlotArg (a -> b) where-    toUPlot x = [UFunction (realToFrac . x . realToFrac)]--instance (Real a, Real b, Fractional a, Fractional b) => IsPlot (a -> b) where-    toUPlot' = reverse . concatMap f-        where f x = [UFunction (realToFrac . x . realToFrac)]--instance PlotArg UPlot where-    toUPlot = (:[])--instance PlotArg PlotKind where-    toUPlot = (:[]) . UKind . (:[])---class IsPlot c where-    toUPlot' :: [c] -> [UPlot]--instance IsPlot PlotKind where-    toUPlot' = (:[]) . UKind--instance IsPlot Double where-    toUPlot' = (:[]) . UDoubles--instance IsPlot Char where-    toUPlot' = (:[]) . UString--instance IsPlot p => IsPlot [p] where-    toUPlot' = reverse . concatMap toUPlot'--instance (IsPlot p, IsPlot q, IsPlot r) => IsPlot (p,q,r) where-    toUPlot' = reverse . concatMap f-        where f (p,q,r) = toUPlot' [p] ++ toUPlot' [q] ++ toUPlot' [r]--instance (IsPlot p, IsPlot q) => IsPlot (p,q) where-    toUPlot' = reverse . concatMap f-        where f (p,q) = toUPlot' [p] ++ toUPlot' [q]
Graphics/Rendering/Chart/SparkLine.hs view
@@ -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"  -- > --------------------------------------------------------------- @@ -36,14 +38,15 @@   , sparkSize     -- * Rendering function   , renderSparkLine-  , sparkLineToPNG-  , sparkLineToPDF+  , sparkLineToRenderable+  , sparkWidth   ) where  import Control.Monad import Data.List import Data.Ord-import Graphics.Rendering.Chart.Types+import Graphics.Rendering.Chart.Geometry+import Graphics.Rendering.Chart.Drawing import Graphics.Rendering.Chart.Renderable import Data.Colour import Data.Colour.Names@@ -89,12 +92,16 @@ barSpark :: SparkOptions barSpark  = smoothSpark { so_smooth=False } -instance ToRenderable SparkLine where-    toRenderable sp = Renderable-            { minsize = return (0, fromIntegral (so_height (sl_options sp)))+-- | Create a renderable from a SparkLine.+sparkLineToRenderable :: SparkLine -> Renderable ()+sparkLineToRenderable sp = Renderable+            { minsize = let (w,h) = sparkSize sp in return (fromIntegral w , fromIntegral h)             , render  = \_rect-> renderSparkLine sp             } +instance ToRenderable SparkLine where+  toRenderable = sparkLineToRenderable+ -- | Compute the width of a SparkLine, for rendering purposes. sparkWidth :: SparkLine -> Int sparkWidth SparkLine{sl_options=opt, sl_data=ds} =@@ -105,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 -> CRender (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@@ -132,38 +140,30 @@       boxpt (Point x y) = Rect (Point (x-1)(y-1)) (Point (x+1)(y+1))       fi    :: (Num b, Integral a) => a -> b       fi    = fromIntegral-  in preserveCState $ do+  in do -  setFillStyle (solidFillStyle (opaque (so_bgColor opt)))-  fillPath (rectPath (Rect (Point 0 0) (Point (fi w) (fi h))))+  withFillStyle (solidFillStyle (opaque (so_bgColor opt))) $ do+    fillPath (rectPath (Rect (Point 0 0) (Point (fi w) (fi h))))   if so_smooth opt     then do-      setLineStyle (solidLine 1 (opaque grey))-      strokePath coords+      withLineStyle (solidLine 1 (opaque grey)) $ do+        p <- alignStrokePoints coords+        strokePointPath p     else do-      setFillStyle (solidFillStyle (opaque grey))-      forM_ coords $ \ (Point x y) ->+      withFillStyle (solidFillStyle (opaque grey)) $ do+        forM_ coords $ \ (Point x y) ->           fillPath (rectPath (Rect (Point (x-1) y) (Point (x+1) (fi h))))   when (so_minMarker opt) $ do-      setFillStyle (solidFillStyle (opaque (so_minColor opt)))-      fillPath (rectPath (boxpt minpt))+      withFillStyle (solidFillStyle (opaque (so_minColor opt))) $ do+        p <- alignFillPath (rectPath (boxpt minpt))+        fillPath p   when (so_maxMarker opt) $ do-      setFillStyle (solidFillStyle (opaque (so_maxColor opt)))-      fillPath (rectPath (boxpt maxpt))+      withFillStyle (solidFillStyle (opaque (so_maxColor opt))) $ do+        p <- alignFillPath (rectPath (boxpt maxpt))+        fillPath p   when (so_lastMarker opt) $ do-      setFillStyle (solidFillStyle (opaque (so_lastColor opt)))-      fillPath (rectPath (boxpt endpt))+      withFillStyle (solidFillStyle (opaque (so_lastColor opt))) $ do+        p <- alignFillPath (rectPath (boxpt endpt))+        fillPath p   return nullPickFn --- | Generate a PNG for the sparkline, using its natural size.-sparkLineToPNG :: FilePath -> SparkLine -> IO (PickFn ())-sparkLineToPNG fp sp = renderableToPNGFile (toRenderable sp)-                                           (sparkWidth sp)-                                           (so_height (sl_options sp))-                                           fp--- | Generate a PDF for the sparkline, using its natural size.-sparkLineToPDF :: FilePath -> SparkLine -> IO ()-sparkLineToPDF fp sp = renderableToPDFFile (toRenderable sp)-                                           (sparkWidth sp)-                                           (so_height (sl_options sp))-                                           fp
+ Graphics/Rendering/Chart/State.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE TemplateHaskell, FlexibleInstances #-}+module Graphics.Rendering.Chart.State(+  plot,+  plotLeft,+  plotRight,++  takeColor,+  takeShape,++  CState,+  colors,+  shapes,++  EC,+  execEC,+  liftEC,+  liftCState,+  ) where++import Control.Lens+import Control.Monad.State+import Data.Default.Class++import Data.Colour+import Data.Colour.Names++import Graphics.Rendering.Chart.Layout+import Graphics.Rendering.Chart.Plot+import Graphics.Rendering.Chart.Drawing+import Graphics.Rendering.Chart.Renderable++-- | The state held when monadically constructing a graphical element+data CState = CState {+  _colors :: [AlphaColour Double], -- ^ An infinite source of colors, for use in plots+  _shapes :: [PointShape]          -- ^ An infinite source of shapes, for use in plots+  }++$( makeLenses ''CState )++-- | We use nested State monads to give nice syntax. The outer state+-- is the graphical element being constructed (typically a+-- layout). The inner state contains any additional state+-- reqired. This approach means that lenses and the state monad lens+-- operators can be used directly on the value being constructed.+type EC l a = StateT l (State CState) a++instance Default CState where+  def = CState defColors defShapes+    where+      defColors = cycle (map opaque [blue,green,red,orange,yellow,violet])+      defShapes = cycle [PointShapeCircle,PointShapePlus,PointShapeCross,PointShapeStar]++instance (Default a,ToRenderable a) => ToRenderable (EC a b) where+  toRenderable = toRenderable . execEC+      +-- | Run the monadic `EC` computation, and return the graphical+-- element (ie the outer monad' state)+execEC :: (Default l) => EC l a -> l+execEC ec = evalState (execStateT ec def) def++-- | Nest the construction of a graphical element within+-- the construction of another.+liftEC :: (Default l1) => EC l1 a -> EC l2 l1+liftEC ec = do+  cs <- lift get+  let (l,cs') = runState (execStateT ec def) cs+  lift (put cs')+  return l++-- | Lift a a computation over `CState`+liftCState :: State CState a -> EC l a+liftCState = lift++-- | Add a plot to the `Layout` being constructed.+plot :: (ToPlot p) => EC (Layout x y) (p x y) -> EC (Layout x y) ()+plot pm = do+    p <- pm+    layout_plots %= (++[toPlot p])++-- | Add a plot against the left axis to the `LayoutLR` being constructed.+plotLeft :: (ToPlot p) => EC (LayoutLR x y1 y2) (p x y1) -> EC (LayoutLR x y1 y2) ()+plotLeft pm = do+  p <- pm+  layoutlr_plots %= (++[Left (toPlot p)])++-- | Add a plot against the right axis tof the `LayoutLR` being constructed.+plotRight :: (ToPlot p) => EC (LayoutLR x y1 y2) (p x y2) -> EC (LayoutLR x y1 y2) ()+plotRight pm = do+  p <- pm+  layoutlr_plots %= (++[Right (toPlot p)])++-- | Pop and return the next color from the state+takeColor :: EC l (AlphaColour Double)+takeColor = liftCState $ do+  (c,cs) <- fromInfiniteList `fmap` use colors+  colors .= cs+  return c++-- | Pop and return the next shape from the state+takeShape :: EC l PointShape+takeShape = liftCState $ do+  (c,cs) <- fromInfiniteList `fmap` use shapes+  shapes .= cs+  return c++fromInfiniteList :: [a] -> (a, [a])+fromInfiniteList []     = error "fromInfiniteList (takeColor or takeShape): empty list"+fromInfiniteList (x:xs) = (x, xs)
− Graphics/Rendering/Chart/Types.hs 
@@ -1,611 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# OPTIONS_GHC -XTemplateHaskell #-}---------------------------------------------------------------------------------- |--- Module      :  Graphics.Rendering.Chart.Types--- Copyright   :  (c) Tim Docker 2006--- License     :  BSD-style (see chart/COPYRIGHT)------ This module contains basic types and functions used for drawing.------ Note that template haskell is used to derive accessor functions--- (see 'Data.Accessor') for each field of the following data types:------    * 'CairoLineStyle'------    * 'CairoFontStyle'------ These accessors are not shown in this API documentation.  They have--- the same name as the field, but with the trailing underscore--- dropped. Hence for data field f_::F in type D, they have type------ @---   f :: Data.Accessor.Accessor D F--- @-----module Graphics.Rendering.Chart.Types(-    Rect(..),-    Point(..),-    Vector(..),--    RectSize,-    Range,--    mkrect,-    pvadd,-    pvsub,-    psub,-    vscale,-    within,--    RectEdge(..),-    Limit(..),-    PointMapFn,--    preserveCState,-    setClipRegion,-    moveTo,-    lineTo,-    rectPath,-    strokePath,-    fillPath,--    isValidNumber,-    maybeM,--    defaultColorSeq,--    setSourceColor,--    CairoLineStyle(..),-    solidLine,-    dashedLine,-    setLineStyle,--    CairoFillStyle(..),-    defaultPointStyle,-    solidFillStyle,-    setFillStyle,--    CairoFontStyle(..),-    defaultFontStyle,-    setFontStyle,--    CairoPointStyle(..),-    filledPolygon,-    hollowPolygon,-    filledCircles,-    hollowCircles,-    plusses,-    exes,-    stars,--    HTextAnchor(..),-    VTextAnchor(..),-    drawText,-    drawTextR,-    drawTextsR,-    textSize,-    textDrawRect,--    CRender(..),-    CEnv(..),-    runCRender,-    c,-    alignp,-    alignc,-    -    line_width,-    line_color,-    line_dashes,-    line_cap,-    line_join,--    font_name,-    font_size,-    font_slant,-    font_weight,-    font_color,--) where--import qualified Graphics.Rendering.Cairo as C-import Control.Monad.Reader-import Data.Accessor-import Data.Accessor.Template-import Data.Colour-import Data.Colour.SRGB-import Data.Colour.Names-import Data.List (unfoldr)---- | A point in two dimensions.-data Point = Point {-    p_x :: Double,-    p_y :: Double-} deriving Show--data Vector = Vector {-    v_x :: Double,-    v_y :: Double-} deriving Show---- | Scale a vector by a constant.-vscale :: Double -> Vector -> Vector-vscale c (Vector x y) = (Vector (x*c) (y*c))---- | Add a point and a vector.-pvadd :: Point -> Vector -> Point-pvadd (Point x1 y1) (Vector x2 y2) = (Point (x1+x2) (y1+y2))---- | Subtract a vector from a point.-pvsub :: Point -> Vector -> Point-pvsub (Point x1 y1) (Vector x2 y2) = (Point (x1-x2) (y1-y2))---- | Subtract two points.-psub :: Point -> Point -> Vector-psub (Point x1 y1) (Point x2 y2) = (Vector (x1-x2) (y1-y2))--data Limit a = LMin | LValue a | LMax-   deriving Show---- | A function mapping between points.-type PointMapFn x y = (Limit x, Limit y) -> Point---- | A rectangle is defined by two points.-data Rect = Rect Point Point-   deriving Show--data RectEdge = E_Top | E_Bottom | E_Left | E_Right---- | Create a rectangle based upon the coordinates of 4 points.-mkrect :: Point -> Point -> Point -> Point -> Rect-mkrect (Point x1 _) (Point _ y2) (Point x3 _) (Point _ y4) =-    Rect (Point x1 y2) (Point x3 y4)---- | Test if a point is within a rectangle.-within :: Point -> Rect -> Bool-within (Point x y) (Rect (Point x1 y1) (Point x2 y2)) =-    x >= x1 && x <= x2 && y >= y1 && y <= y2----------------------------------------------------------------------------- | The environment present in the CRender Monad.-data CEnv = CEnv {-    -- | An adjustment applied immediately prior to points-    --   being displayed in device coordinates.-    ---    --   When device coordinates correspond to pixels, a cleaner-    --   image is created if this transform rounds to the nearest-    --   pixel. With higher-resolution output, this transform can-    --   just be the identity function.-    cenv_point_alignfn :: Point -> Point,--    -- | A adjustment applied immediately prior to coordinates-    --   being transformed.-    cenv_coord_alignfn :: Point -> Point-}---- | The reader monad containing context information to control---   the rendering process.-newtype CRender a = DR (ReaderT CEnv C.Render a)-  deriving (Functor, Monad, MonadReader CEnv)--runCRender :: CRender a -> CEnv -> C.Render a-runCRender (DR m) e = runReaderT m e--c :: C.Render a -> CRender a-c = DR . lift- --------------------------------------------------------------------------- | Abstract data type for the style of a plotted point.------   The contained Cairo action draws a point in the desired---   style, at the supplied device coordinates.-newtype CairoPointStyle = CairoPointStyle (Point -> CRender ())---- | Data type for the style of a line.-data CairoLineStyle = CairoLineStyle {-   line_width_  :: Double,-   line_color_  :: AlphaColour Double,-   line_dashes_ :: [Double],-   line_cap_    :: C.LineCap,-   line_join_   :: C.LineJoin-}---- | Abstract data type for a fill style.------   The contained Cairo action sets the required fill---   style in the Cairo rendering state.-newtype CairoFillStyle = CairoFillStyle (CRender ())---- | Data type for a font.-data CairoFontStyle = CairoFontStyle {-      font_name_   :: String,-      font_size_   :: Double,-      font_slant_  :: C.FontSlant,-      font_weight_ :: C.FontWeight,-      font_color_  :: AlphaColour Double-}--type Range    = (Double,Double)-type RectSize = (Double,Double)--defaultColorSeq :: [AlphaColour Double]-defaultColorSeq = cycle $ map opaque [blue, red, green, yellow, cyan, magenta]--------------------------------------------------------------------------- Assorted helper functions in Cairo Usage--moveTo, lineTo :: Point -> CRender ()-moveTo p  = do-    p' <- alignp p-    c $ C.moveTo (p_x p') (p_y p')--alignp :: Point -> CRender Point-alignp p = do -    alignfn <- fmap cenv_point_alignfn ask-    return (alignfn p)--alignc :: Point -> CRender Point-alignc p = do -    alignfn <- fmap cenv_coord_alignfn ask-    return (alignfn p)--lineTo p = do-    p' <- alignp p-    c $ C.lineTo (p_x p') (p_y p')--setClipRegion :: Point -> Point -> CRender ()-setClipRegion p2 p3 = do    -    c $ C.moveTo (p_x p2) (p_y p2)-    c $ C.lineTo (p_x p2) (p_y p3)-    c $ C.lineTo (p_x p3) (p_y p3)-    c $ C.lineTo (p_x p3) (p_y p2)-    c $ C.lineTo (p_x p2) (p_y p2)-    c $ C.clip---- | Make a path from a rectangle.-rectPath :: Rect -> [Point]-rectPath (Rect p1@(Point x1 y1) p3@(Point x2 y2)) = [p1,p2,p3,p4,p1]-  where    -    p2 = (Point x1 y2)-    p4 = (Point x2 y1)--stepPath :: [Point] -> CRender()-stepPath (p:ps) = c $ do-    C.newPath                    -    C.moveTo (p_x p) (p_y p)-    mapM_ (\p -> C.lineTo (p_x p) (p_y p)) ps-stepPath _  = return ()---- | Draw lines between the specified points.------ The points will be "corrected" by the cenv_point_alignfn, so that--- when drawing bitmaps, 1 pixel wide lines will be centred on the--- pixels.-strokePath :: [Point] -> CRender()-strokePath pts = do-    alignfn <- fmap cenv_point_alignfn ask-    stepPath (map alignfn pts)-    c $ C.stroke---- | Fill the region with the given corners.------ The points will be "corrected" by the cenv_coord_alignfn, so that--- when drawing bitmaps, the edges of the region will fall between--- pixels.-fillPath ::  [Point] -> CRender()-fillPath pts = do-    alignfn <- fmap cenv_coord_alignfn ask-    stepPath (map alignfn pts)-    c $ C.fill--setFontStyle :: CairoFontStyle -> CRender ()-setFontStyle f = do-    c $ C.selectFontFace (font_name_ f) (font_slant_ f) (font_weight_ f)-    c $ C.setFontSize (font_size_ f)-    c $ setSourceColor (font_color_ f)--setLineStyle :: CairoLineStyle -> CRender ()-setLineStyle ls = do-    c $ C.setLineWidth (line_width_ ls)-    c $ setSourceColor (line_color_ ls)-    c $ C.setLineCap (line_cap_ ls)-    c $ C.setLineJoin (line_join_ ls)-    c $ C.setDash (line_dashes_ ls) 0--setFillStyle :: CairoFillStyle -> CRender ()-setFillStyle (CairoFillStyle s) = s--colourChannel :: (Floating a, Ord a) => AlphaColour a -> Colour a-colourChannel c = darken (recip (alphaChannel c)) (c `over` black)--setSourceColor :: AlphaColour Double -> C.Render ()-setSourceColor c = let (RGB r g b) = toSRGB $ colourChannel c-                   in C.setSourceRGBA r g b (alphaChannel c)---- | Return the bounding rectangle for a text string rendered---   in the current context.-textSize :: String -> CRender RectSize-textSize s = c $ do-    te <- C.textExtents s-    fe <- C.fontExtents-    return (C.textExtentsWidth te, C.fontExtentsHeight fe)--data HTextAnchor = HTA_Left | HTA_Centre | HTA_Right-data VTextAnchor = VTA_Top | VTA_Centre | VTA_Bottom | VTA_BaseLine---- | Recturn the bounding rectangle for a text string positioned---   where it would be drawn by drawText-textDrawRect :: HTextAnchor -> VTextAnchor -> Point -> String -> CRender Rect-textDrawRect hta vta (Point x y) s = preserveCState $ textSize s >>= rect-    where-      rect (w,h) = c $ do te <- C.textExtents s-                          fe <- C.fontExtents-                          let lx = xadj hta (C.textExtentsWidth te)-                          let ly = yadj vta te fe-                          let (x',y') = (x + lx, y + ly)-                          let p1 = Point x' y'-                          let p2 = Point (x' + w) (y' + h)-                          return $ Rect p1 p2--      xadj HTA_Left   w = 0-      xadj HTA_Centre w = (-w/2)-      xadj HTA_Right  w = (-w)-      yadj VTA_Top      te fe = C.fontExtentsAscent fe-      yadj VTA_Centre   te fe = - (C.textExtentsYbearing te) / 2-      yadj VTA_BaseLine te fe = 0-      yadj VTA_Bottom   te fe = -(C.fontExtentsDescent fe)---- | Function to draw a textual label anchored by one of its corners---   or edges.-drawText :: HTextAnchor -> VTextAnchor -> Point -> String -> CRender ()-drawText hta vta p s = drawTextR hta vta 0 p s---- | Function to 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.-drawTextR :: HTextAnchor -> VTextAnchor -> Double -> Point -> String -> CRender ()-drawTextR hta vta angle (Point x y) s = preserveCState $ draw-    where-      draw =  c $ do te <- C.textExtents s-                     fe <- C.fontExtents-                     let lx = xadj hta (C.textExtentsWidth te)-                     let ly = yadj vta te fe-                     C.translate x y-                     C.rotate theta-                     C.moveTo lx ly-                     C.showText s-      theta = angle*pi/180.0-      xadj HTA_Left   w = 0-      xadj HTA_Centre w = (-w/2)-      xadj HTA_Right  w = (-w)-      yadj VTA_Top      te fe = C.fontExtentsAscent fe-      yadj VTA_Centre   te fe = - (C.textExtentsYbearing te) / 2-      yadj VTA_BaseLine te fe = 0-      yadj VTA_Bottom   te fe = -(C.fontExtentsDescent fe)---- | Function to draw a multi-line textual label anchored by one of its corners---   or edges, with rotation. Rotation angle is given in degrees,---   rotation is performed around anchor point.-drawTextsR :: HTextAnchor -> VTextAnchor -> Double -> Point -> String -> CRender ()-drawTextsR hta vta angle (Point x y) s = preserveCState $ drawAll-    where-      ss   = lines s-      num  = length ss-      drawAll =  c $ do tes <- mapM C.textExtents ss-                        fe  <- C.fontExtents-                        let widths = map C.textExtentsWidth tes-                            maxw   = maximum widths-                            maxh   = maximum (map C.textExtentsYbearing tes)-                            gap    = maxh / 2 -- half-line spacing-                            totalHeight = fromIntegral num*maxh +-                                          (fromIntegral num-1)*gap-                            ys = take num (unfoldr (\y-> Just (y, y-gap-maxh))-                                                   (yinit vta fe totalHeight))-                            xs = map (xadj hta) widths-                        C.translate x y-                        C.rotate theta-                        sequence_ (zipWith3 draw xs ys ss)--      draw lx ly s =  do C.moveTo lx ly-                         C.showText s-      theta = angle*pi/180.0--      xadj HTA_Left   w = 0-      xadj HTA_Centre w = (-w/2)-      xadj HTA_Right  w = (-w)--      yinit VTA_Top      fe height = C.fontExtentsAscent fe-      yinit VTA_BaseLine fe height = 0-      yinit VTA_Centre   fe height = height / 2 + C.fontExtentsAscent fe-      yinit VTA_Bottom   fe height = height + C.fontExtentsAscent fe----- | Execute a rendering action in a saved context (ie bracketed---   between C.save and C.restore).-preserveCState :: CRender a -> CRender a-preserveCState a = do -  c $ C.save-  v <- a-  c $ C.restore-  return v--------------------------------------------------------------------------filledCircles ::-     Double             -- ^ Radius of circle.-  -> AlphaColour Double -- ^ Colour.-  -> CairoPointStyle-filledCircles radius cl = CairoPointStyle rf-  where-    rf p = do-        (Point x y) <- alignp p-	c $ setSourceColor cl-        c $ C.newPath-	c $ C.arc x y radius 0 (2*pi)-	c $ C.fill--hollowCircles ::-     Double -- ^ Radius of circle.-  -> Double -- ^ Thickness of line.-  -> AlphaColour Double-  -> CairoPointStyle-hollowCircles radius w cl = CairoPointStyle rf-  where-    rf p = do-        (Point x y) <- alignp p-        c $ C.setLineWidth w-	c $ setSourceColor cl-        c $ C.newPath-	c $ C.arc x y radius 0 (2*pi)-	c $ C.stroke--hollowPolygon ::-     Double -- ^ Radius of circle.-  -> Double -- ^ Thickness of line.-  -> Int    -- ^ Number of vertices.-  -> Bool   -- ^ Is right-side-up?-  -> AlphaColour Double-  -> CairoPointStyle-hollowPolygon radius w sides isrot cl = CairoPointStyle rf-  where rf p =-            do (Point x y ) <- alignp p-               c $ C.setLineWidth w-	       c $ setSourceColor cl-               c $ C.newPath-               let intToAngle n =-                         if isrot-                         then       fromIntegral n * 2*pi / fromIntegral sides-                         else (0.5 + fromIntegral n)*2*pi / fromIntegral sides-                   angles = map intToAngle [0 .. sides-1]-                   (p:ps) = map (\a -> Point (x + radius * sin a)-                                             (y + radius * cos a))-                                angles-               moveTo p-               mapM_ lineTo (ps++[p])-	       c $ C.stroke--filledPolygon ::-     Double -- ^ Radius of circle.-  -> Int    -- ^ Number of vertices.-  -> Bool   -- ^ Is right-side-up?-  -> AlphaColour Double-  -> CairoPointStyle-filledPolygon radius sides isrot cl = CairoPointStyle rf-  where rf p =-            do (Point x y ) <- alignp p-               c $ setSourceColor cl-               c $ C.newPath-               let intToAngle n =-                         if isrot-                         then       fromIntegral n * 2*pi/fromIntegral sides-                         else (0.5 + fromIntegral n)*2*pi/fromIntegral sides-                   angles = map intToAngle [0 .. sides-1]-                   (p:ps) = map (\a -> Point (x + radius * sin a)-                                             (y + radius * cos a)) angles-               moveTo p-               mapM_ lineTo (ps++[p])-	       c $ C.fill--plusses ::-     Double -- ^ Radius of circle.-  -> Double -- ^ Thickness of line.-  -> AlphaColour Double-  -> CairoPointStyle-plusses radius w cl = CairoPointStyle rf-  where rf p = do (Point x y ) <- alignp p-                  c $ C.setLineWidth w-	          c $ setSourceColor cl-                  c $ C.newPath-                  c $ C.moveTo (x+radius) y-                  c $ C.lineTo (x-radius) y-                  c $ C.moveTo x (y-radius)-                  c $ C.lineTo x (y+radius)-	          c $ C.stroke--exes ::-     Double -- ^ Radius of circle.-  -> Double -- ^ Thickness of line.-  -> AlphaColour Double-  -> CairoPointStyle-exes radius w cl = CairoPointStyle rf-  where rad = radius / sqrt 2-        rf p = do (Point x y ) <- alignp p-                  c $ C.setLineWidth w-	          c $ setSourceColor cl-                  c $ C.newPath-                  c $ C.moveTo (x+rad) (y+rad)-                  c $ C.lineTo (x-rad) (y-rad)-                  c $ C.moveTo (x+rad) (y-rad)-                  c $ C.lineTo (x-rad) (y+rad)-	          c $ C.stroke--stars ::-     Double -- ^ Radius of circle.-  -> Double -- ^ Thickness of line.-  -> AlphaColour Double-  -> CairoPointStyle-stars radius w cl = CairoPointStyle rf-  where rad = radius / sqrt 2-        rf p = do (Point x y ) <- alignp p-                  c $ C.setLineWidth w-	          c $ setSourceColor cl-                  c $ C.newPath-                  c $ C.moveTo (x+radius) y-                  c $ C.lineTo (x-radius) y-                  c $ C.moveTo x (y-radius)-                  c $ C.lineTo x (y+radius)-                  c $ C.moveTo (x+rad) (y+rad)-                  c $ C.lineTo (x-rad) (y-rad)-                  c $ C.moveTo (x+rad) (y-rad)-                  c $ C.lineTo (x-rad) (y+rad)-	          c $ C.stroke--solidLine ::-     Double -- ^ Width of line.-  -> AlphaColour Double-  -> CairoLineStyle-solidLine w cl = CairoLineStyle w cl [] C.LineCapButt C.LineJoinMiter--dashedLine ::-     Double   -- ^ Width of line.-  -> [Double] -- ^ The dash pattern in device coordinates.-  -> AlphaColour Double-  -> CairoLineStyle-dashedLine w ds cl = CairoLineStyle w cl ds C.LineCapButt C.LineJoinMiter--solidFillStyle ::-     AlphaColour Double-  -> CairoFillStyle-solidFillStyle cl = CairoFillStyle fn-   where fn = c $ setSourceColor cl--defaultPointStyle :: CairoPointStyle-defaultPointStyle = filledCircles 1 $ opaque white--defaultFontStyle :: CairoFontStyle-defaultFontStyle = CairoFontStyle {-   font_name_   = "sans",-   font_size_   = 10,-   font_slant_  = C.FontSlantNormal,-   font_weight_ = C.FontWeightNormal,-   font_color_  = opaque black-}--isValidNumber :: (RealFloat a) => a -> Bool-isValidNumber v = not (isNaN v) && not (isInfinite v)--maybeM :: (Monad m) => b -> (a -> m b) -> Maybe a -> m b-maybeM v = maybe (return v)--------------------------------------------------------------------------- Template haskell to derive an instance of Data.Accessor.Accessor--- for each field.-$( deriveAccessors ''CairoLineStyle )-$( deriveAccessors ''CairoFontStyle )-
+ Graphics/Rendering/Chart/Utils.hs view
@@ -0,0 +1,24 @@+-- | Non chart specific utility functions.+module Graphics.Rendering.Chart.Utils(+    isValidNumber,+    log10,+    maybeM,+    whenJust,+  ) where++-- | Checks if the given value is and actual numeric value and not+--   a concept like NaN or infinity.+isValidNumber :: (RealFloat a) => a -> Bool+isValidNumber v = not (isNaN v) && not (isInfinite v)++-- | Shorthand for the decimal logarithm+log10 :: (Floating a) => a -> a+log10 = logBase 10++-- | Version of 'Prelude.maybe' that returns a monadic value.+maybeM :: (Monad m) => b -> (a -> m b) -> Maybe a -> m b+maybeM v = maybe (return v)++-- | Specialization to ()+whenJust :: (Monad m) => Maybe a -> (a -> m ()) -> m ()+whenJust m f = maybeM () f m
+ Numeric/Histogram.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE PatternGuards #-}++module Numeric.Histogram ( Range+                         , binBounds+                         , histValues+                         , histWeightedValues+                         , histWithBins+                         ) where++import qualified Data.Vector as V+import qualified Data.Vector.Mutable as MV+import Control.Monad.ST++type Range a = (a,a)++-- | 'binBounds a b n' generates bounds for 'n' bins spaced linearly between+-- 'a' and 'b'+--+-- Examples:+--+-- >>> binBounds 0 3 4+-- [(0.0,0.75),(0.75,1.5),(1.5,2.25),(2.25,3.0)]+binBounds :: RealFrac a => a -> a -> Int -> [Range a]+binBounds a b n = map (\i->(lbound i, lbound (i+1))) [0..n-1]+        where lbound i = a + (b-a) * realToFrac i / realToFrac n++-- | 'histValues a b n vs' returns the bins for the histogram of+-- 'vs' on the range from 'a' to 'b' with 'n' bins+histValues :: RealFrac a => a -> a -> Int -> [a] -> V.Vector (Range a, Int)+histValues a b n = histWithBins (V.fromList $ binBounds a b n) . zip (repeat 1)++-- | 'histValues a b n vs' returns the bins for the weighted histogram of+-- 'vs' on the range from 'a' to 'b' with 'n' bins+histWeightedValues :: RealFrac a => a -> a -> Int -> [(Double,a)] -> V.Vector (Range a, Double)+histWeightedValues a b n = histWithBins (V.fromList $ binBounds a b n)++-- | 'histWithBins bins xs' is the histogram of weighted values 'xs' with 'bins'+--+-- Examples:+--+-- >>> :{+-- histWithBins+--     (V.fromList [(0.0, 0.75), (0.75, 1.5), (1.5, 2.25), (2.25, 3.0)])+--     [(1, 0), (1, 0), (1, 1), (1, 2), (1, 2), (1, 2), (1, 3)]+-- :}+-- [((0.0,0.75),2),((0.75,1.5),1),((1.5,2.25),3),((2.25,3.0),1)]+histWithBins :: (Num w, RealFrac a) => V.Vector (Range a) -> [(w, a)] -> V.Vector (Range a, w)+histWithBins bins xs =+    let n = V.length bins+        testBin :: RealFrac a => a -> (Int, Range a) -> Bool+        testBin x (i, (a,b)) =+            if i == n - 1+                then x >= a && x <= b+                else x >= a && x < b++        f :: (RealFrac a, Num w)+          => V.Vector (Range a) -> MV.STVector s w -> (w, a)+          -> ST s ()+        f bins1 bs (w,x) =+            case V.dropWhile (not . testBin x) $ V.indexed bins1 of+                v | V.null v  -> return ()+                v | (idx,_) <- V.head v  -> do+                    m <- MV.read bs idx+                    MV.write bs idx $! m+w++        counts = runST $ do b <- MV.replicate n 0+                            mapM_ (f bins b) xs+                            V.freeze b+    in V.zip bins counts
− tests/ExampleStocks.hs 
@@ -1,219 +0,0 @@-module ExampleStocks where-import Data.Time.Calendar-import Data.Time.LocalTime--mkDate :: Integer -> LocalTime-mkDate jday =-  LocalTime (ModifiedJulianDay jday) midnight---- Price data imported from Yahoo: low, open, close, high--pricesAAPL :: [(LocalTime,(Double,Double,Double,Double))]-pricesMSFT :: [(LocalTime,(Double,Double,Double,Double))]-pricesARMH :: [(LocalTime,(Double,Double,Double,Double))]--pricesAAPL = -    [ (mkDate 55105,(180.7,185.35,180.86,186.22))-    , (mkDate 55104,(182.61,186.13,185.35,186.45))-    , (mkDate 55103,(184.31,186.73,185.38,187.4))-    , (mkDate 55102,(183.33,183.87,186.15,186.68))-    , (mkDate 55099,(181.44,182.01,182.37,185.5))-    , (mkDate 55098,(182.77,187.2,183.82,187.7))-    , (mkDate 55097,(185.03,185.4,185.5,188.9))-    , (mkDate 55096,(182.85,185.19,184.48,185.38))-    , (mkDate 55095,(181.62,184.29,184.02,185.16))-    , (mkDate 55092,(184.76,185.83,185.02,186.55))-    , (mkDate 55091,(181.97,181.98,184.55,186.79))-    , (mkDate 55090,(177.88,177.99,181.87,182.75))-    , (mkDate 55089,(173.59,174.04,175.16,175.65))-    , (mkDate 55088,(170.25,170.83,173.72,173.9))-    , (mkDate 55085,(170.87,172.91,172.16,173.18))-    , (mkDate 55084,(170.81,172.06,172.56,173.25))-    , (mkDate 55083,(169.7,172.78,171.14,174.47))-    , (mkDate 55082,(172.0,172.98,172.93,173.14))-    , (mkDate 55078,(167.09,167.28,170.31,170.7))-    , (mkDate 55077,(165.0,166.44,166.55,167.1))-    , (mkDate 55076,(164.11,164.62,165.18,167.61))-    , (mkDate 55075,(164.94,167.99,165.3,170.0))-    , (mkDate 55074,(166.5,168.16,168.21,168.85))-    , (mkDate 55071,(168.53,172.27,170.05,172.49))-    , (mkDate 55070,(164.83,168.75,169.45,169.57))-    , (mkDate 55069,(166.76,168.92,167.41,169.55))-    , (mkDate 55068,(169.13,169.46,169.4,170.94))-    , (mkDate 55067,(168.27,170.12,169.06,170.71))-    , (mkDate 55064,(166.8,167.65,169.22,169.37))-    , (mkDate 55063,(164.61,164.98,166.33,166.72))-    , (mkDate 55062,(162.45,162.75,164.6,165.3))-    , (mkDate 55061,(161.41,161.63,164.0,164.24))-    , (mkDate 55060,(159.42,163.55,159.59,163.59))-    , (mkDate 55057,(165.53,167.94,166.78,168.23))-    , (mkDate 55056,(166.5,166.65,168.42,168.67))-    , (mkDate 55055,(162.46,162.55,165.31,166.71))-    , (mkDate 55054,(161.88,163.69,162.83,164.38))-    , (mkDate 55053,(163.66,165.66,164.72,166.6))-    , (mkDate 55050,(164.8,165.49,165.51,166.6))-    , (mkDate 55049,(163.09,165.58,163.91,166.51))-    , (mkDate 55048,(164.21,165.75,165.11,167.39))-    , (mkDate 55047,(164.21,164.93,165.55,165.57))-    , (mkDate 55046,(164.87,165.21,166.43,166.64))-    , (mkDate 55043,(162.91,162.99,163.39,165.0))-    , (mkDate 55042,(161.5,161.7,162.79,164.72))-    , (mkDate 55041,(158.25,158.9,160.03,160.45))-    , (mkDate 55040,(157.6,158.88,160.0,160.1))-    , (mkDate 55039,(157.26,160.17,160.1,160.88))-    , (mkDate 55036,(156.5,156.95,159.99,160.0))-    , (mkDate 55035,(155.56,156.63,157.82,158.44))-    , (mkDate 55034,(156.11,157.79,156.74,158.73))-    , (mkDate 55033,(149.75,153.29,151.51,153.43))-    , (mkDate 55032,(150.89,153.27,152.91,155.04))-    , (mkDate 55029,(148.63,149.08,151.75,152.02))-    , (mkDate 55028,(145.57,145.76,147.52,148.02))-    , (mkDate 55027,(144.32,145.04,146.88,147.0))-    , (mkDate 55026,(141.16,142.03,142.27,143.18))-    , (mkDate 55025,(137.53,139.54,142.34,142.34))-    , (mkDate 55022,(136.32,136.34,138.52,138.97))-    , (mkDate 55021,(135.93,137.76,136.36,137.99))-    , (mkDate 55020,(134.42,135.92,137.22,138.04))-    , (mkDate 55019,(135.18,138.48,135.4,139.68))-    , (mkDate 55018,(136.25,138.7,138.61,138.99))-    , (mkDate 55014,(139.79,141.25,140.02,142.83))-    , (mkDate 55013,(142.52,143.5,142.83,144.66))-    ]--pricesMSFT = -    [ (mkDate 55105,(24.8,25.41,24.88,25.47))-    , (mkDate 55104,(25.38,25.76,25.72,25.99))-    , (mkDate 55103,(25.69,25.91,25.75,25.96))-    , (mkDate 55102,(25.6,25.6,25.83,26.16))-    , (mkDate 55099,(25.52,25.69,25.55,25.82))-    , (mkDate 55098,(25.66,25.92,25.94,26.11))-    , (mkDate 55097,(25.64,25.92,25.71,26.25))-    , (mkDate 55096,(25.29,25.4,25.77,25.82))-    , (mkDate 55095,(25.1,25.11,25.3,25.37))-    , (mkDate 55092,(25.1,25.46,25.26,25.48))-    , (mkDate 55091,(25.06,25.06,25.3,25.38))-    , (mkDate 55090,(24.95,25.25,25.2,25.35))-    , (mkDate 55089,(24.86,24.97,25.2,25.27))-    , (mkDate 55088,(24.64,24.65,25.0,25.09))-    , (mkDate 55085,(24.81,24.93,24.86,25.17))-    , (mkDate 55084,(24.65,24.8,25.0,25.05))-    , (mkDate 55083,(24.67,24.74,24.78,24.95))-    , (mkDate 55082,(24.41,24.62,24.82,24.84))-    , (mkDate 55078,(24.08,24.09,24.62,24.8))-    , (mkDate 55077,(23.76,23.91,24.11,24.14))-    , (mkDate 55076,(23.78,23.82,23.86,24.14))-    , (mkDate 55075,(23.9,24.35,24.0,24.74))-    , (mkDate 55074,(24.29,24.57,24.65,24.85))-    , (mkDate 55071,(24.61,25.07,24.68,25.49))-    , (mkDate 55070,(24.3,24.41,24.69,24.78))-    , (mkDate 55069,(24.42,24.59,24.55,24.75))-    , (mkDate 55068,(24.46,24.6,24.64,24.82))-    , (mkDate 55067,(24.28,24.41,24.64,24.73))-    , (mkDate 55064,(23.77,23.93,24.41,24.42))-    , (mkDate 55063,(23.54,23.6,23.67,23.87))-    , (mkDate 55062,(23.25,23.25,23.65,23.72))-    , (mkDate 55061,(23.27,23.29,23.58,23.65))-    , (mkDate 55060,(23.23,23.32,23.25,23.6))-    , (mkDate 55057,(23.51,23.62,23.69,23.8))-    , (mkDate 55056,(23.4,23.63,23.62,23.85))-    , (mkDate 55055,(23.03,23.13,23.53,23.9))-    , (mkDate 55054,(23.05,23.32,23.13,23.4))-    , (mkDate 55053,(23.3,23.46,23.42,23.55))-    , (mkDate 55050,(23.5,23.75,23.56,23.82))-    , (mkDate 55049,(23.27,23.93,23.46,23.98))-    , (mkDate 55048,(23.79,23.84,23.81,24.25))-    , (mkDate 55047,(23.53,23.68,23.77,23.79))-    , (mkDate 55046,(23.5,23.82,23.83,23.86))-    , (mkDate 55043,(23.5,23.77,23.52,24.07))-    , (mkDate 55042,(23.71,24.2,23.81,24.43))-    , (mkDate 55041,(23.34,23.73,23.8,23.91))-    , (mkDate 55040,(22.9,22.99,23.47,23.55))-    , (mkDate 55039,(22.9,23.44,23.11,23.45))-    , (mkDate 55036,(22.81,23.61,23.45,23.89))-    , (mkDate 55035,(24.84,24.93,25.56,25.72))-    , (mkDate 55034,(24.51,24.7,24.8,24.9))-    , (mkDate 55033,(24.37,24.69,24.83,24.83))-    , (mkDate 55032,(24.15,24.44,24.53,24.53))-    , (mkDate 55029,(24.1,24.4,24.29,24.45))-    , (mkDate 55028,(23.86,23.93,24.44,24.44))-    , (mkDate 55027,(23.56,23.75,24.12,24.12))-    , (mkDate 55026,(22.86,23.2,23.11,23.22))-    , (mkDate 55025,(22.14,22.42,23.23,23.29))-    , (mkDate 55022,(22.15,22.19,22.39,22.54))-    , (mkDate 55021,(22.37,22.65,22.44,22.81))-    , (mkDate 55020,(22.0,22.31,22.56,22.69))-    , (mkDate 55019,(22.46,23.08,22.53,23.14))-    , (mkDate 55018,(22.87,23.21,23.2,23.28))-    , (mkDate 55014,(23.21,23.76,23.37,24.04))-    , (mkDate 55013,(23.96,24.05,24.04,24.3))-    ]--pricesARMH = -    [ (mkDate 55105,(6.65,6.83,6.65,6.86))-    , (mkDate 55104,(6.87,7.0,7.0,7.02))-    , (mkDate 55103,(6.88,6.92,6.95,6.97))-    , (mkDate 55102,(6.62,6.63,6.81,6.82))-    , (mkDate 55099,(6.69,6.88,6.72,6.88))-    , (mkDate 55098,(6.55,6.69,6.64,6.88))-    , (mkDate 55097,(6.8,6.87,6.8,6.94))-    , (mkDate 55096,(6.67,6.68,6.74,6.78))-    , (mkDate 55095,(6.62,6.67,6.7,6.77))-    , (mkDate 55092,(6.63,6.71,6.7,6.76))-    , (mkDate 55091,(6.64,6.7,6.67,6.76))-    , (mkDate 55090,(6.76,6.84,6.77,6.85))-    , (mkDate 55089,(6.69,6.73,6.84,6.9))-    , (mkDate 55088,(6.73,6.74,6.8,6.81))-    , (mkDate 55085,(6.84,7.05,6.87,7.07))-    , (mkDate 55084,(6.65,6.7,6.94,6.97))-    , (mkDate 55083,(6.65,6.71,6.7,6.75))-    , (mkDate 55082,(6.56,6.58,6.65,6.68))-    , (mkDate 55078,(6.16,6.18,6.39,6.41))-    , (mkDate 55077,(6.11,6.19,6.21,6.24))-    , (mkDate 55076,(6.03,6.07,6.09,6.14))-    , (mkDate 55075,(6.14,6.22,6.24,6.31))-    , (mkDate 55074,(6.3,6.45,6.35,6.45))-    , (mkDate 55071,(6.4,6.5,6.47,6.56))-    , (mkDate 55070,(6.13,6.18,6.35,6.39))-    , (mkDate 55069,(6.1,6.12,6.16,6.2))-    , (mkDate 55068,(6.14,6.3,6.17,6.3))-    , (mkDate 55067,(6.19,6.29,6.21,6.34))-    , (mkDate 55064,(6.25,6.32,6.3,6.38))-    , (mkDate 55063,(6.18,6.2,6.25,6.27))-    , (mkDate 55062,(6.09,6.11,6.19,6.22))-    , (mkDate 55061,(6.14,6.14,6.23,6.28))-    , (mkDate 55060,(5.91,6.02,5.98,6.04))-    , (mkDate 55057,(6.04,6.15,6.2,6.21))-    , (mkDate 55056,(6.1,6.18,6.22,6.26))-    , (mkDate 55055,(6.07,6.07,6.22,6.3))-    , (mkDate 55054,(6.09,6.23,6.14,6.23))-    , (mkDate 55053,(6.19,6.39,6.23,6.4))-    , (mkDate 55050,(6.25,6.31,6.32,6.41))-    , (mkDate 55049,(6.2,6.42,6.24,6.42))-    , (mkDate 55048,(6.4,6.55,6.46,6.55))-    , (mkDate 55047,(6.5,6.52,6.67,6.7))-    , (mkDate 55046,(6.5,6.51,6.58,6.6))-    , (mkDate 55043,(6.3,6.34,6.39,6.43))-    , (mkDate 55042,(6.42,6.47,6.46,6.64))-    , (mkDate 55041,(6.14,6.37,6.22,6.49))-    , (mkDate 55040,(6.28,6.32,6.52,6.56))-    , (mkDate 55039,(6.41,6.47,6.49,6.63))-    , (mkDate 55036,(6.27,6.36,6.44,6.44))-    , (mkDate 55035,(6.47,6.48,6.52,6.55))-    , (mkDate 55034,(6.38,6.41,6.47,6.51))-    , (mkDate 55033,(6.27,6.45,6.41,6.46))-    , (mkDate 55032,(6.32,6.44,6.45,6.48))-    , (mkDate 55029,(6.23,6.25,6.37,6.45))-    , (mkDate 55028,(6.24,6.29,6.35,6.39))-    , (mkDate 55027,(6.37,6.53,6.45,6.6))-    , (mkDate 55026,(6.12,6.13,6.19,6.23))-    , (mkDate 55025,(5.98,6.02,6.12,6.13))-    , (mkDate 55022,(5.93,5.96,6.08,6.12))-    , (mkDate 55021,(5.74,5.8,5.97,6.0))-    , (mkDate 55020,(5.61,5.74,5.69,5.82))-    , (mkDate 55019,(5.68,5.82,5.69,5.84))-    , (mkDate 55018,(5.77,5.84,5.91,5.93))-    , (mkDate 55014,(5.89,6.03,5.94,6.06))-    , (mkDate 55013,(5.93,5.98,5.95,6.03))-    ]--
− tests/Prices.hs 
@@ -1,392 +0,0 @@-module Prices where--import Data.Time.Calendar-import Data.Time.LocalTime--rawPrices = [-    (03,05,2005, 16.18, 42.02),-    (04,05,2005, 16.25, 42.31),-    (05,05,2005, 16.50, 42.95),-    (06,05,2005, 16.52, 43.50),-    (09,05,2005, 16.84, 44.91),-    (10,05,2005, 16.70, 44.55),-    (11,05,2005, 16.43, 43.63),-    (12,05,2005, 16.29, 43.18),-    (13,05,2005, 15.95, 42.40),-    (16,05,2005, 15.55, 41.65),-    (17,05,2005, 15.71, 42.17),-    (18,05,2005, 15.93, 42.37),-    (19,05,2005, 16.20, 42.85),-    (20,05,2005, 15.88, 42.30),-    (23,05,2005, 15.92, 42.53),-    (24,05,2005, 16.25, 42.81),-    (25,05,2005, 16.20, 42.67),-    (26,05,2005, 16.05, 42.35),-    (27,05,2005, 16.45, 43.12),-    (30,05,2005, 16.85, 43.24),-    (31,05,2005, 16.68, 42.57),-    (01,06,2005, 16.85, 43.22),-    (02,06,2005, 17.17, 43.85),-    (03,06,2005, 17.42, 44.15),-    (06,06,2005, 17.50, 44.07),-    (07,06,2005, 17.37, 43.76),-    (08,06,2005, 17.15, 43.21),-    (09,06,2005, 17.12, 43.42),-    (10,06,2005, 17.15, 43.27),-    (14,06,2005, 17.34, 43.30),-    (15,06,2005, 17.46, 43.90),-    (16,06,2005, 17.71, 44.43),-    (17,06,2005, 18.25, 45.45),-    (20,06,2005, 18.23, 45.16),-    (21,06,2005, 18.26, 45.54),-    (22,06,2005, 18.11, 45.06),-    (23,06,2005, 17.79, 44.65),-    (24,06,2005, 17.76, 44.43),-    (27,06,2005, 17.63, 44.22),-    (28,06,2005, 18.08, 44.94),-    (29,06,2005, 18.13, 44.80),-    (30,06,2005, 18.15, 44.82),-    (01,07,2005, 18.09, 45.12),-    (04,07,2005, 18.20, 45.20),-    (05,07,2005, 18.45, 45.85),-    (06,07,2005, 18.40, 45.91),-    (07,07,2005, 18.60, 46.35),-    (08,07,2005, 18.38, 45.76),-    (11,07,2005, 18.80, 46.41),-    (12,07,2005, 18.60, 45.86),-    (13,07,2005, 18.73, 46.00),-    (14,07,2005, 18.70, 46.44),-    (15,07,2005, 18.67, 46.25),-    (18,07,2005, 18.54, 45.77),-    (19,07,2005, 18.20, 45.21),-    (20,07,2005, 18.65, 46.13),-    (21,07,2005, 19.00, 46.87),-    (22,07,2005, 19.09, 47.32),-    (25,07,2005, 19.22, 47.36),-    (26,07,2005, 19.19, 47.66),-    (27,07,2005, 19.17, 47.64),-    (28,07,2005, 19.15, 47.98),-    (29,07,2005, 19.36, 49.12),-    (01,08,2005, 19.40, 49.30),-    (02,08,2005, 19.30, 49.17),-    (03,08,2005, 19.52, 49.91),-    (04,08,2005, 19.80, 50.60),-    (05,08,2005, 19.60, 50.40),-    (08,08,2005, 19.92, 50.94),-    (09,08,2005, 20.34, 52.09),-    (10,08,2005, 20.45, 51.42),-    (11,08,2005, 20.74, 52.30),-    (12,08,2005, 21.05, 53.01),-    (15,08,2005, 21.16, 53.02),-    (16,08,2005, 20.90, 52.74),-    (17,08,2005, 20.55, 51.93),-    (18,08,2005, 20.28, 51.42),-    (19,08,2005, 20.68, 52.20),-    (22,08,2005, 21.22, 53.10),-    (23,08,2005, 21.07, 53.01),-    (24,08,2005, 20.56, 52.72),-    (25,08,2005, 19.90, 50.45),-    (26,08,2005, 20.60, 51.42),-    (29,08,2005, 20.03, 50.10),-    (30,08,2005, 20.47, 50.74),-    (31,08,2005, 20.46, 50.31),-    (01,09,2005, 20.93, 51.80),-    (02,09,2005, 20.83, 51.60),-    (05,09,2005, 20.46, 51.56),-    (06,09,2005, 20.25, 50.60),-    (07,09,2005, 20.55, 51.54),-    (08,09,2005, 20.03, 50.55),-    (09,09,2005, 20.19, 50.90),-    (12,09,2005, 20.20, 51.27),-    (13,09,2005, 20.47, 51.91),-    (14,09,2005, 20.59, 51.59),-    (15,09,2005, 20.70, 52.44),-    (16,09,2005, 20.99, 53.77),-    (19,09,2005, 21.39, 55.45),-    (20,09,2005, 21.53, 55.88),-    (21,09,2005, 20.89, 54.63),-    (22,09,2005, 21.41, 55.50),-    (23,09,2005, 21.30, 55.56),-    (26,09,2005, 21.86, 57.55),-    (27,09,2005, 22.01, 58.56),-    (28,09,2005, 21.81, 58.26),-    (29,09,2005, 22.48, 60.01),-    (30,09,2005, 22.25, 59.14),-    (03,10,2005, 22.30, 58.93),-    (04,10,2005, 22.20, 58.61),-    (05,10,2005, 21.45, 57.10),-    (06,10,2005, 20.76, 56.30),-    (07,10,2005, 20.47, 56.50),-    (10,10,2005, 20.72, 57.25),-    (11,10,2005, 20.33, 57.00),-    (12,10,2005, 20.83, 57.48),-    (13,10,2005, 20.47, 56.69),-    (14,10,2005, 19.98, 55.21),-    (17,10,2005, 20.05, 55.95),-    (18,10,2005, 20.75, 57.90),-    (19,10,2005, 20.05, 56.19),-    (20,10,2005, 20.01, 56.30),-    (21,10,2005, 20.03, 55.82),-    (24,10,2005, 19.77, 54.27),-    (25,10,2005, 20.09, 54.82),-    (26,10,2005, 20.42, 55.58),-    (27,10,2005, 20.49, 55.80),-    (28,10,2005, 20.10, 54.94),-    (31,10,2005, 20.75, 56.31),-    (01,11,2005, 20.89, 57.00),-    (02,11,2005, 20.70, 57.11),-    (03,11,2005, 21.28, 58.39),-    (04,11,2005, 21.35, 58.60),-    (07,11,2005, 21.09, 58.18),-    (08,11,2005, 21.35, 59.80),-    (09,11,2005, 21.03, 59.25),-    (10,11,2005, 21.11, 59.21),-    (11,11,2005, 21.12, 59.71),-    (14,11,2005, 21.60, 61.24),-    (15,11,2005, 21.53, 60.96),-    (16,11,2005, 21.42, 60.60),-    (17,11,2005, 21.40, 60.79),-    (18,11,2005, 21.85, 62.45),-    (21,11,2005, 21.71, 62.60),-    (22,11,2005, 21.67, 61.70),-    (23,11,2005, 21.55, 60.70),-    (24,11,2005, 21.86, 61.89),-    (25,11,2005, 22.02, 62.21),-    (28,11,2005, 22.22, 62.09),-    (29,11,2005, 21.83, 61.35),-    (30,11,2005, 21.87, 61.76),-    (01,12,2005, 21.50, 60.40),-    (02,12,2005, 21.95, 61.92),-    (05,12,2005, 22.03, 63.33),-    (06,12,2005, 21.83, 62.99),-    (07,12,2005, 21.85, 63.84),-    (08,12,2005, 21.56, 63.10),-    (09,12,2005, 21.80, 63.55),-    (12,12,2005, 21.92, 63.60),-    (13,12,2005, 21.65, 63.35),-    (14,12,2005, 21.72, 63.15),-    (15,12,2005, 21.69, 63.16),-    (16,12,2005, 21.60, 62.63),-    (19,12,2005, 21.87, 63.81),-    (20,12,2005, 22.10, 65.50),-    (21,12,2005, 22.50, 67.18),-    (22,12,2005, 22.49, 67.75),-    (23,12,2005, 22.58, 68.50),-    (28,12,2005, 22.59, 68.25),-    (29,12,2005, 22.93, 69.10),-    (30,12,2005, 22.75, 69.00),-    (03,01,2006, 23.18, 69.90),-    (04,01,2006, 23.85, 71.06),-    (05,01,2006, 23.60, 69.80),-    (06,01,2006, 23.35, 68.80),-    (09,01,2006, 24.06, 70.18),-    (10,01,2006, 23.85, 69.15),-    (11,01,2006, 23.88, 69.35),-    (12,01,2006, 23.80, 70.19),-    (13,01,2006, 23.73, 70.50),-    (16,01,2006, 23.74, 71.05),-    (17,01,2006, 23.96, 71.94),-    (18,01,2006, 23.73, 70.25),-    (19,01,2006, 24.45, 72.50),-    (20,01,2006, 24.66, 74.00),-    (23,01,2006, 24.47, 73.25),-    (24,01,2006, 24.84, 74.25),-    (25,01,2006, 25.08, 73.96),-    (27,01,2006, 26.05, 76.10),-    (30,01,2006, 26.58, 78.45),-    (31,01,2006, 25.80, 75.82),-    (01,02,2006, 25.99, 75.21),-    (02,02,2006, 25.50, 74.98),-    (03,02,2006, 25.53, 74.75),-    (06,02,2006, 25.85, 75.57),-    (07,02,2006, 25.70, 75.06),-    (08,02,2006, 24.37, 72.75),-    (09,02,2006, 24.68, 72.77),-    (13,02,2006, 23.88, 70.95),-    (14,02,2006, 24.16, 72.37),-    (15,02,2006, 24.35, 71.84),-    (16,02,2006, 24.29, 71.89),-    (17,02,2006, 23.88, 71.65),-    (20,02,2006, 24.54, 74.90),-    (21,02,2006, 24.98, 75.50),-    (22,02,2006, 24.90, 73.24),-    (23,02,2006, 25.28, 74.69),-    (24,02,2006, 24.55, 72.20),-    (27,02,2006, 24.66, 73.00),-    (28,02,2006, 24.25, 71.20),-    (01,03,2006, 24.03, 70.25),-    (02,03,2006, 24.45, 70.50),-    (03,03,2006, 24.34, 70.35),-    (06,03,2006, 24.51, 70.85),-    (08,03,2006, 23.60, 67.95),-    (09,03,2006, 23.70, 68.65),-    (10,03,2006, 23.37, 67.50),-    (13,03,2006, 23.93, 70.36),-    (14,03,2006, 23.64, 69.45),-    (15,03,2006, 23.90, 69.40),-    (16,03,2006, 24.46, 70.90),-    (17,03,2006, 24.70, 71.25),-    (20,03,2006, 25.24, 72.85),-    (21,03,2006, 25.32, 73.08),-    (22,03,2006, 25.18, 72.99),-    (23,03,2006, 25.57, 74.34),-    (24,03,2006, 25.92, 75.23),-    (27,03,2006, 26.78, 77.05),-    (28,03,2006, 26.85, 77.13),-    (30,03,2006, 27.60, 77.96),-    (31,03,2006, 28.00, 78.85),-    (03,01,2007, 23.18, 69.90),-    (04,01,2007, 23.85, 71.06),-    (05,01,2007, 23.60, 69.80),-    (06,01,2007, 23.35, 68.80),-    (09,01,2007, 24.06, 70.18),-    (10,01,2007, 23.85, 69.15),-    (11,01,2007, 23.88, 69.35),-    (12,01,2007, 23.80, 70.19),-    (13,01,2007, 23.73, 70.50),-    (16,01,2007, 23.74, 71.05),-    (17,01,2007, 23.96, 71.94),-    (18,01,2007, 23.73, 70.25),-    (19,01,2007, 24.45, 72.50),-    (20,01,2007, 24.66, 74.00),-    (23,01,2007, 24.47, 73.25),-    (24,01,2007, 24.84, 74.25),-    (25,01,2007, 25.08, 73.96),-    (27,01,2007, 26.05, 76.10),-    (30,01,2007, 26.58, 78.45),-    (31,01,2007, 25.80, 75.82),-    (01,02,2007, 25.99, 75.21),-    (02,02,2007, 25.50, 74.98),-    (03,02,2007, 25.53, 74.75),-    (06,02,2007, 25.85, 75.57),-    (07,02,2007, 25.70, 75.06),-    (08,02,2007, 24.37, 72.75),-    (09,02,2007, 24.68, 72.77),-    (13,02,2007, 23.88, 70.95),-    (14,02,2007, 24.16, 72.37),-    (15,02,2007, 24.35, 71.84),-    (16,02,2007, 24.29, 71.89),-    (17,02,2007, 23.88, 71.65),-    (20,02,2007, 24.54, 74.90),-    (21,02,2007, 24.98, 75.50),-    (22,02,2007, 24.90, 73.24),-    (23,02,2007, 25.28, 74.69),-    (24,02,2007, 24.55, 72.20),-    (27,02,2007, 24.66, 73.00),-    (28,02,2007, 24.25, 71.20),-    (01,03,2007, 24.03, 70.25),-    (02,03,2007, 24.45, 70.50),-    (03,03,2007, 24.34, 70.35),-    (06,03,2007, 24.51, 70.85),-    (08,03,2007, 23.60, 67.95),-    (09,03,2007, 23.70, 68.65),-    (10,03,2007, 23.37, 67.50),-    (13,03,2007, 23.93, 70.36),-    (14,03,2007, 23.64, 69.45),-    (15,03,2007, 23.90, 69.40),-    (16,03,2007, 24.46, 70.90),-    (17,03,2007, 24.70, 71.25),-    (20,03,2007, 25.24, 72.85),-    (21,03,2007, 25.32, 73.08),-    (22,03,2007, 25.18, 72.99),-    (23,03,2007, 25.57, 74.34),-    (24,03,2007, 25.92, 75.23),-    (27,03,2007, 26.78, 77.05),-    (28,03,2007, 26.85, 77.13),-    (30,03,2007, 27.60, 77.96),-    (31,03,2007, 28.00, 78.85)-    ]--rawHourly = [-    (03,05,2005,00, 16.18, 42.02),-    (03,05,2005,01, 16.25, 42.31),-    (03,05,2005,02, 16.50, 42.95),-    (03,05,2005,03, 16.52, 43.50),-    (03,05,2005,04, 16.84, 44.91),-    (03,05,2005,05, 16.70, 44.55),-    (03,05,2005,06, 16.43, 43.63),-    (03,05,2005,07, 16.29, 43.18),-    (03,05,2005,08, 15.95, 42.40),-    (03,05,2005,09, 15.55, 41.65),-    (03,05,2005,10, 15.71, 42.17),-    (03,05,2005,11, 15.93, 42.37),-    (03,05,2005,12, 16.20, 42.85),-    (03,05,2005,13, 15.88, 42.30),-    (03,05,2005,14, 15.92, 42.53),-    (03,05,2005,15, 16.25, 42.81),-    (03,05,2005,16, 16.20, 42.67),-    (03,05,2005,17, 16.05, 42.35),-    (03,05,2005,18, 16.45, 43.12),-    (03,05,2005,19, 16.85, 43.24),-    (03,05,2005,20, 16.68, 42.57),-    (03,05,2005,21, 16.85, 43.22),-    (03,05,2005,22, 17.17, 43.85),-    (03,05,2005,23, 17.42, 44.15),-    (04,05,2005,00, 17.50, 44.07),-    (04,05,2005,01, 17.37, 43.76),-    (04,05,2005,02, 17.15, 43.21),-    (04,05,2005,03, 17.12, 43.42),-    (04,05,2005,04, 17.15, 43.27),-    (04,05,2005,05, 17.34, 43.30),-    (04,05,2005,06, 17.46, 43.90),-    (04,05,2005,07, 17.71, 44.43),-    (04,05,2005,08, 18.25, 45.45),-    (04,05,2005,09, 18.23, 45.16),-    (04,05,2005,10, 18.26, 45.54),-    (04,05,2005,11, 18.11, 45.06),-    (04,05,2005,12, 17.79, 44.65)-    ]--prices :: [(LocalTime,Double,Double)]-prices = [ (mkDate dd mm yyyy, p1, p2) | (dd,mm,yyyy,p1,p2) <- rawPrices ]--hourlyPrices :: [(LocalTime,Double,Double)]-hourlyPrices = [ (mkDateTime dd mm yyyy hh 00, p1, p2)-               | (dd,mm,yyyy,hh,p1,p2) <- rawHourly ]--minutePrices :: [(LocalTime,Double,Double)]-minutePrices = [ (mkDateTime dd mm yyyy 05 hh, p1, p2)-               | (dd,mm,yyyy,hh,p1,p2) <- take 24 rawHourly ]-            ++ [ (mkDateTime dd mm yyyy 05 (hh+24), p1, p2)-               | (dd,mm,yyyy,hh,p1,p2) <- take 24 rawHourly ]--secondPrices :: [(LocalTime,Double,Double)]-secondPrices = [ (mkSeconds ss, p1, p2)-               | (ss,(_,_,_,p1,p2)) <- zip [0..] rawPrices ]--filterPrices prices t1 t2 = [ v | v@(d,_,_) <- prices-                                , let t = d in t >= t1 && t <= t2]--prices1 = filterPrices prices (mkDate 1 1 2005) (mkDate 31 12 2005)-prices2 = filterPrices prices (mkDate 1 6 2005) (mkDate 1 9 2005)-prices3 = filterPrices prices (mkDate 1 1 2006) (mkDate 10 1 2006)-prices4 = filterPrices prices (mkDate 1 8 2005) (mkDate 31 8 2005)-prices5 = filterPrices prices (mkDate 1 6 2005) (mkDate 15 7 2005)-prices6 = filterPrices prices (mkDate 1 6 2005) (mkDate 2  7 2005)-prices7 = filterPrices prices (mkDate 20 6 2005) (mkDate 12 7 2005)-prices8 = filterPrices prices (mkDate 6 6 2005) (mkDate 9  6 2005)-prices9 = filterPrices prices (mkDate 6 6 2005) (mkDate 8  6 2005)-prices10 = hourlyPrices-prices10a = take 31 hourlyPrices-prices10b = take 15 hourlyPrices-prices11 = filterPrices hourlyPrices (mkDateTime 3 5 2005 02 30)-                                     (mkDateTime 4 5 2005 02 30)-prices12 = filterPrices hourlyPrices (mkDateTime 3 5 2005 02 30)-                                     (mkDateTime 3 5 2005 06 30)-prices13  = minutePrices-prices13a = take 24 minutePrices-prices13b = take 16 minutePrices-prices14  = secondPrices-prices14a = take 90 secondPrices-prices14b = take 35 secondPrices-prices14c = take 30 secondPrices-prices14d = take  7 secondPrices--mkDate dd mm yyyy =-    LocalTime (fromGregorian (fromIntegral yyyy) mm dd) midnight-mkDateTime dd mm yyyy hh nn =-    LocalTime (fromGregorian (fromIntegral yyyy) mm dd)-              (dayFractionToTimeOfDay ((hh*60+nn)/1440))-mkSeconds ss = LocalTime (fromGregorian (fromIntegral 2009) 11 23)-                         (dayFractionToTimeOfDay (((14*60+32)*60+ss)/(1440*60)))-
− tests/Test1.hs 
@@ -1,39 +0,0 @@-module Test1 where --import Graphics.Rendering.Chart-import Data.Colour-import Data.Colour.Names-import Data.Colour.SRGB-import Data.Accessor-import System.Environment(getArgs)--chart lwidth = toRenderable (layout lwidth)--layout :: Double -> Layout1 Double Double-layout lwidth = layout1-  where-    layout1 = layout1_title ^= "Amplitude Modulation"-            $ layout1_plots ^= [Left (toPlot sinusoid1),-			       Left (toPlot sinusoid2)]-            $ layout1_plot_background ^= Just (solidFillStyle $ opaque white)-            $ defaultLayout1--    am x = (sin (x*pi/45) + 1) / 2 * (sin (x*pi/5))--    sinusoid1 = plot_lines_values ^= [[ (x,(am x)) | x <- [0,(0.5)..400]]]-              $ plot_lines_style  ^= solidLine lwidth (opaque blue)-              $ plot_lines_title ^="am"-              $ defaultPlotLines--    sinusoid2 = plot_points_style ^= filledCircles 2 (opaque red)-              $ plot_points_values ^= [ (x,(am x)) | x <- [0,7..400]]-              $ plot_points_title ^="am points"-              $ defaultPlotPoints--main1 :: [String] -> IO (PickFn ())-main1 ["small"]  = renderableToPNGFile (chart 0.25) 320 240 "test1_small.png"-main1 ["big"]    = renderableToPNGFile (chart 0.25) 800 600 "test1_big.png"--main = getArgs >>= main1--
− tests/Test14.hs 
@@ -1,46 +0,0 @@-module Test14 where --import Graphics.Rendering.Chart-import Data.Colour-import Data.Colour.Names-import Data.Accessor-import System.Random-import System.Environment(getArgs)-import Prices(prices1)---- demonstrate AreaSpots--chart :: Double -> Renderable ()-chart lwidth = toRenderable layout-  where-    layout = layout1_title ^="Price History"-           $ layout1_background ^= solidFillStyle (opaque white)-           $ layout1_left_axis ^: laxis_override ^= axisTicksHide- 	   $ layout1_plots ^= [ Left (toPlot price1), Left (toPlot spots) ]-           $ setLayout1Foreground (opaque black)-           $ defaultLayout1--    price1 = plot_lines_style ^= lineStyle-           $ plot_lines_values ^= [[ (d, v) | (d,v,_) <- prices1]]-           $ plot_lines_title ^= "price 1"-           $ defaultPlotLines--    spots = area_spots_title ^= "random value"-          $ area_spots_max_radius ^= 20-          $ area_spots_values ^= values-          $ defaultAreaSpots-    -    points = map (\ (d,v,z)-> (d,v) ) values-    values = [ (d, v, z) | ((d,v,_),z) <- zip prices1 zs ]-    zs    :: [Int]-    zs     = randoms $ mkStdGen 0--    lineStyle = line_width ^= 3 * lwidth-              $ line_color ^= opaque blue-              $ defaultPlotLines ^. plot_lines_style--main1 :: [String] -> IO (PickFn ())-main1 ["small"]  = renderableToPNGFile (chart 0.25) 320 240 "test14_small.png"-main1 ["big"]    = renderableToPNGFile (chart 0.25) 800 600 "test14_big.png"--main = getArgs >>= main1
− tests/Test14a.hs 
@@ -1,48 +0,0 @@-module Test14a where --import Graphics.Rendering.Chart-import Graphics.Rendering.Chart.Plot-import Data.Colour-import Data.Colour.Names-import Data.Accessor-import System.Random-import System.Environment(getArgs)-import Prices(prices1)---- demonstrate AreaSpots4D--chart :: Double -> Renderable ()-chart lwidth = toRenderable layout-  where-    layout = layout1_title ^="Price History"-           $ layout1_background ^= solidFillStyle (opaque white)-           $ layout1_left_axis ^: laxis_override ^= axisTicksHide- 	   $ layout1_plots ^= [ Left (toPlot price1), Left (toPlot spots) ]-           $ setLayout1Foreground (opaque black)-           $ defaultLayout1--    price1 = plot_lines_style ^= lineStyle-           $ plot_lines_values ^= [[ (d, v) | (d,v,_) <- prices1]]-           $ plot_lines_title ^= "price 1"-           $ defaultPlotLines--    spots = area_spots_4d_title ^= "random value"-          $ area_spots_4d_max_radius ^= 20-          $ area_spots_4d_values ^= values-          $ defaultAreaSpots4D-    -    points = map (\ (d,v,z,t)-> (d,v) ) values-    values = [ (d, v, z, t) | ((d,v,_),z,t) <- zip3 prices1 zs ts ]-    zs,ts :: [Int]-    zs     = randoms $ mkStdGen 0-    ts     = randomRs (-2,27) $ mkStdGen 1--    lineStyle = line_width ^= 3 * lwidth-              $ line_color ^= opaque blue-              $ defaultPlotLines ^. plot_lines_style--main1 :: [String] -> IO (PickFn ())-main1 ["small"]  = renderableToPNGFile (chart 0.25) 320 240 "test14_small.png"-main1 ["big"]    = renderableToPNGFile (chart 0.25) 800 600 "test14_big.png"--main = getArgs >>= main1
− tests/Test15.hs 
@@ -1,43 +0,0 @@-module Test15 where --import Graphics.Rendering.Chart-import Data.Colour-import Data.Colour.Names-import Data.Accessor-import System.Environment(getArgs)--chart lo = toRenderable layout- where-  layout = -        layout1_title ^= "Legend Test"-      $ layout1_title_style ^: font_size ^= 10-      $ layout1_bottom_axis ^: laxis_generate ^= autoIndexAxis alabels-      $ layout1_left_axis ^: laxis_override ^= (axisGridHide.axisTicksHide)-      $ layout1_plots ^= [ Left (plotBars bars2) ]-      $ layout1_legend ^= Just lstyle-      $ defaultLayout1 :: Layout1 PlotIndex Double--  bars2 = plot_bars_titles ^= ["A","B","C","D","E","F","G","H","I","J"]-      $ plot_bars_values ^= addIndexes [[2,3,4,2,1,5,6,4,8,1,3],-                                        [7,4,5,6,2,4,4,5,7,8,9]-                                       ]-      $ plot_bars_style ^= BarsClustered-      $ plot_bars_spacing ^= BarsFixGap 30 5-      $ plot_bars_item_styles ^= map mkstyle (cycle defaultColorSeq)-      $ defaultPlotBars--  alabels = [ "X", "Y" ]--  lstyle = legend_orientation ^= lo-         $ defaultLegendStyle--  btitle = ""-  mkstyle c = (solidFillStyle c, Nothing)--main1 :: [String] -> IO (PickFn ())-main1 ["small"]  = renderableToPNGFile (chart (LORows 3)) 320 240 "test15_small.png"-main1 ["big"]    = renderableToPNGFile (chart (LORows 3)) 800 600 "test15_big.png"--main = getArgs >>= main1--
− tests/Test17.hs 
@@ -1,80 +0,0 @@-module Test17 where --import Graphics.Rendering.Chart-import Data.Colour-import Data.Colour.Names-import Data.Accessor-import System.Random-import System.Environment(getArgs)-import ExampleStocks---- demonstrate Candles--chart :: Double -> Renderable ()-chart lwidth = toRenderable layout-  where-    layout = layout1_title ^="Stock Prices"-           $ layout1_background ^= solidFillStyle (opaque white)-           $ layout1_left_axis ^: laxis_override ^= axisTicksHide- 	   $ layout1_plots ^= [ Right (toPlot msftArea)-                              , Right (toPlot msftLine)-                              , Right (toPlot msftCandle)-                              , Left  (toPlot aaplArea)-                              , Left  (toPlot aaplLine)-                              , Left  (toPlot aaplCandle) ]-           $ setLayout1Foreground (opaque black)-           $ defaultLayout1--    aaplLine = plot_lines_style  ^= lineStyle 2 green-             $ plot_lines_values ^= [[ (d, cl)-                                     | (d,(lo,op,cl,hi)) <- pricesAAPL]]-             $ plot_lines_title  ^= "AAPL closing"-             $ defaultPlotLines--    msftLine = plot_lines_style  ^= lineStyle 2 purple-             $ plot_lines_values ^= [[ (d, cl)-                                     | (d,(lo,op,cl,hi)) <- pricesMSFT]]-             $ plot_lines_title  ^= "MSFT closing"-             $ defaultPlotLines--    aaplArea = plot_fillbetween_style  ^= solidFillStyle (withOpacity green 0.4)-             $ plot_fillbetween_values ^= [ (d, (lo,hi))-                                          | (d,(lo,op,cl,hi)) <- pricesAAPL]-             $ plot_fillbetween_title  ^= "AAPL spread"-             $ defaultPlotFillBetween--    msftArea = plot_fillbetween_style ^= solidFillStyle (withOpacity purple 0.4)-             $ plot_fillbetween_values ^= [ (d, (lo,hi))-                                          | (d,(lo,op,cl,hi)) <- pricesMSFT]-             $ plot_fillbetween_title  ^= "MSFT spread"-             $ defaultPlotFillBetween--    aaplCandle = plot_candle_line_style  ^= lineStyle 1 blue-               $ plot_candle_fill        ^= True-               $ plot_candle_tick_length ^= 0-               $ plot_candle_width       ^= 2-               $ plot_candle_values      ^= [ Candle d lo op 0 cl hi-                                            | (d,(lo,op,cl,hi)) <- pricesAAPL]-               $ plot_candle_title       ^= "AAPL candle"-               $ defaultPlotCandle--    msftCandle = plot_candle_line_style  ^= lineStyle 1 red-               $ plot_candle_fill        ^= True-               $ plot_candle_rise_fill_style ^= solidFillStyle (opaque pink)-               $ plot_candle_fall_fill_style ^= solidFillStyle (opaque red)-               $ plot_candle_tick_length ^= 0-               $ plot_candle_width       ^= 2-               $ plot_candle_values      ^= [ Candle d lo op 0 cl hi-                                            | (d,(lo,op,cl,hi)) <- pricesMSFT]-               $ plot_candle_title       ^= "MSFT candle"-               $ defaultPlotCandle--    lineStyle n colour = line_width ^= n * lwidth-                       $ line_color ^= opaque colour-                       $ defaultPlotLines ^. plot_lines_style--main1 :: [String] -> IO (PickFn ())-main1 ["small"]  = renderableToPNGFile (chart 0.25) 320 240 "test1_small.png"-main1 ["big"]    = renderableToPNGFile (chart 0.25) 800 600 "test1_big.png"--main = getArgs >>= main1
− tests/Test2.hs 
@@ -1,62 +0,0 @@-module Test2 where--import Graphics.Rendering.Chart-import Data.Time.LocalTime-import Data.Colour-import Data.Colour.Names-import Data.Colour.SRGB-import Data.Accessor-import System.Environment(getArgs)-import Prices(prices2)--chart :: [(LocalTime,Double,Double)] -> Bool -> Double -> Renderable ()-chart prices showMinMax lwidth = toRenderable layout-  where--    lineStyle c = line_width ^= 3 * lwidth-                $ line_color ^= c-                $ defaultPlotLines ^. plot_lines_style--    limitLineStyle c = line_width ^= lwidth-                $ line_color ^= opaque c-                $ line_dashes ^= [5,10]-                $ defaultPlotLines ^. plot_lines_style--    price1 = plot_lines_style ^= lineStyle (opaque blue)-           $ plot_lines_values ^= [[ (d, v) | (d,v,_) <- prices]]-           $ plot_lines_title ^= "price 1"-           $ defaultPlotLines--    price2 = plot_lines_style ^= lineStyle (opaque green)-	   $ plot_lines_values ^= [[ (d, v) | (d,_,v) <- prices]]-           $ plot_lines_title ^= "price 2"-           $ defaultPlotLines--    (min1,max1) = (minimum [v | (_,v,_) <- prices],maximum [v | (_,v,_) <- prices])-    (min2,max2) = (minimum [v | (_,_,v) <- prices],maximum [v | (_,_,v) <- prices])-    limits | showMinMax = [ Left $ hlinePlot "min/max" (limitLineStyle blue) min1,-                            Left $ hlinePlot "" (limitLineStyle blue) max1,-                            Right $ hlinePlot "min/max" (limitLineStyle green) min2,-                            Right $ hlinePlot "" (limitLineStyle green) max2 ]-           | otherwise  = []--    bg = opaque $ sRGB 0 0 0.25-    fg = opaque white-    fg1 = opaque $ sRGB 0.0 0.0 0.15--    layout = layout1_title ^="Price History"-           $ layout1_background ^= solidFillStyle bg-           $ updateAllAxesStyles (axis_grid_style ^= solidLine 1 fg1)-           $ layout1_left_axis ^: laxis_override ^= axisGridHide-           $ layout1_right_axis ^: laxis_override ^= axisGridHide-           $ layout1_bottom_axis ^: laxis_override ^= axisGridHide- 	   $ layout1_plots ^= ([Left (toPlot price1), Right (toPlot price2)] ++ limits)-           $ layout1_grid_last ^= False-           $ setLayout1Foreground fg-           $ defaultLayout1--main1 :: [String] -> IO (PickFn ())-main1 ["small"]  = renderableToPNGFile (chart prices2 True 0.25) 320 240 "test2_small.png"-main1 ["big"]    = renderableToPNGFile (chart prices2 True 0.25) 800 600 "test2_big.png"--main = getArgs >>= main1
− tests/Test3.hs 
@@ -1,38 +0,0 @@-module Test3 where--import Graphics.Rendering.Chart-import Data.Time.LocalTime-import Data.Colour-import Data.Colour.Names-import Data.Colour.SRGB-import Data.Accessor-import System.Environment(getArgs)-import Prices(prices1)--green1 = opaque $ sRGB 0.5 1 0.5-blue1 = opaque $ sRGB 0.5 0.5 1--chart = toRenderable layout-  where-    price1 = plot_fillbetween_style ^= solidFillStyle green1-           $ plot_fillbetween_values ^= [ (d,(0,v2)) | (d,v1,v2) <- prices1]-           $ plot_fillbetween_title ^= "price 1"-           $ defaultPlotFillBetween--    price2 = plot_fillbetween_style ^= solidFillStyle blue1-           $ plot_fillbetween_values ^= [ (d,(0,v1)) | (d,v1,v2) <- prices1]-           $ plot_fillbetween_title ^= "price 2"-           $ defaultPlotFillBetween--    layout = layout1_title ^= "Price History"-           $ layout1_grid_last ^= True- 	   $ layout1_plots ^= [Left (toPlot price1),-                               Left (toPlot price2)]-           $ defaultLayout1---main1 :: [String] -> IO (PickFn ())-main1 ["small"]  = renderableToPNGFile chart 320 240 "test3_small.png"-main1 ["big"]    = renderableToPNGFile chart 800 600 "test3_big.png"--main = getArgs >>= main1
− tests/Test4.hs 
@@ -1,37 +0,0 @@-module Test4 where --import Graphics.Rendering.Chart-import Data.Colour-import Data.Colour.Names-import Data.Accessor-import System.Environment(getArgs)--chart :: Bool -> Bool -> Renderable ()-chart xrev yrev = toRenderable layout-  where--    points = plot_points_style ^= filledCircles 3 (opaque red)-           $ plot_points_values ^= [ (x, 10**x) | x <- [0.5,1,1.5,2,2.5 :: Double] ]-           $ plot_points_title ^= "values"-           $ defaultPlotPoints--    lines = plot_lines_values ^= [ [(x, 10**x) | x <- [0,3]] ]-          $ plot_lines_title ^= "values"-          $ defaultPlotLines--    layout = layout1_title ^= "Log/Linear Example"-           $ layout1_bottom_axis ^: laxis_title ^= "horizontal"-           $ layout1_bottom_axis ^: laxis_reverse ^= xrev-           $ layout1_left_axis ^: laxis_generate ^= autoScaledLogAxis defaultLogAxis-           $ layout1_left_axis ^: laxis_title ^= "vertical"-           $ layout1_left_axis ^: laxis_reverse ^= yrev-	   $ layout1_plots ^= [Left (toPlot points), Left (toPlot lines) ]-           $ defaultLayout1--main1 :: [String] -> IO (PickFn ())-main1 ["small"]  = renderableToPNGFile (chart False False) 320 240 "test4_small.png"-main1 ["big"]    = renderableToPNGFile (chart False False) 800 600 "test4_big.png"--main = getArgs >>= main1--
− tests/Test5.hs 
@@ -1,48 +0,0 @@-module Test5 where --import Graphics.Rendering.Chart-import Data.Colour-import Data.Colour.Names-import Data.Accessor-import System.Random-import System.Environment(getArgs)--------------------------------------------------------------------------- Example thanks to Russell O'Connor--chart :: Double -> Renderable ()-chart lwidth = toRenderable (layout 1001 (trial bits) :: Layout1 Double LogValue)-  where-    bits = randoms $ mkStdGen 0--    layout n t = layout1_title ^= "Simulation of betting on a biased coin"-               $ layout1_plots ^= [-                      Left (toPlot (plot "f=0.05" s1 n 0 (t 0.05))),-                      Left (toPlot (plot "f=0.1" s2 n 0 (t 0.1)))-                     ]-               $ defaultLayout1--    plot tt s n m t = plot_lines_style ^= s-                 $ plot_lines_values ^=-                       [[(fromIntegral x, LogValue y) | (x,y) <--                         filter (\(x,_)-> x `mod` (m+1)==0) $ take n $ zip [0..] t]]-                 $ plot_lines_title ^= tt-                 $ defaultPlotLines--    b = 0.1--    trial bits frac = scanl (*) 1 (map f bits)-      where-        f True = (1+frac*(1+b))-        f False = (1-frac)--    s1 = solidLine lwidth $ opaque green-    s2 = solidLine lwidth $ opaque blue--main1 :: [String] -> IO (PickFn ())-main1 ["small"]  = renderableToPNGFile (chart 0.25) 320 240 "test5_small.png"-main1 ["big"]    = renderableToPNGFile (chart 0.25) 800 600 "test5_big.png"--main = getArgs >>= main1--
− tests/Test6.hs 
@@ -1,22 +0,0 @@-module Test6 where--import Graphics.Rendering.Chart-import Graphics.Rendering.Chart.Simple-import System.Environment(getArgs)--chart :: Renderable ()-chart = toRenderable (plotLayout pp){layout1_title_="Graphics.Rendering.Chart.Simple example"}-  where-    pp = plot xs sin "sin"-                 cos "cos" "o"-                 (sin.sin.cos) "sin.sin.cos" "."-                 (/3) "- "-                 (const 0.5)-                 [0.1,0.7,0.5::Double] "+"-    xs = [0,0.3..3] :: [Double]--main1 :: [String] -> IO (PickFn ())-main1 ["small"]  = renderableToPNGFile chart 320 240 "test6_small.png"-main1 ["big"]    = renderableToPNGFile chart 800 600 "test6_big.png"--main = getArgs >>= main1
− tests/Test7.hs 
@@ -1,34 +0,0 @@-module Test7 where --import Graphics.Rendering.Chart-import Data.Colour-import Data.Colour.Names-import Data.Accessor-import System.Environment(getArgs)--chart = toRenderable layout-  where-    vals :: [(Double,Double,Double,Double)]-    vals = [ (x,sin (exp x),sin x/2,cos x/10) | x <- [1..20]]-    bars = plot_errbars_values ^= [symErrPoint x y dx dy | (x,y,dx,dy) <- vals]-         $ plot_errbars_title ^="test"-         $ defaultPlotErrBars--    points = plot_points_style ^= filledCircles 2 (opaque red)-	   $ plot_points_values ^= [(x,y) |  (x,y,dx,dy) <- vals]-           $ plot_points_title ^= "test data"-           $ defaultPlotPoints--    layout = layout1_title ^= "Error Bars"-           $ layout1_plots ^= [Left (toPlot bars),-                               Left (toPlot points)]-           $ defaultLayout1---main1 :: [String] -> IO (PickFn ())-main1 ["small"]  = renderableToPNGFile chart 320 240 "test7_small.png"-main1 ["big"]    = renderableToPNGFile chart 800 600 "test7_big.png"--main = getArgs >>= main1--
− tests/Test8.hs 
@@ -1,24 +0,0 @@-module Test8 where --import Graphics.Rendering.Chart-import Data.Accessor-import System.Environment(getArgs)--chart :: Renderable ()-chart = toRenderable layout-  where-    values = [ ("eggs",38,e), ("milk",45,e), ("bread",11,e1), ("salmon",8,e) ]-    e = 0-    e1 = 25-    layout = pie_title ^= "Pie Chart Example"-           $ pie_plot ^: pie_data ^= [ defaultPieItem{pitem_value_=v,pitem_label_=s,pitem_offset_=o}-                                       | (s,v,o) <- values ]-           $ defaultPieLayout--main1 :: [String] -> IO (PickFn ())-main1 ["small"]  = renderableToPNGFile chart 320 240 "test8_small.png"-main1 ["big"]    = renderableToPNGFile chart 800 600 "test8_big.png"--main = getArgs >>= main1--
− tests/Test9.hs 
@@ -1,38 +0,0 @@-module Test9 where --import Graphics.Rendering.Chart-import Data.Colour-import Data.Colour.Names-import Data.Accessor-import System.Environment(getArgs)--chart borders = toRenderable layout- where-  layout = -        layout1_title ^= "Sample Bars" ++ btitle-      $ layout1_title_style ^: font_size ^= 10-      $ layout1_bottom_axis ^: laxis_generate ^= autoIndexAxis alabels-      $ layout1_left_axis ^: laxis_override ^= (axisGridHide.axisTicksHide)-      $ layout1_plots ^= [ Left (plotBars bars2) ]-      $ defaultLayout1 :: Layout1 PlotIndex Double--  bars2 = plot_bars_titles ^= ["Cash","Equity"]-      $ plot_bars_values ^= addIndexes [[20,45],[45,30],[30,20],[70,25]]-      $ plot_bars_style ^= BarsClustered-      $ plot_bars_spacing ^= BarsFixGap 30 5-      $ plot_bars_item_styles ^= map mkstyle (cycle defaultColorSeq)-      $ defaultPlotBars--  alabels = [ "Jun", "Jul", "Aug", "Sep", "Oct" ]--  btitle = if borders then "" else " (no borders)"-  bstyle = if borders then Just (solidLine 1.0 $ opaque black) else Nothing-  mkstyle c = (solidFillStyle c, bstyle)--main1 :: [String] -> IO (PickFn ())-main1 ["small"]  = renderableToPNGFile (chart True) 320 240 "test9_small.png"-main1 ["big"]    = renderableToPNGFile (chart True) 800 600 "test9_big.png"--main = getArgs >>= main1--
− tests/TestParametric.hs 
@@ -1,28 +0,0 @@-module TestParametric where--import Graphics.Rendering.Chart-import Data.Colour-import Data.Colour.Names-import Data.Accessor-import System.Environment(getArgs)--chart lwidth = toRenderable layout-  where-    circle = [ (r a * sin (a*dr),r a * cos (a*dr)) | a <- [0,0.5..360::Double] ]-      where-        dr = 2 * pi / 360-        r a = 0.8 * cos (a * 20 * pi /360)--    circleP = plot_lines_values ^= [circle]-            $ plot_lines_style ^= solidLine lwidth (opaque blue) -            $ defaultPlotLines--    layout = layout1_title ^= "Parametric Plot"-           $ layout1_plots ^= [Left (toPlot circleP)]-           $ defaultLayout1--main1 :: [String] -> IO (PickFn ())-main1 ["small"]  = renderableToPNGFile (chart 0.25) 320 240 "test1_small.png"-main1 ["big"]    = renderableToPNGFile (chart 0.25) 800 600 "test1_big.png"--main = getArgs >>= main1
− tests/all_tests.hs 
@@ -1,433 +0,0 @@-import qualified Graphics.Rendering.Cairo as C-import Graphics.Rendering.Chart-import Graphics.Rendering.Chart.Simple-import Graphics.Rendering.Chart.Grid--import System.Environment(getArgs)-import System.Time-import System.Random-import Data.Time.LocalTime-import Data.Accessor-import Data.Accessor.Tuple-import Data.Colour-import Data.Colour.Names-import Data.Colour.SRGB-import Data.List(sort,nub,scanl1)-import qualified Data.Map as Map-import Control.Monad-import Prices-import qualified Test1-import qualified Test2-import qualified Test3-import qualified Test4-import qualified Test5-import qualified Test6-import qualified Test7-import qualified Test8-import qualified Test9-import qualified Test14-import qualified Test14a-import qualified Test15-import qualified Test17-import qualified TestParametric-import qualified TestSparkLines--data OutputType = PNG | PS | PDF | SVG--chooseLineWidth PNG = 1.0-chooseLineWidth PDF = 0.25-chooseLineWidth PS = 0.25-chooseLineWidth SVG = 0.25--fwhite = solidFillStyle $ opaque white--test1a :: Double -> Renderable ()-test1a lwidth = fillBackground fwhite $ (gridToRenderable t)-  where-    t = weights (1,1) $ aboveN [ besideN [rf g1, rf g2, rf g3],-                                 besideN [rf g4, rf g5, rf g6] ]--    g1 = layout1_title ^= "minimal"-       $ layout1_bottom_axis ^: laxis_override ^= (axisGridHide.axisTicksHide)-       $ layout1_left_axis ^: laxis_override ^= (axisGridHide.axisTicksHide)-       $ Test1.layout lwidth--    g2 = layout1_title ^= "with borders"-       $ layout1_bottom_axis ^: laxis_override ^= (axisGridHide.axisTicksHide)-       $ layout1_left_axis ^: laxis_override ^= (axisGridHide.axisTicksHide)-       $ layout1_top_axis ^: axisBorderOnly-       $ layout1_right_axis ^: axisBorderOnly-       $ Test1.layout lwidth--    g3 = layout1_title ^= "default"-       $ Test1.layout lwidth--    g4 = layout1_title ^= "tight grid"-       $ layout1_left_axis ^: laxis_generate ^= axis-       $ layout1_left_axis ^: laxis_override ^= axisGridAtTicks-       $ layout1_bottom_axis ^: laxis_generate ^= axis-       $ layout1_bottom_axis ^: laxis_override ^= axisGridAtTicks-       $ Test1.layout lwidth-      where-        axis = autoScaledAxis (-            la_nLabels ^= 5-          $ la_nTicks ^= 20-          $ defaultLinearAxis-          )--    g5 = layout1_title ^= "y linked"-       $ layout1_yaxes_control ^= linkAxes-       $ Test1.layout lwidth--    g6 = layout1_title ^= "everything"-       $ layout1_yaxes_control ^= linkAxes-       $ layout1_top_axis ^: laxis_visible ^= const True-       $ Test1.layout lwidth--    rf = tval.toRenderable--    axisBorderOnly = (laxis_visible ^= const True)-                   . (laxis_override ^=  (axisGridHide.axisTicksHide.axisLabelsHide))-------------------------------------------------------------------------test4d :: OutputType -> Renderable ()-test4d otype = toRenderable layout-  where--    points = plot_points_style ^= filledCircles 3 (opaque red)-           $ plot_points_values ^= [ (x, 10**x) | x <- [0.5,1,1.5,2,2.5::Double] ]-           $ plot_points_title ^= "values"-           $ defaultPlotPoints--    lines = plot_lines_values ^= [ [(x, 10**x) | x <- [0,3]] ]-          $ plot_lines_title ^= "values"-          $ defaultPlotLines--    layout = layout1_title ^= "Log/Linear Example"-           $ layout1_bottom_axis ^: laxis_title ^= "horizontal"-           $ layout1_bottom_axis ^: laxis_reverse ^= False-           $ layout1_left_axis ^: laxis_generate ^= autoScaledLogAxis defaultLogAxis-           $ layout1_left_axis ^: laxis_title ^= "vertical"-           $ layout1_left_axis ^: laxis_reverse ^= False-	   $ layout1_plots ^= [Left (toPlot points `joinPlot` toPlot lines) ]-           $ defaultLayout1--------------------------------------------------------------------------test9 :: PlotBarsAlignment -> OutputType -> Renderable ()-test9 alignment otype = fillBackground fwhite $ (gridToRenderable t)-  where-    t = weights (1,1) $ aboveN [ besideN [rf g0, rf g1, rf g2],-                                 besideN [rf g3, rf g4, rf g5] ]--    g0 = layout "clustered 1"-       $ plot_bars_style ^= BarsClustered-       $ plot_bars_spacing ^= BarsFixWidth 25-       $ bars1--    g1 = layout "clustered/fix width "-       $ plot_bars_style ^= BarsClustered-       $ plot_bars_spacing ^= BarsFixWidth 25-       $ bars2--    g2 = layout "clustered/fix gap "-       $ plot_bars_style ^= BarsClustered-       $ plot_bars_spacing ^= BarsFixGap 10 5-       $ bars2--    g3 = layout "stacked 1"-       $ plot_bars_style ^= BarsStacked-       $ plot_bars_spacing ^= BarsFixWidth 25-       $ bars1--    g4 = layout "stacked/fix width"-       $ plot_bars_style ^= BarsStacked-       $ plot_bars_spacing ^= BarsFixWidth 25-       $ bars2--    g5 = layout "stacked/fix gap"-       $ plot_bars_style ^= BarsStacked-       $ plot_bars_spacing ^= BarsFixGap 10 5-       $ bars2--    rf = tval.toRenderable--    alabels = [ "Jun", "Jul", "Aug", "Sep", "Oct" ]---    layout title bars =-             layout1_title ^= (show alignment ++ "/" ++ title)-           $ layout1_title_style ^: font_size ^= 10-           $ layout1_bottom_axis ^: laxis_generate ^= autoIndexAxis alabels-           $ layout1_left_axis ^: laxis_override ^= (axisGridHide.axisTicksHide)-           $ layout1_plots ^= [ Left (plotBars bars) ]-           $ defaultLayout1 :: Layout1 PlotIndex Double--    bars1 = plot_bars_titles ^= ["Cash"]-          $ plot_bars_values ^= addIndexes [[20],[45],[30],[70]]-          $ plot_bars_alignment ^= alignment-          $ defaultPlotBars--    bars2 = plot_bars_titles ^= ["Cash","Equity"]-          $ plot_bars_values ^= addIndexes [[20,45],[45,30],[30,20],[70,25]]-          $ plot_bars_alignment ^= alignment-          $ defaultPlotBars-----------------------------------------------------------------------------------test10 :: [(LocalTime,Double,Double)] -> OutputType -> Renderable ()-test10 prices otype = toRenderable layout-  where--    lineStyle c = line_width ^= 3 * chooseLineWidth otype-                $ line_color ^= c-                $ defaultPlotLines ^. plot_lines_style--    price1 = plot_lines_style ^= lineStyle (opaque blue)-           $ plot_lines_values ^= [[ (d,v) | (d,v,_) <- prices]]-           $ plot_lines_title ^= "price 1"-           $ defaultPlotLines--    price1_area = plot_fillbetween_values ^= [(d, (v * 0.95, v * 1.05)) | (d,v,_) <- prices]-                $ plot_fillbetween_style  ^= solidFillStyle (withOpacity blue 0.2)-                $ defaultPlotFillBetween--    price2 = plot_lines_style ^= lineStyle (opaque red)-	   $ plot_lines_values ^= [[ (d, v) | (d,_,v) <- prices]]-           $ plot_lines_title ^= "price 2"-           $ defaultPlotLines--    price2_area = plot_fillbetween_values ^= [(d, (v * 0.95, v * 1.05)) | (d,_,v) <- prices]-                $ plot_fillbetween_style  ^= solidFillStyle (withOpacity red 0.2)-                $ defaultPlotFillBetween--    fg = opaque black-    fg1 = opaque $ sRGB 0.0 0.0 0.15--    layout = layout1_title ^="Price History"-           $ layout1_background ^= solidFillStyle (opaque white)-           $ layout1_right_axis ^: laxis_override ^= axisGridHide- 	   $ layout1_plots ^= [ Left (toPlot price1_area), Right (toPlot price2_area)-                              , Left (toPlot price1),      Right (toPlot price2)-                              ]-           $ setLayout1Foreground fg-           $ defaultLayout1------------------------------------------------------------------------------------ A quick test of stacked layouts--test11_ f = f layout1 layout2-  where-    vs1 :: [(Int,Int)]-    vs1 = [ (2,2), (3,40), (8,400), (12,60) ]--    vs2 :: [(Int,Double)]-    vs2 = [ (0,0.7), (3,0.35), (4,0.25), (7, 0.6), (10,0.4) ]--    plot1 = plot_points_style ^= filledCircles 5 (opaque red)-          $ plot_points_values ^= vs1-          $ plot_points_title ^= "spots"-          $ defaultPlotPoints--    layout1 = layout1_title ^= "Multi typed stack"- 	   $ layout1_plots ^= [Left (toPlot plot1)]-           $ layout1_left_axis ^: laxis_title ^= "integer values"-           $ defaultLayout1--    plot2 = plot_lines_values ^= [vs2]-          $ plot_lines_title ^= "lines"-          $ defaultPlotLines--    layout2 = layout1_plots ^= [Left (toPlot plot2)]-           $ layout1_left_axis ^: laxis_title ^= "double values"-           $ defaultLayout1--test11a :: OutputType -> Renderable ()-test11a otype = test11_ f-   where-     f l1 l2 = renderStackedLayouts -             $ slayouts_layouts ^= [StackedLayout l1, StackedLayout l2]-             $ slayouts_compress_xlabels ^= False-             $ slayouts_compress_legend ^= False-             $ defaultStackedLayouts- -test11b :: OutputType -> Renderable ()-test11b otype = test11_ f-   where-     f l1 l2 = renderStackedLayouts -             $ slayouts_layouts ^= [StackedLayout l1, StackedLayout l2]-             $ slayouts_compress_xlabels ^= True-             $ slayouts_compress_legend ^= True-             $ defaultStackedLayouts------------------------------------------------------------------------------------ More of an example that a test:--- configuring axes explicitly configured axes--test12 :: OutputType -> Renderable ()-test12 otype = toRenderable layout-  where-    vs1 :: [(Int,Int)]-    vs1 = [ (2,10), (3,40), (8,400), (12,60) ]--    baxis = AxisData {-        axis_viewport_ = vmap (0,15),-        axis_tropweiv_ = invmap (0,15),-        axis_ticks_    = [(v,3) | v <- [0,1..15]],-        axis_grid_     = [0,5..15],-        axis_labels_   = [[(v,show v) | v <- [0,5..15]]]-    }    --    laxis = AxisData {-        axis_viewport_ = vmap (0,500),-        axis_tropweiv_ = invmap (0,500),-        axis_ticks_    = [(v,3) | v <- [0,25..500]],-        axis_grid_     = [0,100..500],-        axis_labels_   = [[(v,show v) | v <- [0,100..500]]]-    }    --    plot = plot_lines_values ^= [vs1]-         $ defaultPlotLines--    layout = layout1_plots ^= [Left (toPlot plot)]-           $ layout1_bottom_axis ^: laxis_generate ^= const baxis-           $ layout1_left_axis   ^: laxis_generate ^= const laxis-           $ layout1_title ^= "Explicit Axes"-           $ defaultLayout1------------------------------------------------------------------------------------- Plot annotations test--test13 otype = fillBackground fwhite $ (gridToRenderable t)-  where-    t = weights (1,1) $ aboveN [ besideN [tval (annotated h v) | h <- hs] | v <- vs ]-    hs = [HTA_Left, HTA_Centre, HTA_Right]-    vs = [VTA_Top, VTA_Centre, VTA_Bottom]-    points=[-2..2]-    pointPlot :: PlotPoints Int Int-    pointPlot = plot_points_style^= filledCircles 2 (opaque red)-                $  plot_points_values ^= [(x,x)|x<-points]-                $  defaultPlotPoints-    p = Left (toPlot pointPlot)-    annotated h v = toRenderable ( layout1_plots ^= [Left (toPlot labelPlot), Left (toPlot rotPlot), p] $ defaultLayout1 )-      where labelPlot = plot_annotation_hanchor ^= h-                      $ plot_annotation_vanchor ^= v-                      $ plot_annotation_values  ^= [(x,x,"Hello World\n(plain)")|x<-points]-                      $ defaultPlotAnnotation-            rotPlot =   plot_annotation_angle ^= -45.0-                      $ plot_annotation_style ^= defaultFontStyle{font_size_=10,font_weight_=C.FontWeightBold, font_color_ =(opaque blue) }-                      $ plot_annotation_values  ^= [(x,x,"Hello World\n(fancy)")|x<-points]-                      $ labelPlot---------------------------------------------------------------------------- a quick test to display labels with all combinations--- of anchors-misc1 rot otype = fillBackground fwhite $ (gridToRenderable t)-  where-    t = weights (1,1) $ aboveN [ besideN [tval (lb h v) | h <- hs] | v <- vs ]-    lb h v = addMargins (20,20,20,20) $ fillBackground fblue $ crossHairs $ rlabel fs h v rot s-    s = "Labelling"-    hs = [HTA_Left, HTA_Centre, HTA_Right]-    vs = [VTA_Top, VTA_Centre, VTA_Bottom]-    fwhite = solidFillStyle $ opaque white-    fblue = solidFillStyle $ opaque $ sRGB 0.8 0.8 1-    fs = defaultFontStyle{font_size_=20,font_weight_=C.FontWeightBold}-    crossHairs r =Renderable {-      minsize = minsize r,-      render = \sz@(w,h) -> do-          let xa = w / 2-          let ya = h / 2-          strokePath [Point 0 ya,Point w ya]-          strokePath [Point xa 0,Point xa h]-          render r sz-    }-------------------------------------------------------------------------stdSize = (640,480)--allTests :: [ (String, (Int,Int), OutputType -> Renderable ()) ]-allTests =-     [ ("test1",  stdSize, \o -> Test1.chart (chooseLineWidth o) )-     , ("test1a", stdSize, \o -> test1a (chooseLineWidth o) )-     , ("test2a", stdSize, \o -> Test2.chart prices    False (chooseLineWidth o))-     , ("test2b", stdSize, \o -> Test2.chart prices1   False (chooseLineWidth o))-     , ("test2c", stdSize, \o -> Test2.chart prices2   False (chooseLineWidth o))-     , ("test2d", stdSize, \o -> Test2.chart prices5   True  (chooseLineWidth o))-     , ("test2e", stdSize, \o -> Test2.chart prices6   True  (chooseLineWidth o))-     , ("test2f", stdSize, \o -> Test2.chart prices7   True  (chooseLineWidth o))-     , ("test2g", stdSize, \o -> Test2.chart prices3   False (chooseLineWidth o))-     , ("test2h", stdSize, \o -> Test2.chart prices8   True  (chooseLineWidth o))-     , ("test2i", stdSize, \o -> Test2.chart prices9   True  (chooseLineWidth o))-     , ("test2j", stdSize, \o -> Test2.chart prices10  True  (chooseLineWidth o))-     , ("test2k", stdSize, \o -> Test2.chart prices10a True  (chooseLineWidth o))-     , ("test2m", stdSize, \o -> Test2.chart prices11  True  (chooseLineWidth o))-     , ("test2n", stdSize, \o -> Test2.chart prices10b True  (chooseLineWidth o))-     , ("test2o", stdSize, \o -> Test2.chart prices12  True  (chooseLineWidth o))-     , ("test2p", stdSize, \o -> Test2.chart prices13  True  (chooseLineWidth o))-     , ("test2q", stdSize, \o -> Test2.chart prices13a True  (chooseLineWidth o))-     , ("test2r", stdSize, \o -> Test2.chart prices13b True  (chooseLineWidth o))-     , ("test2s", stdSize, \o -> Test2.chart prices14  True  (chooseLineWidth o))-     , ("test2t", stdSize, \o -> Test2.chart prices14a True  (chooseLineWidth o))-     , ("test2u", stdSize, \o -> Test2.chart prices14b True  (chooseLineWidth o))-     , ("test2v", stdSize, \o -> Test2.chart prices14c True  (chooseLineWidth o))-     , ("test2w", stdSize, \o -> Test2.chart prices14d True  (chooseLineWidth o))-     , ("test3",  stdSize,  const Test3.chart)-     , ("test4a", stdSize, const (Test4.chart False False))-     , ("test4b", stdSize, const (Test4.chart True False))-     , ("test4c", stdSize, const (Test4.chart False True))-     , ("test4d", stdSize, test4d)-     , ("test5",  stdSize, \o -> Test5.chart (chooseLineWidth o))-     , ("test6",  stdSize, const Test6.chart)-     , ("test7",  stdSize, const Test7.chart)-     , ("test8",  stdSize, const Test8.chart)-     , ("test9",  stdSize, const (Test9.chart True))-     , ("test9b", stdSize, const (Test9.chart False))-     , ("test9c", stdSize, test9 BarsCentered)-     , ("test9l", stdSize, test9 BarsLeft)-     , ("test9r", stdSize, test9 BarsRight)-     , ("test10", stdSize, test10 prices1)-     , ("test11a", stdSize, test11a)-     , ("test11b", stdSize, test11b)-     , ("test12", stdSize, test12)-     , ("test13", stdSize, test13)-     , ("test14", stdSize, \o -> Test14.chart (chooseLineWidth o) )-     , ("test14a", stdSize, \o -> Test14a.chart (chooseLineWidth o) )-     , ("test15a", stdSize, const (Test15.chart (LORows 2)))-     , ("test15b", stdSize, const (Test15.chart (LOCols 2)))-     , ("test17", stdSize,  \o -> Test17.chart (chooseLineWidth o))-     , ("misc1",  stdSize, setPickFn nullPickFn . misc1 0)-     , ("misc1a", stdSize, setPickFn nullPickFn . misc1 45)-     , ("parametric", stdSize, \o -> TestParametric.chart (chooseLineWidth o) )-     , ("sparklines", TestSparkLines.chartSize, const TestSparkLines.chart )-     ]--main = do-    args <- getArgs-    main1 args--main1 :: [String] -> IO ()-main1 ("--pdf":tests) = showTests tests renderToPDF-main1 ("--svg":tests) = showTests tests renderToSVG-main1 ("--ps":tests) = showTests tests renderToPS-main1 ("--png":tests) = showTests tests renderToPNG-main1 tests = showTests tests renderToPNG--showTests :: [String] -> ((String,(Int,Int),OutputType -> Renderable ()) -> IO()) -> IO ()-showTests tests ofn = mapM_ doTest (filter (match tests) allTests)-   where-     doTest (s,size,f) = do-       putStrLn (s ++ "... ")-       ofn (s,size,f)-     --match :: [String] -> (String,s,a) -> Bool-match [] t = True-match ts (s,_,_) = s `elem` ts--renderToPNG (n,(w,h),ir) = renderableToPNGFile (ir PNG) w h (n ++ ".png")-                           >> return ()-renderToPS  (n,(w,h),ir) = renderableToPSFile (ir PS) w h (n ++ ".ps")-renderToPDF (n,(w,h),ir) = renderableToPDFFile (ir PDF) w h (n ++ ".pdf")-renderToSVG (n,(w,h),ir) = renderableToSVGFile (ir SVG) w h (n ++ ".svg")