Chart-1.9.5/0000755000000000000000000000000007346545000010760 5ustar0000000000000000Chart-1.9.5/Chart.cabal0000644000000000000000000000547707346545000013022 0ustar0000000000000000Name: Chart Version: 1.9.5 License: BSD3 License-file: LICENSE Copyright: Tim Docker, 2006-2014 Author: Tim Docker Maintainer: Tim Docker 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, with backends provided by Cairo () and Diagrams (). Documentation: https://github.com/timbod7/haskell-chart/wiki. Category: Graphics Cabal-Version: 1.18 Build-Type: Simple 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 if !impl(ghc >= 8.0) build-depends: semigroups >= 0.18.4 && <0.19 Ghc-options: -Wall -fno-warn-orphans Exposed-modules: Graphics.Rendering.Chart, Graphics.Rendering.Chart.Drawing, Graphics.Rendering.Chart.Geometry, Graphics.Rendering.Chart.Utils, Graphics.Rendering.Chart.Renderable, Graphics.Rendering.Chart.Axis, Graphics.Rendering.Chart.Axis.Floating, Graphics.Rendering.Chart.Axis.Indexed, Graphics.Rendering.Chart.Axis.Int, Graphics.Rendering.Chart.Axis.Time, Graphics.Rendering.Chart.Axis.LocalTime, Graphics.Rendering.Chart.Axis.Types, Graphics.Rendering.Chart.Axis.Unit, Graphics.Rendering.Chart.Layout, Graphics.Rendering.Chart.Legend, Graphics.Rendering.Chart.Grid, Graphics.Rendering.Chart.Plot, Graphics.Rendering.Chart.Plot.Types, Graphics.Rendering.Chart.Plot.Annotation, Graphics.Rendering.Chart.Plot.AreaSpots, Graphics.Rendering.Chart.Plot.Bars, Graphics.Rendering.Chart.Plot.Candle, Graphics.Rendering.Chart.Plot.ErrBars, Graphics.Rendering.Chart.Plot.FillBetween, Graphics.Rendering.Chart.Plot.Hidden, Graphics.Rendering.Chart.Plot.Lines, Graphics.Rendering.Chart.Plot.Vectors, Graphics.Rendering.Chart.Plot.Pie, Graphics.Rendering.Chart.Plot.Points, Graphics.Rendering.Chart.Plot.Histogram Graphics.Rendering.Chart.SparkLine Graphics.Rendering.Chart.Backend Graphics.Rendering.Chart.Backend.Impl Graphics.Rendering.Chart.Backend.Types Graphics.Rendering.Chart.Easy Graphics.Rendering.Chart.State Numeric.Histogram source-repository head type: git location: https://github.com/timbod7/haskell-chart Chart-1.9.5/Graphics/Rendering/0000755000000000000000000000000007346545000014435 5ustar0000000000000000Chart-1.9.5/Graphics/Rendering/Chart.hs0000644000000000000000000000431407346545000016034 0ustar0000000000000000---------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Chart -- Copyright : (c) Tim Docker 2006-2013 -- License : BSD-style (see chart/COPYRIGHT) -- -- A framework for creating 2D charts in Haskell. -- -- For the simplest API, see the "Graphics.Rendering.Chart.Easy" -- module. -- -- 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'. -- -- Currently, there are three types of charts: -- -- * 'Layout' is a standard XY chart -- -- * 'LayoutLR' is an XY chart with independent left -- and right axes -- -- * 'PieLayout' is a pie chart -- -- 'Layout' and 'LayoutLR' charts can be stacked vertically using -- the 'StackedLayouts' type. -- -- 'Renderable's can be composed in arbitrary ways using the -- "Graphics.Rendering.Chart.Grid" module. -- -- Many of the record structure involved in the API have a large -- number of fields. 'Lens'es are provided to access each field. Also, -- for each record type, there is generally a default value, which can -- be accessed through the 'def' value of the 'Default' typeclass. -- ----------------------------------------------------------------------------- module Graphics.Rendering.Chart( 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.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 Chart-1.9.5/Graphics/Rendering/Chart/0000755000000000000000000000000007346545000015476 5ustar0000000000000000Chart-1.9.5/Graphics/Rendering/Chart/Axis.hs0000644000000000000000000000153307346545000016740 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Chart.Axis -- Copyright : (c) Tim Docker 2006 -- License : BSD-style (see chart/COPYRIGHT) -- -- Code to calculate and render axes. -- module Graphics.Rendering.Chart.Axis( module Graphics.Rendering.Chart.Axis.Types, module Graphics.Rendering.Chart.Axis.Floating, module Graphics.Rendering.Chart.Axis.Int, module Graphics.Rendering.Chart.Axis.Time, module Graphics.Rendering.Chart.Axis.Unit, module Graphics.Rendering.Chart.Axis.Indexed, ) where import Graphics.Rendering.Chart.Axis.Types import Graphics.Rendering.Chart.Axis.Floating import Graphics.Rendering.Chart.Axis.Int import Graphics.Rendering.Chart.Axis.Time import Graphics.Rendering.Chart.Axis.Unit import Graphics.Rendering.Chart.Axis.Indexed Chart-1.9.5/Graphics/Rendering/Chart/Axis/0000755000000000000000000000000007346545000016402 5ustar0000000000000000Chart-1.9.5/Graphics/Rendering/Chart/Axis/Floating.hs0000644000000000000000000002703307346545000020506 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Chart.Axis.Floating -- Copyright : (c) Tim Docker 2010, 2014 -- License : BSD-style (see chart/COPYRIGHT) -- -- Calculate and render floating value axes -- including doubles with linear, log, and percentage scaling. -- {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Graphics.Rendering.Chart.Axis.Floating( Percent(..), LinearAxisParams(..), LogValue(..), LogAxisParams(..), scaledAxis, autoScaledAxis, autoScaledLogAxis, autoSteps, la_labelf, la_nLabels, la_nTicks, loga_labelf ) where import Data.List(minimumBy, nub) import Data.Ord (comparing) import Data.Default.Class import Numeric (showEFloat, showFFloat) import Control.Lens import Graphics.Rendering.Chart.Geometry import Graphics.Rendering.Chart.Utils import Graphics.Rendering.Chart.Axis.Types -- Note: the following code uses explicit Integer types -- to avoid -Wall 'defaulting to Integer' messages. instance PlotValue Double where toValue = id fromValue= id autoAxis = autoScaledAxis def instance PlotValue Float where toValue = realToFrac fromValue= realToFrac autoAxis = autoScaledAxis def -- | A wrapper class for doubles used to indicate they are to -- be plotted against a percentage axis. newtype Percent = Percent {unPercent :: Double} deriving (Eq,Ord,Num,Real,Fractional,RealFrac,Floating,RealFloat) instance Show Percent where show (Percent d) = showD (d*100) ++ "%" instance PlotValue Percent where toValue = unPercent fromValue= Percent autoAxis = autoScaledAxis def {-_la_labelf=-} -- | A wrapper class for doubles used to indicate they are to -- be plotted against a log axis. newtype LogValue = LogValue {unLogValue :: Double} deriving (Eq, Ord, Num, Real, Fractional, RealFrac, Floating, RealFloat) instance Show LogValue where show (LogValue x) = show x instance PlotValue LogValue where toValue (LogValue x) = log x fromValue d = LogValue (exp d) autoAxis = autoScaledLogAxis def -- | Show a list of axis labels. -- If some are too big or all are too small, switch to scientific notation for all. -- If the range is much smaller than the mean, use an offset. -- TODO: show this offset only once, not on every label. -- When thinking about improving this function, -- https://github.com/matplotlib/matplotlib/blob/master/lib/matplotlib/ticker.py -- is a good read. -- -- >>> showDs [0, 1, 2 :: Double] -- ["0","1","2"] -- -- >>> showDs [0, 1000000, 2000000 :: Double] -- ["0.0e0","1.0e6","2.0e6"] -- -- >>> showDs [0, 0.001, 0.002 :: Double] -- ["0","0.001","0.002"] -- -- >>> showDs [-10000000, -1000000, 9000000 :: Double] -- ["-1.0e7","-1.0e6","9.0e6"] -- -- >>> showDs [10, 11, 12 :: Double] -- ["10","11","12"] -- -- >>> showDs [100, 101, 102 :: Double] -- ["100","101","102"] -- -- >>> showDs [100000, 100001, 100002 :: Double] -- ["100000","100001","100002"] -- -- >>> showDs [1000000, 1000001, 1000002 :: Double] -- ["1.0e6 + 0","1.0e6 + 1","1.0e6 + 2"] -- -- >>> showDs [10000000, 10000001, 10000002 :: Double] -- ["1.0e7 + 0","1.0e7 + 1","1.0e7 + 2"] -- -- >>> showDs [-10000000, -10000001, -10000002 :: Double] -- ["-1.0e7 + 2","-1.0e7 + 1","-1.0e7 + 0"] -- -- prop> let [s0, s1] = showDs [x, x + 1.0 :: Double] in s0 /= s1 showDs :: forall d . (RealFloat d) => [d] -> [String] showDs xs = case showWithoutOffset xs of (s0:others) | anyEqualNeighbor s0 others -> map addShownOffset $ showWithoutOffset (map (\x -> x - offset) xs) s -> s where anyEqualNeighbor z0 (z1:others) | z0 == z1 = True | otherwise = anyEqualNeighbor z1 others anyEqualNeighbor _ [] = False -- Use the min for offset. Another good choice could be the mean. offset :: d offset = minimum xs shownOffset = case showWithoutOffset [offset] of [r] -> r rs -> error $ "showDs: shownOffset expected 1 element, got " ++ show (length rs) addShownOffset :: String -> String addShownOffset ('-':x) = shownOffset ++ " - " ++ x addShownOffset x = shownOffset ++ " + " ++ x showWithoutOffset :: RealFloat d => [d] -> [String] showWithoutOffset xs | useScientificNotation = map (showEFloat' (Just 1)) xs | otherwise = map showD xs where -- use scientific notation if max value is too big or too small useScientificNotation = maxAbs >= 1e6 || maxAbs <= 1e-6 maxAbs = maximum (map abs xs) -- | Changes the behavior of showEFloat to drop more than one trailings 0. -- Instead of 1.000e4 you get 1.0e4 showEFloat' :: forall d . RealFloat d => Maybe Int -> d -> String showEFloat' mdigits x = reverse $ cleanup0 (reverse shown0) where shown0 = showEFloat mdigits x "" -- wait until we get the "e" cleanup0 :: String -> String cleanup0 (e@'e':ys) = e:cleanup1 ys cleanup0 (y:ys) = y : cleanup0 ys cleanup0 [] = reverse shown0 -- something went wrong, just return the original -- get rid of redundant 0s before the '.' cleanup1 :: String -> String cleanup1 ('0':ys@('0':_)) = cleanup1 ys cleanup1 y = y showD :: (RealFloat d) => d -> String showD x = case reverse $ showFFloat Nothing x "" of '0':'.':r -> reverse r r -> reverse r data LinearAxisParams a = LinearAxisParams { -- | The function used to show the axes labels. _la_labelf :: [a] -> [String], -- | The target number of labels to be shown. _la_nLabels :: Int, -- | The target number of ticks to be shown. _la_nTicks :: Int } instance (Show a, RealFloat a) => Default (LinearAxisParams a) where def = LinearAxisParams { _la_labelf = showDs , _la_nLabels = 5 , _la_nTicks = 50 } -- | Generate a linear axis with the specified bounds scaledAxis :: RealFloat a => LinearAxisParams a -> (a,a) -> AxisFn a scaledAxis lap rs@(minV,maxV) ps0 = makeAxis' realToFrac realToFrac (_la_labelf lap) (labelvs,tickvs,gridvs) where ps = filter isValidNumber ps0 range [] = (0,1) range _ | minV == maxV = if minV==0 then (-1,1) else let d = abs (minV * 0.01) in (minV-d,maxV+d) | otherwise = rs labelvs = map fromRational $ steps (fromIntegral (_la_nLabels lap)) r tickvs = map fromRational $ steps (fromIntegral (_la_nTicks lap)) (minimum labelvs,maximum labelvs) gridvs = labelvs r = range ps -- | Generate a linear axis automatically, scaled appropriately for the -- input data. autoScaledAxis :: RealFloat a => LinearAxisParams a -> AxisFn a autoScaledAxis lap ps0 = scaledAxis lap rs ps where ps = filter isValidNumber ps0 rs = (minimum ps,maximum ps) steps :: RealFloat a => a -> (a,a) -> [Rational] steps nSteps rs@(minV,maxV) = map ((s*) . fromIntegral) [min' .. max'] where s = chooseStep nSteps rs min' :: Integer min' = floor $ realToFrac minV / s max' = ceiling $ realToFrac maxV / s chooseStep :: RealFloat a => a -> (a,a) -> Rational chooseStep nsteps (x1,x2) = minimumBy (comparing proximity) stepVals where delta = x2 - x1 mult | delta == 0 = 1 -- Otherwise the case below will use all of memory | otherwise = 10 ^^ ((floor $ log10 $ delta / nsteps)::Integer) stepVals = map (mult*) [0.1,0.2,0.25,0.5,1.0,2.0,2.5,5.0,10,20,25,50] proximity x = abs $ delta / realToFrac x - nsteps -- | Given a target number of values, and a list of input points, -- find evenly spaced values from the set {1*X, 2*X, 2.5*X, 5*X} (where -- X is some power of ten) that evenly cover the input points. autoSteps :: Int -> [Double] -> [Double] autoSteps nSteps vs = map fromRational $ steps (fromIntegral nSteps) r where range [] = (0,1) range _ | minV == maxV = (minV-0.5,minV+0.5) | otherwise = rs rs@(minV,maxV) = (minimum ps,maximum ps) ps = filter isValidNumber vs r = range ps ---------------------------------------------------------------------- instance (Show a, RealFloat a) => Default (LogAxisParams a) where def = LogAxisParams { _loga_labelf = showDs } -- | Generate a log axis automatically, scaled appropriately for the -- input data. autoScaledLogAxis :: RealFloat a => LogAxisParams a -> AxisFn a autoScaledLogAxis lap ps0 = makeAxis' (realToFrac . log) (realToFrac . exp) (_loga_labelf lap) (wrap rlabelvs, wrap rtickvs, wrap rlabelvs) where ps = filter (\x -> isValidNumber x && 0 < x) ps0 (minV,maxV) = (minimum ps,maximum ps) wrap = map fromRational range [] = (3,30) range _ | minV == maxV = (realToFrac $ minV/3, realToFrac $ maxV*3) | otherwise = (realToFrac $ minV, realToFrac $ maxV) (rlabelvs, rtickvs) = logTicks (range ps) data LogAxisParams a = LogAxisParams { -- | The function used to show the axes labels. _loga_labelf :: [a] -> [String] } {- Rules: Do not subdivide between powers of 10 until all powers of 10 get major ticks. Do not subdivide between powers of ten as [1,2,4,6,8,10] when 5 gets a major tick (i.e. the major ticks need to be a subset of the minor ticks) -} logTicks :: Range -> ([Rational],[Rational]) logTicks (low,high) = (nub major,nub minor) where pf :: RealFrac a => a -> (Integer, a) pf = properFraction -- frac :: (RealFrac a, Integral b) => a -> (b, a) frac :: (RealFrac a) => a -> (Integer, a) frac x | 0 <= b = (a,b) | otherwise = (a-1,b+1) where (a,b) = properFraction x ratio = high/low lower a l = let (i,r) = frac (log10 a) in maximum (1:filter (\x -> log10 (fromRational x) <= r) l)*10^^i upper a l = let (i,r) = pf (log10 a) in minimum (10:filter (\x -> r <= log10 (fromRational x)) l)*10^^i powers :: (Double,Double) -> [Rational] -> [Rational] powers (x,y) l = [ a*10^^p | p <- [(floor (log10 x))..(ceiling (log10 y))] :: [Integer] , a <- l ] midselection r l = filter (inRange r l) (powers r l) inRange (a,b) l x = (lower a l <= x) && (x <= upper b l) logRange = (log10 low, log10 high) roundPow x = 10^^(round x :: Integer) major | 17.5 < log10 ratio = map roundPow $ steps (min 5 (log10 ratio)) logRange | 12 < log10 ratio = map roundPow $ steps (log10 ratio / 5) logRange | 6 < log10 ratio = map roundPow $ steps (log10 ratio / 2) logRange | 3 < log10 ratio = midselection (low,high) [1,10] | 20 < ratio = midselection (low,high) [1,5,10] | 6 < ratio = midselection (low,high) [1,2,4,6,8,10] | 3 < ratio = midselection (low,high) [1..10] | otherwise = steps 5 (low,high) (l',h') = (minimum major, maximum major) (dl',dh') = (fromRational l', fromRational h') ratio' :: Double ratio' = fromRational (h'/l') filterX = filter (\x -> l'<=x && x <=h') . powers (dl',dh') minor | 50 < log10 ratio' = map roundPow $ steps 50 (log10 dl', log10 dh') | 6 < log10 ratio' = filterX [1,10] | 4 < log10 ratio' = filterX [1,5,10] | 6 < ratio' = filterX [1..10] | 3 < ratio' = filterX [1,1.2..10] | otherwise = steps 50 (dl', dh') $( makeLenses ''LinearAxisParams ) $( makeLenses ''LogAxisParams ) Chart-1.9.5/Graphics/Rendering/Chart/Axis/Indexed.hs0000644000000000000000000000364507346545000020326 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Chart.Axis.Unit -- Copyright : (c) Tim Docker 2010, 2014 -- License : BSD-style (see chart/COPYRIGHT) -- -- Calculate and render indexed axes {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TupleSections #-} module Graphics.Rendering.Chart.Axis.Indexed( PlotIndex(..), autoIndexAxis', autoIndexAxis, addIndexes, ) where import Data.Default.Class import Graphics.Rendering.Chart.Axis.Types -- | Type for capturing values plotted by index number -- (ie position in a list) rather than a numerical value. newtype PlotIndex = PlotIndex { plotindex_i :: Int } deriving (Eq,Ord,Enum,Num,Real,Integral,Show) instance PlotValue PlotIndex where toValue (PlotIndex i) = fromIntegral i fromValue = PlotIndex . round autoAxis = autoIndexAxis [] -- | Augment a list of values with index numbers for plotting. addIndexes :: [a] -> [(PlotIndex,a)] addIndexes = zipWith (\n x -> (PlotIndex n, x)) [0..] -- | Create an axis for values indexed by position. The -- list of strings are the labels to be used. autoIndexAxis' :: Integral i => Bool -> [String] -> AxisFn i autoIndexAxis' tks labels vs = AxisData { _axis_visibility = def { _axis_show_ticks = False }, _axis_viewport = vport, _axis_tropweiv = invport, _axis_ticks = if tks then map (, 5) $ take (length labels) [0..] else [], _axis_labels = [filter (\(i,_) -> i >= imin && i <= imax) (zip [0..] labels)], _axis_grid = [] } where vport r i = linMap id ( fromIntegral imin - 0.5 , fromIntegral imax + 0.5) r (fromIntegral i) invport = invLinMap round fromIntegral (imin, imax) imin = minimum vs imax = maximum vs autoIndexAxis :: Integral i => [String] -> AxisFn i autoIndexAxis = autoIndexAxis' FalseChart-1.9.5/Graphics/Rendering/Chart/Axis/Int.hs0000644000000000000000000001040007346545000017463 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Chart.Axis.Int -- Copyright : (c) Tim Docker 2010, 2014 -- License : BSD-style (see chart/COPYRIGHT) -- -- Calculate and render integer indexed axes {-# OPTIONS_GHC -fno-warn-orphans #-} module Graphics.Rendering.Chart.Axis.Int( defaultIntAxis, scaledIntAxis, autoScaledIntAxis ) where import Data.List(genericLength) import Data.Int (Int8, Int16, Int32, Int64) import Data.Word (Word8, Word16, Word32, Word64) import Graphics.Rendering.Chart.Geometry import Graphics.Rendering.Chart.Axis.Types import Graphics.Rendering.Chart.Axis.Floating instance PlotValue Int where toValue = fromIntegral fromValue = round autoAxis = autoScaledIntAxis defaultIntAxis instance PlotValue Int8 where toValue = fromIntegral fromValue = round autoAxis = autoScaledIntAxis defaultIntAxis instance PlotValue Int16 where toValue = fromIntegral fromValue = round autoAxis = autoScaledIntAxis defaultIntAxis instance PlotValue Int32 where toValue = fromIntegral fromValue = round autoAxis = autoScaledIntAxis defaultIntAxis instance PlotValue Int64 where toValue = fromIntegral fromValue = round autoAxis = autoScaledIntAxis defaultIntAxis instance PlotValue Word where toValue = fromIntegral fromValue = round autoAxis = autoScaledIntAxis defaultIntAxis instance PlotValue Word8 where toValue = fromIntegral fromValue = round autoAxis = autoScaledIntAxis defaultIntAxis instance PlotValue Word16 where toValue = fromIntegral fromValue = round autoAxis = autoScaledIntAxis defaultIntAxis instance PlotValue Word32 where toValue = fromIntegral fromValue = round autoAxis = autoScaledIntAxis defaultIntAxis instance PlotValue Word64 where toValue = fromIntegral fromValue = round autoAxis = autoScaledIntAxis defaultIntAxis instance PlotValue Integer where toValue = fromIntegral fromValue = round autoAxis = autoScaledIntAxis defaultIntAxis defaultIntAxis :: (Show a) => LinearAxisParams a defaultIntAxis = LinearAxisParams { _la_labelf = map show, _la_nLabels = 5, _la_nTicks = 10 } autoScaledIntAxis :: (Integral i, PlotValue i) => LinearAxisParams i -> AxisFn i autoScaledIntAxis lap ps = scaledIntAxis lap rs ps where rs = (minimum ps,maximum ps) scaledIntAxis :: (Integral i, PlotValue i) => LinearAxisParams i -> (i,i) -> AxisFn i scaledIntAxis lap (minI,maxI) ps = makeAxis (_la_labelf lap) (labelvs,tickvs,gridvs) where range [] = (0,1) range _ | minI == maxI = (fromIntegral $ minI-1, fromIntegral $ minI+1) | otherwise = (fromIntegral minI, fromIntegral maxI) -- labelvs :: [i] labelvs = stepsInt (fromIntegral $ _la_nLabels lap) r tickvs = stepsInt (fromIntegral $ _la_nTicks lap) ( fromIntegral $ minimum labelvs , fromIntegral $ maximum labelvs ) gridvs = labelvs r = range ps stepsInt :: Integral a => a -> Range -> [a] stepsInt nSteps range = bestSize (goodness alt0) alt0 alts where bestSize n a (a':as) = let n' = goodness a' in if n' < n then bestSize n' a' as else a bestSize _ _ [] = [] goodness vs = abs (genericLength vs - nSteps) (alt0:alts) = map (\n -> steps n range) sampleSteps' -- throw away sampleSteps that are definitely too small as -- they takes a long time to process sampleSteps' = let rangeMag = ceiling (snd range - fst range) (s1,s2) = span (< (rangeMag `div` nSteps)) sampleSteps in ((reverse . take 5 . reverse) s1) ++ s2 -- generate all possible step sizes sampleSteps = [1,2,5] ++ sampleSteps1 sampleSteps1 = [10,20,25,50] ++ map (*10) sampleSteps1 steps size (minV,maxV) = takeWhile ( Double doubleFromLocalTime lt = fromIntegral (toModifiedJulianDay (localDay lt)) + fromRational (timeOfDayToDayFraction (localTimeOfDay lt)) -- | Map a plot coordinate to a LocalTime. localTimeFromDouble :: Double -> LocalTime localTimeFromDouble v = LocalTime (ModifiedJulianDay i) (dayFractionToTimeOfDay (toRational d)) where (i,d) = properFraction v -- | TimeSeq is a (potentially infinite) set of times. When passed -- a reference time, the function returns a a pair of lists. The first -- contains all times in the set less than the reference time in -- decreasing order. The second contains all times in the set greater -- than or equal to the reference time, in increasing order. type TimeSeq = LocalTime-> ([LocalTime],[LocalTime]) coverTS :: TimeSeq -> LocalTime -> LocalTime -> [LocalTime] coverTS tseq minT maxT = min' ++ enumerateTS tseq minT maxT ++ max' where min' = if elemTS minT tseq then [] else take 1 (fst (tseq minT)) max' = if elemTS maxT tseq then [] else take 1 (snd (tseq maxT)) enumerateTS :: TimeSeq -> LocalTime -> LocalTime -> [LocalTime] enumerateTS tseq minT maxT = reverse (takeWhile (>=minT) ts1) ++ takeWhile (<=maxT) ts2 where (ts1,ts2) = tseq minT elemTS :: LocalTime -> TimeSeq -> Bool elemTS t tseq = case tseq t of (_,t0:_) | t == t0 -> True _ -> False -- | How to display a time type TimeLabelFn = LocalTime -> String data TimeLabelAlignment = UnderTicks | BetweenTicks deriving (Show) -- | Create an 'AxisFn' to for a time axis. -- -- The values to be plotted against this axis can be created with -- 'doubleFromLocalTime'. timeAxis :: TimeSeq -- ^ Set the minor ticks, and the final range will be aligned to its -- elements. -> TimeSeq -- ^ Set the labels and grid. -> TimeLabelFn -> TimeLabelAlignment -> TimeSeq -- ^ Set the second line of labels. -> TimeLabelFn -- ^ Format `LocalTime` for labels. -> TimeLabelAlignment -> AxisFn LocalTime timeAxis tseq lseq labelf lal cseq contextf clal pts = AxisData { _axis_visibility = def, _axis_viewport = vmap(min', max'), _axis_tropweiv = invmap(min', max'), _axis_ticks = [ (t,2) | t <- times] ++ [ (t,5) | t <- ltimes, visible t], _axis_labels = [ [ (t,l) | (t,l) <- labels labelf ltimes lal, visible t] , [ (t,l) | (t,l) <- labels contextf ctimes clal, visible t] ], _axis_grid = [ t | t <- ltimes, visible t] } where (minT,maxT) = case pts of [] -> (refLocalTime,refLocalTime) ps -> (minimum ps, maximum ps) refLocalTime = LocalTime (ModifiedJulianDay 0) midnight times = coverTS tseq minT maxT ltimes = coverTS lseq minT maxT ctimes = coverTS cseq minT maxT min' = minimum times max' = maximum times visible t = min' <= t && t <= max' labels f ts lal' = [ (align lal' m1' m2', f m1) | (m1,m2) <- zip ts (tail ts) , let m1' = if m1max' then max' else m2 ] align BetweenTicks m1 m2 = avg m1 m2 align UnderTicks m1 _ = m1 avg m1 m2 = localTimeFromDouble $ m1' + (m2' - m1')/2 where m1' = doubleFromLocalTime m1 m2' = doubleFromLocalTime m2 normalizeTimeOfDay :: LocalTime -> LocalTime normalizeTimeOfDay t@(LocalTime day (TimeOfDay h m s)) | s < 0 = normalizeTimeOfDay (LocalTime day (TimeOfDay h (m-1) (s+60))) | m < 0 = normalizeTimeOfDay (LocalTime day (TimeOfDay (h-1) (m+60) s)) | h < 0 = normalizeTimeOfDay (LocalTime (addDays (-1) day) (TimeOfDay (h+24) m s)) | s >= 60 = normalizeTimeOfDay (LocalTime day (TimeOfDay h (m+s`div'`60) (s`mod'`60))) | m >= 60 = normalizeTimeOfDay (LocalTime day (TimeOfDay (h+m`div`60) (m`mod`60) s)) | h >= 24 = LocalTime (addDays (fromIntegral (h`div`24)) day) (TimeOfDay (h`mod`24) m s) | otherwise = t addTod :: Int -> Int -> Pico -> LocalTime -> LocalTime addTod dh dm ds (LocalTime day (TimeOfDay h m s)) = normalizeTimeOfDay t' where t' = LocalTime day (TimeOfDay (h+dh) (m+dm) (s+ds)) truncateTo :: (HasResolution a) => Fixed a -> Fixed a -> Fixed a truncateTo t step = t - t `mod'` step secondSeq :: Pico -> TimeSeq secondSeq step t = (iterate rev t1, tail (iterate fwd t1)) where h0 = todHour (localTimeOfDay t) m0 = todMin (localTimeOfDay t) s0 = todSec (localTimeOfDay t) `truncateTo` (1 / 1000) t0 = LocalTime (localDay t) (TimeOfDay h0 m0 s0) t1 = if t0 < t then t0 else rev t0 rev = addTod 0 0 (negate step) fwd = addTod 0 0 step millis1, millis10, millis100, seconds, fiveSeconds :: TimeSeq millis1 = secondSeq (1 / 1000) millis10 = secondSeq (1 / 100) millis100 = secondSeq (1 / 10) seconds = secondSeq 1 fiveSeconds = secondSeq 5 minuteSeq :: Int -> TimeSeq minuteSeq step t = (iterate rev t1, tail (iterate fwd t1)) where h0 = todHour (localTimeOfDay t) m0 = todMin (localTimeOfDay t) t0 = LocalTime (localDay t) (TimeOfDay h0 m0 0) t1 = if t0 < t then t0 else rev t0 rev = addTod 0 (negate step) 0 fwd = addTod 0 step 0 minutes, fiveMinutes :: TimeSeq minutes = minuteSeq 1 fiveMinutes = minuteSeq 5 -- | A 'TimeSeq' for hours. hours :: TimeSeq hours t = (iterate rev t1, tail (iterate fwd t1)) where h0 = todHour (localTimeOfDay t) t0 = LocalTime (localDay t) (TimeOfDay h0 0 0) t1 = if t0 < t then t0 else rev t0 rev = addTod (-1) 0 0 fwd = addTod 1 0 0 -- | A 'TimeSeq' for calendar days. days :: TimeSeq days t = (map toTime $ iterate rev t1, map toTime $ tail (iterate fwd t1)) where t0 = localDay t t1 = if toTime t0 < t then t0 else rev t0 rev = pred fwd = succ toTime d = LocalTime d midnight -- | A 'TimeSeq' for calendar months. months :: TimeSeq months t = (map toTime $ iterate rev t1, map toTime $ tail (iterate fwd t1)) where t0 = let (y,m,_) = toGregorian $ localDay t in fromGregorian y m 1 t1 = if toTime t0 < t then t0 else rev t0 rev = addGregorianMonthsClip (-1) fwd = addGregorianMonthsClip 1 toTime d = LocalTime d midnight -- | A 'TimeSeq' for calendar years. years :: TimeSeq years t = (map toTime $ iterate rev t1, map toTime $ tail (iterate fwd t1)) where t0 = toGregorian (localDay t) ^. _1 t1 = if toTime t0 < t then t0 else rev t0 rev = pred fwd = succ toTime y = LocalTime (fromGregorian y 1 1) midnight -- | A 'TimeSeq' for no sequence at all. noTime :: TimeSeq noTime _ = ([],[]) -- | Automatically choose a suitable time axis, based upon the time range -- of data. The values to be plotted against this axis can be created -- with 'doubleFromLocalTime'. autoTimeAxis :: AxisFn LocalTime autoTimeAxis pts | null pts = timeAxis days days (ft "%d-%b-%y") UnderTicks noTime (ft "") UnderTicks [] | tdiff==0 && 100*dsec<1= timeAxis millis1 millis1 (ft "%S%Q") UnderTicks noTime (ft "%S%Q") UnderTicks pts | tdiff==0 && 10*dsec<1 = timeAxis millis10 millis10 (ft "%S%Q") UnderTicks noTime (ft "%S%Q") UnderTicks pts | tdiff==0 && dsec<1 = timeAxis millis10 millis100 (ft "%S%Q") UnderTicks seconds (ft "%M:%S") BetweenTicks pts | tdiff==0 && dsec<5 = timeAxis millis100 seconds (ft "%M:%S%Q") UnderTicks seconds (ft "%M:%S") BetweenTicks pts | tdiff==0 && dsec<32 = timeAxis seconds seconds (ft "%Ss") UnderTicks minutes (ft "%d-%b-%y %H:%M") BetweenTicks pts | tdiff==0 && dsec<120 = timeAxis seconds fiveSeconds (ft "%Ss") UnderTicks minutes (ft "%d-%b-%y %H:%M") BetweenTicks pts | tdiff==0 && dmin<7 = timeAxis fiveSeconds minutes (ft "%Mm") UnderTicks hours (ft "%d-%b-%y %H:00") BetweenTicks pts | tdiff==0 && dmin<32 = timeAxis minutes minutes (ft "%Mm") UnderTicks hours (ft "%d-%b-%y %H:00") BetweenTicks pts | tdiff==0 && dmin<90 = timeAxis minutes fiveMinutes (ft "%Mm") UnderTicks hours (ft "%d-%b-%y %H:00") BetweenTicks pts | tdiff < 2 && dhour<4 = timeAxis fiveMinutes hours (ft "%H:%M") UnderTicks days (ft "%d-%b-%y") BetweenTicks pts | tdiff < 2 && dhour<32 = timeAxis hours hours (ft "%H:%M") UnderTicks days (ft "%d-%b-%y") BetweenTicks pts | tdiff < 4 = timeAxis hours days (ft "%d-%b-%y") BetweenTicks noTime (ft "") BetweenTicks pts | tdiff < 12 = timeAxis days days (ft "%d-%b") BetweenTicks years (ft "%Y") BetweenTicks pts | tdiff < 45 = timeAxis days days (ft "%d") BetweenTicks months (ft "%b-%y") BetweenTicks pts | tdiff < 95 = timeAxis days months (ft "%b-%y") BetweenTicks noTime (ft "") BetweenTicks pts | tdiff < 450 = timeAxis months months (ft "%b-%y") BetweenTicks noTime (ft "") BetweenTicks pts | tdiff < 735 = timeAxis months months (ft "%b") BetweenTicks years (ft "%Y") BetweenTicks pts | tdiff < 1800 = timeAxis months years (ft "%Y") BetweenTicks noTime (ft "") BetweenTicks pts | otherwise = timeAxis years years (ft "%Y") BetweenTicks noTime (ft "") BetweenTicks pts where tdiff = diffDays (localDay t1) (localDay t0) dhour = if tdiff==0 then h1-h0 else 24*fromIntegral tdiff +h1-h0 dmin = 60*dhour+(m1-m0) dsec = fromIntegral (60*dmin) + (s1-s0) (TimeOfDay h0 m0 s0) = localTimeOfDay t0 (TimeOfDay h1 m1 s1) = localTimeOfDay t1 t1 = maximum pts t0 = minimum pts ft = formatTime defaultTimeLocale Chart-1.9.5/Graphics/Rendering/Chart/Axis/Time.hs0000644000000000000000000003025607346545000017642 0ustar0000000000000000{-# 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 m1max' 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 Chart-1.9.5/Graphics/Rendering/Chart/Axis/Types.hs0000644000000000000000000003567607346545000020063 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Chart.Axis.Types -- Copyright : (c) Tim Docker 2006, 2014 -- License : BSD-style (see chart/COPYRIGHT) -- -- Type definitions for Axes -- {-# LANGUAGE TemplateHaskell #-} module Graphics.Rendering.Chart.Axis.Types( AxisData(..), AxisVisibility(..), AxisT(..), AxisStyle(..), PlotValue(..), AxisFn, defaultAxisLineStyle, defaultGridLineStyle, makeAxis, makeAxis', axisToRenderable, renderAxisGrid, axisOverhang, vmap, invmap, linMap, invLinMap, axisGridAtTicks, axisGridAtBigTicks, axisGridAtLabels, axisGridHide, axisLabelsOverride, axis_show_line, axis_show_ticks, axis_show_labels, axis_visibility, axis_viewport, axis_tropweiv, axis_ticks, axis_labels, axis_grid, axis_line_style, axis_label_style, axis_grid_style, axis_label_gap, ) where import Control.Monad import Data.List(sort,intersperse) import Control.Lens hiding (at, re) import Data.Colour (opaque) import Data.Colour.Names (black, lightgrey) import Data.Default.Class import Graphics.Rendering.Chart.Geometry import Graphics.Rendering.Chart.Drawing import Graphics.Rendering.Chart.Renderable -- | A typeclass abstracting the functions we need -- to be able to plot against an axis of type a class Ord a => PlotValue a where toValue :: a -> Double fromValue:: Double -> a autoAxis :: AxisFn a -- | Configures whick visual elements of a axis are shown at the -- appropriate edge of a plot area. data AxisVisibility = AxisVisibility { -- | Whether to display a line along the axis. _axis_show_line :: Bool -- | Whether to display the tick marks. , _axis_show_ticks :: Bool -- | Whether to display the labels. , _axis_show_labels :: Bool } -- | The basic data associated with an axis showing values of type x. data AxisData x = AxisData { -- | Which parts of the axis shall be displayed. _axis_visibility :: AxisVisibility, -- | The _axis_viewport function maps values into device coordinates. _axis_viewport :: Range -> x -> Double, -- | The _axis_tropweiv function maps device coordinates back to values. _axis_tropweiv :: Range -> Double -> x, -- | The tick marks on the axis as pairs. -- The first element is the position on the axis -- (in viewport units) and the second element is the -- length of the tick in output coordinates. -- The tick starts on the axis, and positive numbers are drawn -- towards the plot area. _axis_ticks :: [(x,Double)], -- | The labels on an axis as pairs. The first element of the pair -- is the position on the axis (in viewport units) and the -- second is the label text string. Note that multiple sets of -- labels can be specified, and are shown successively further -- away from the axis line. _axis_labels :: [[(x, String)]], -- | The positions on the axis (in viewport units) where -- we want to show grid lines. _axis_grid :: [ x ] } -- | Control values for how an axis gets displayed. data AxisStyle = AxisStyle { -- | 'LineStyle' to use for axis line and ticks. _axis_line_style :: LineStyle, -- | 'FontStyle' to use for axis labels. _axis_label_style :: FontStyle, -- | 'LineStyle' to use for axis grid. _axis_grid_style :: LineStyle, -- | How far the labels are to be drawn from the axis. _axis_label_gap :: Double } -- | A function to generate the axis data, given the data values -- to be plotted against it. type AxisFn x = [x] -> AxisData x -- | Collect the information we need to render an axis. The -- bool is true if the axis direction is reversed. data AxisT x = AxisT RectEdge AxisStyle Bool (AxisData x) -- | Construct a renderable from an axis, in order that -- it can be composed with other renderables and drawn. This -- does not include the drawing of the grid, which must be done -- separately by the `renderAxisGrid` function. axisToRenderable :: AxisT x -> Renderable x axisToRenderable at = Renderable { minsize = minsizeAxis at, render = renderAxis at } -- | Modifier to remove grid lines from an axis axisGridHide :: AxisData x -> AxisData x axisGridHide ad = ad{ _axis_grid = [] } -- | Modifier to position grid lines to line up with the ticks axisGridAtTicks :: AxisData x -> AxisData x axisGridAtTicks ad = ad{ _axis_grid = map fst (_axis_ticks ad) } -- | Modifier to position grid lines to line up with only the major ticks axisGridAtBigTicks :: AxisData x -> AxisData x axisGridAtBigTicks ad = ad{ _axis_grid = map fst $ filter ((> minimum (map (abs.snd) (_axis_ticks ad))).snd) $ _axis_ticks ad } -- | Modifier to position grid lines to line up with the labels axisGridAtLabels :: AxisData x -> AxisData x axisGridAtLabels ad = ad{ _axis_grid = map fst vs } where vs = case _axis_labels ad of [] -> [] ls -> head ls -- | Modifier to change labels on an axis axisLabelsOverride :: [(x,String)] -> AxisData x -> AxisData x axisLabelsOverride o ad = ad{ _axis_labels = [o] } minsizeAxis :: AxisT x -> BackendProgram RectSize minsizeAxis (AxisT at as _ ad) = do let labelVis = _axis_show_labels $ _axis_visibility ad tickVis = _axis_show_ticks $ _axis_visibility ad labels = if labelVis then labelTexts ad else [] ticks = if tickVis then _axis_ticks ad else [] labelSizes <- withFontStyle (_axis_label_style as) $ mapM (mapM textDimension) labels let ag = _axis_label_gap as let tsize = maximum (0 : [ max 0 (-l) | (_,l) <- ticks ]) let hw = maximum0 (map (maximum0.map fst) labelSizes) let hh = ag + tsize + (sum . intersperse ag . map (maximum0.map snd) $ labelSizes) let vw = ag + tsize + (sum . intersperse ag . map (maximum0.map fst) $ labelSizes) let vh = maximum0 (map (maximum0.map snd) labelSizes) let sz = case at of E_Top -> (hw,hh) E_Bottom -> (hw,hh) E_Left -> (vw,vh) E_Right -> (vw,vh) return sz labelTexts :: AxisData a -> [[String]] labelTexts ad = map (map snd) (_axis_labels ad) maximum0 :: (Num a, Ord a) => [a] -> a maximum0 [] = 0 maximum0 vs = maximum vs -- | Calculate the amount by which the labels extend beyond -- the ends of the axis. axisOverhang :: (Ord x) => AxisT x -> BackendProgram (Double,Double) axisOverhang (AxisT at as _ ad) = do let labels = map snd . sort . concat . _axis_labels $ ad labelSizes <- withFontStyle (_axis_label_style as) $ mapM textDimension labels case labelSizes of [] -> return (0,0) ls -> let l1 = head ls l2 = last ls ohangv = return (snd l1 / 2, snd l2 / 2) ohangh = return (fst l1 / 2, fst l2 / 2) in case at of E_Top -> ohangh E_Bottom -> ohangh E_Left -> ohangv E_Right -> ohangh renderAxis :: AxisT x -> RectSize -> BackendProgram (PickFn x) renderAxis at@(AxisT et as _ ad) sz = do let ls = _axis_line_style as vis = _axis_visibility ad when (_axis_show_line vis) $ withLineStyle (ls {_line_cap = LineCapSquare}) $ do p <- alignStrokePoints [Point sx sy,Point ex ey] strokePointPath p when (_axis_show_ticks vis) $ withLineStyle (ls {_line_cap = LineCapButt}) $ mapM_ drawTick (_axis_ticks ad) when (_axis_show_labels vis) $ withFontStyle (_axis_label_style as) $ do labelSizes <- mapM (mapM textDimension) (labelTexts ad) let sizes = map ((+ag).maximum0.map coord) labelSizes let offsets = scanl (+) ag sizes mapM_ drawLabels (zip offsets (_axis_labels ad)) return pickfn where (sx,sy,ex,ey,tp,axisPoint,invAxisPoint) = axisMapping at sz drawTick (value,len) = let t1 = axisPoint value t2 = t1 `pvadd` vscale len tp in alignStrokePoints [t1,t2] >>= strokePointPath (hta,vta,coord,awayFromAxis) = case et of E_Top -> (HTA_Centre, VTA_Bottom, snd, \v -> Vector 0 (-v)) E_Bottom -> (HTA_Centre, VTA_Top, snd, \v -> Vector 0 v) E_Left -> (HTA_Right, VTA_Centre, fst, \v -> Vector (-v) 0) E_Right -> (HTA_Left, VTA_Centre, fst, \v -> Vector v 0) avoidOverlaps labels = do rects <- mapM labelDrawRect labels return $ map snd . head . filter (noOverlaps . map fst) $ map (`eachNth` rects) [0 .. length rects] labelDrawRect (value,s) = do let pt = axisPoint value `pvadd` awayFromAxis ag r <- textDrawRect hta vta pt s return (hBufferRect r,(value,s)) drawLabels (offset,labels) = do labels' <- avoidOverlaps labels mapM_ drawLabel labels' where drawLabel (value,s) = do drawTextA hta vta (axisPoint value `pvadd` awayFromAxis offset) s textDimension s ag = _axis_label_gap as pickfn = Just . invAxisPoint hBufferRect :: Rect -> Rect hBufferRect (Rect p (Point x y)) = Rect p $ Point x' y where x' = x + w/2 w = x - p_x p noOverlaps :: [Rect] -> Bool noOverlaps [] = True noOverlaps [_] = True noOverlaps (x:y:l) | rectsOverlap x y = False | otherwise = noOverlaps (y:l) rectsOverlap :: Rect -> Rect -> Bool rectsOverlap (Rect p1 p2) r = any (withinRect r) ps where (Point x1 y1) = p1 (Point x2 y2) = p2 p3 = Point x1 y2 p4 = Point x2 y1 ps = [p1,p2,p3,p4] eachNth :: Int -> [a] -> [a] eachNth n = skipN where n' = n - 1 skipN [] = [] skipN (x:xs) = x : skipN (drop n' xs) withinRect :: Rect -> Point -> Bool withinRect (Rect (Point x1 y1) (Point x2 y2)) (Point x y) = and [x >= x1 && x <= x2, y >= y1 && y <= y2] axisMapping :: AxisT z -> RectSize -> (Double,Double,Double,Double,Vector,z->Point,Point->z) axisMapping (AxisT et _ rev ad) (x2,y2) = case et of E_Top -> (x1,y2,x2,y2, Vector 0 1, mapx y2, imapx) E_Bottom -> (x1,y1,x2,y1, Vector 0 (-1), mapx y1, imapx) E_Left -> (x2,y2,x2,y1, Vector 1 0, mapy x2, imapy) E_Right -> (x1,y2,x1,y1, Vector (-1) 0, mapy x1, imapy) where (x1,y1) = (0,0) xr = reverseR (x1,x2) yr = reverseR (y2,y1) mapx y x = Point (_axis_viewport ad xr x) y mapy x y = Point x (_axis_viewport ad yr y) imapx (Point x _) = _axis_tropweiv ad xr x imapy (Point _ y) = _axis_tropweiv ad yr y reverseR r@(r0,r1) = if rev then (r1,r0) else r -- renderAxisGrid :: RectSize -> AxisT z -> BackendProgram () renderAxisGrid sz@(w,h) at@(AxisT re as _ ad) = withLineStyle (_axis_grid_style as) $ mapM_ (drawGridLine re) (_axis_grid ad) where (_,_,_,_,_,axisPoint,_) = axisMapping at sz drawGridLine E_Top = vline drawGridLine E_Bottom = vline drawGridLine E_Left = hline drawGridLine E_Right = hline vline v = let v' = p_x (axisPoint v) in alignStrokePoints [Point v' 0,Point v' h] >>= strokePointPath hline v = let v' = p_y (axisPoint v) in alignStrokePoints [Point 0 v',Point w v'] >>= strokePointPath -- | Construct an axis given the positions for ticks, grid lines, and -- labels, and the labelling function makeAxis :: PlotValue x => ([x] -> [String]) -> ([x],[x],[x]) -> AxisData x makeAxis labelf (labelvs, tickvs, gridvs) = AxisData { _axis_visibility = def, _axis_viewport = newViewport, _axis_tropweiv = newTropweiv, _axis_ticks = newTicks, _axis_grid = gridvs, _axis_labels = [newLabels] } where newViewport = vmap (min',max') newTropweiv = invmap (min',max') newTicks = [ (v,2) | v <- tickvs ] ++ [ (v,5) | v <- labelvs ] newLabels = zipWithLengthCheck labelvs (labelf labelvs) where zipWithLengthCheck (x:xs) (y:ys) = (x,y) : zipWithLengthCheck xs ys zipWithLengthCheck [] [] = [] zipWithLengthCheck _ _ = error "makeAxis: label function returned the wrong number of labels" min' = minimum labelvs max' = maximum labelvs -- | Construct an axis given the positions for ticks, grid lines, and -- labels, and the positioning and labelling functions makeAxis' :: Ord x => (x -> Double) -> (Double -> x) -> ([x] -> [String]) -> ([x],[x],[x]) -> AxisData x makeAxis' t f labelf (labelvs, tickvs, gridvs) = AxisData { _axis_visibility = def, _axis_viewport = linMap t (minimum labelvs, maximum labelvs), _axis_tropweiv = invLinMap f t (minimum labelvs, maximum labelvs), _axis_ticks = zip tickvs (repeat 2) ++ zip labelvs (repeat 5), _axis_grid = gridvs, _axis_labels = let zipWithLengthCheck (x:xs) (y:ys) = (x,y) : zipWithLengthCheck xs ys zipWithLengthCheck [] [] = [] zipWithLengthCheck _ _ = error "makeAxis': label function returned the wrong number of labels" in [zipWithLengthCheck labelvs (labelf labelvs)] } ---------------------------------------------------------------------- -- | The default 'LineStyle' of an axis. defaultAxisLineStyle :: LineStyle defaultAxisLineStyle = solidLine 1 $ opaque black -- | The default 'LineStyle' of a plot area grid. defaultGridLineStyle :: LineStyle defaultGridLineStyle = dashedLine 1 [5,5] $ opaque lightgrey instance Default AxisStyle where def = AxisStyle { _axis_line_style = defaultAxisLineStyle , _axis_label_style = def , _axis_grid_style = defaultGridLineStyle , _axis_label_gap = 10 } -- | By default all parts of a axis are visible. instance Default AxisVisibility where def = AxisVisibility { _axis_show_line = True , _axis_show_ticks = True , _axis_show_labels = True } ---------------------------------------------------------------------- -- | A linear mapping of points in one range to another. vmap :: PlotValue x => (x,x) -> Range -> x -> Double vmap (v1,v2) (v3,v4) v = v3 + (toValue v - toValue v1) * (v4-v3) / (toValue v2 - toValue v1) -- | The inverse mapping from device co-ordinate range back to -- interesting values. invmap :: PlotValue x => (x,x) -> Range -> Double -> x invmap (v3,v4) (d1,d2) d = fromValue (toValue v3 + ( (d-d1) * doubleRange / (d2-d1) )) where doubleRange = toValue v4 - toValue v3 -- | A linear mapping of points in one range to another. linMap :: (a -> Double) -> (a,a) -> Range -> a -> Double linMap f (x1,x2) (d1,d2) x = d1 + (d2 - d1) * (f x - f x1) / (f x2 - f x1) -- | An inverse linear mapping of points from one range to another. invLinMap :: (Double -> a) -> (a -> Double) -> (a,a) -> Range -> Double -> a invLinMap f t (v3,v4) (d1,d2) d = f (t v3 + ( (d-d1) * doubleRange / (d2-d1) )) where doubleRange = t v4 - t v3 $( makeLenses ''AxisVisibility ) $( makeLenses ''AxisData ) $( makeLenses ''AxisStyle ) Chart-1.9.5/Graphics/Rendering/Chart/Axis/Unit.hs0000644000000000000000000000163607346545000017663 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Chart.Axis.Unit -- Copyright : (c) Tim Docker 2010 -- License : BSD-style (see chart/COPYRIGHT) -- -- Calculate and render unit indexed axes {-# OPTIONS_GHC -fno-warn-orphans #-} module Graphics.Rendering.Chart.Axis.Unit( unitAxis, ) where import Data.Default.Class import Graphics.Rendering.Chart.Axis.Types instance PlotValue () where toValue () = 0 fromValue = const () autoAxis = const unitAxis unitAxis :: AxisData () unitAxis = AxisData { _axis_visibility = def { _axis_show_ticks = False , _axis_show_labels = False }, _axis_viewport = \(x0,x1) _ -> (x0+x1)/2, _axis_tropweiv = \_ _ -> (), _axis_ticks = [((), 0)], _axis_labels = [[((), "")]], _axis_grid = [] } Chart-1.9.5/Graphics/Rendering/Chart/Backend.hs0000644000000000000000000000251207346545000017361 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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 Chart-1.9.5/Graphics/Rendering/Chart/Backend/0000755000000000000000000000000007346545000017025 5ustar0000000000000000Chart-1.9.5/Graphics/Rendering/Chart/Backend/Impl.hs0000644000000000000000000001275307346545000020272 0ustar0000000000000000{-# 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) Chart-1.9.5/Graphics/Rendering/Chart/Backend/Types.hs0000644000000000000000000001433707346545000020475 0ustar0000000000000000{-# 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 ) Chart-1.9.5/Graphics/Rendering/Chart/Drawing.hs0000644000000000000000000004260407346545000017433 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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 ) Chart-1.9.5/Graphics/Rendering/Chart/Easy.hs0000644000000000000000000000717607346545000016746 0ustar0000000000000000{-# 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 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)) Chart-1.9.5/Graphics/Rendering/Chart/Geometry.hs0000644000000000000000000003044007346545000017626 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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_ Chart-1.9.5/Graphics/Rendering/Chart/Grid.hs0000644000000000000000000002677707346545000016742 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Chart.Grid -- Copyright : (c) Tim Docker 2010, 2014 -- License : BSD-style (see chart/COPYRIGHT) -- -- A container type for values that can be composed by horizonal -- and vertical layout. module Graphics.Rendering.Chart.Grid ( Grid, Span, SpaceWeight, tval, tspan, empty, nullt, (.|.), (./.), above, aboveN, beside, besideN, overlay, width, height, gridToRenderable, weights, aboveWide, wideAbove, tallBeside, besideTall, fullOverlayUnder, fullOverlayOver ) where import Data.Array import Control.Monad import Graphics.Rendering.Chart.Renderable import Graphics.Rendering.Chart.Geometry hiding (x0, y0) import Graphics.Rendering.Chart.Drawing type Span = (Int,Int) type Size = (Int,Int) -- | When more space is available for an item than the total width of items, -- extra added space is proportional to 'space weight'. type SpaceWeight = (Double,Double) type Cell a = (a,Span,SpaceWeight) -- | Abstract datatype representing a grid. data Grid a = Value (a,Span,SpaceWeight) -- ^ A singleton grid item "a" spanning -- a given rectangle (measured in grid -- cells), with given space weight. | Above (Grid a) (Grid a) Size -- ^ One grid above the other. "Size" is -- their cached total size (so it is -- NOT specified manually). | Beside (Grid a) (Grid a) Size -- ^ One grid horizontally beside -- the other. | Overlay (Grid a) (Grid a) Size -- ^ Two grids positioned one over -- the other. | Empty -- ^ An empty 1x1 grid cell. | Null -- ^ An empty 0x0 grid cell. deriving (Show) width :: Grid a -> Int width Null = 0 width Empty = 1 width (Value _) = 1 width (Beside _ _ (w,_)) = w width (Above _ _ (w,_)) = w width (Overlay _ _ (w,_)) = w height :: Grid a -> Int height Null = 0 height Empty = 1 height (Value _) = 1 height (Beside _ _ (_,h)) = h height (Above _ _ (_,h)) = h height (Overlay _ _ (_,h)) = h -- | A 1x1 grid from a given value, with no extra space. tval :: a -> Grid a tval a = Value (a,(1,1),(0,0)) -- | A WxH (measured in cells) grid from a given value, with space weight (1,1). tspan :: a -> Span -> Grid a tspan a spn = Value (a,spn,(1,1)) -- | A 1x1 empty grid. empty :: Grid a empty = Empty -- | A 0x0 empty grid. nullt :: Grid a nullt = Null above, beside :: Grid a -> Grid a -> Grid a above Null t = t above t Null = t above t1 t2 = Above t1 t2 size where size = (max (width t1) (width t2), height t1 + height t2) -- | A value occupying 1 row with the same horizontal span as the grid. wideAbove :: a -> Grid a -> Grid a wideAbove a g = weights (0,0) (tspan a (width g,1)) `above` g -- | A value placed below the grid, occupying 1 row with the same -- horizontal span as the grid. aboveWide :: Grid a -> a -> Grid a aboveWide g a = g `above` weights (0,0) (tspan a (width g,1)) -- | A value placed to the left of the grid, occupying 1 column with -- the same vertical span as the grid. tallBeside :: a -> Grid a -> Grid a tallBeside a g = weights (0,0) (tspan a (1,height g)) `beside` g -- | A value placed to the right of the grid, occupying 1 column with -- the same vertical span as the grid. besideTall :: Grid a -> a -> Grid a besideTall g a = g `beside` weights (0,0) (tspan a (1,height g)) -- | A value placed under a grid, with the same span as the grid. fullOverlayUnder :: a -> Grid a -> Grid a fullOverlayUnder a g = g `overlay` tspan a (width g,height g) -- | A value placed over a grid, with the same span as the grid. fullOverlayOver :: a -> Grid a -> Grid a fullOverlayOver a g = tspan a (width g,height g) `overlay` g beside Null t = t beside t Null = t beside t1 t2 = Beside t1 t2 size where size = (width t1 + width t2, max (height t1) (height t2)) aboveN, besideN :: [Grid a] -> Grid a aboveN = foldl above nullt besideN = foldl beside nullt -- | One grid over the other. The first argument is shallow, the second is deep. overlay :: Grid a -> Grid a -> Grid a overlay Null t = t overlay t Null = t overlay t1 t2 = Overlay t1 t2 size where size = (max (width t1) (width t2), max (height t1) (height t2)) -- | A synonym for 'beside'. (.|.) :: Grid a -> Grid a -> Grid a (.|.) = beside -- | A synonym for 'above'. (./.) :: Grid a -> Grid a -> Grid a (./.) = above -- | Sets the space weight of *every* cell of the grid to given value. weights :: SpaceWeight -> Grid a -> Grid a weights _ Null = Null weights _ Empty = Empty weights sw (Value (v,sp,_)) = Value (v,sp,sw) weights sw (Above t1 t2 sz) = Above (weights sw t1) (weights sw t2) sz weights sw (Beside t1 t2 sz) = Beside (weights sw t1) (weights sw t2) sz weights sw (Overlay t1 t2 sz) = Overlay (weights sw t1) (weights sw t2) sz -- fix me, need to make .|. and .||. higher precedence -- than ./. and .//. instance Functor Grid where fmap f (Value (a,spn,ew)) = Value (f a,spn,ew) fmap f (Above t1 t2 s) = Above (fmap f t1) (fmap f t2) s fmap f (Beside t1 t2 s) = Beside (fmap f t1) (fmap f t2) s fmap f (Overlay t1 t2 s) = Overlay (fmap f t1) (fmap f t2) s fmap _ Empty = Empty fmap _ Null = Null mapGridM :: Monad m => (a -> m b) -> Grid a -> m (Grid b) mapGridM f (Value (a,spn,ew)) = do b <- f a return (Value (b,spn,ew)) mapGridM f (Above t1 t2 s) = do t1' <- mapGridM f t1 t2' <- mapGridM f t2 return (Above t1' t2' s) mapGridM f (Beside t1 t2 s) = do t1' <- mapGridM f t1 t2' <- mapGridM f t2 return (Beside t1' t2' s) mapGridM f (Overlay t1 t2 s) = do t1' <- mapGridM f t1 t2' <- mapGridM f t2 return (Overlay t1' t2' s) mapGridM _ Empty = return Empty mapGridM _ Null = return Null ---------------------------------------------------------------------- type FlatGrid a = Array (Int,Int) [(a,Span,SpaceWeight)] flatten :: Grid a -> FlatGrid a flatten t = accumArray (flip (:)) [] ((0,0), (width t - 1, height t - 1)) (flatten2 (0,0) t []) type FlatEl a = ((Int,Int),Cell a) flatten2 :: (Int,Int) -> Grid a -> [FlatEl a] -> [FlatEl a] flatten2 _ Empty els = els flatten2 _ Null els = els flatten2 i (Value cell) els = (i,cell):els flatten2 i@(x,y) (Above t1 t2 _) els = (f1.f2) els where f1 = flatten2 i t1 f2 = flatten2 (x,y + height t1) t2 flatten2 i@(x,y) (Beside t1 t2 _) els = (f1.f2) els where f1 = flatten2 i t1 f2 = flatten2 (x + width t1, y) t2 flatten2 i (Overlay t1 t2 _) els = (f1.f2) els where f1 = flatten2 i t1 f2 = flatten2 i t2 foldT :: ((Int,Int) -> Cell a -> r -> r) -> r -> FlatGrid a -> r foldT f iv ft = foldr f' iv (assocs ft) where f' (i,vs) r = foldr (f i) r vs ---------------------------------------------------------------------- type DArray = Array Int Double getSizes :: Grid (Renderable a) -> BackendProgram (DArray, DArray, DArray, DArray) getSizes t = do szs <- mapGridM minsize t :: BackendProgram (Grid RectSize) let szs' = flatten szs let widths = accumArray max 0 (0, width t - 1) (foldT (ef wf fst) [] szs') let heights = accumArray max 0 (0, height t - 1) (foldT (ef hf snd) [] szs') let xweights = accumArray max 0 (0, width t - 1) (foldT (ef xwf fst) [] szs') let yweights = accumArray max 0 (0, height t - 1) (foldT (ef ywf snd) [] szs') return (widths,heights,xweights,yweights) where wf (x,_) (w,_) _ = (x,w) hf (_,y) (_,h) _ = (y,h) xwf (x,_) _ (xw,_) = (x,xw) ywf (_,y) _ (_,yw) = (y,yw) ef f ds loc (size,spn,ew) r | ds spn == 1 = f loc size ew:r | otherwise = r instance (ToRenderable a) => ToRenderable (Grid a) where toRenderable = gridToRenderable . fmap toRenderable gridToRenderable :: Grid (Renderable a) -> Renderable a gridToRenderable gt = Renderable minsizef renderf where minsizef :: BackendProgram RectSize minsizef = do (widths, heights, _, _) <- getSizes gt return (sum (elems widths), sum (elems heights)) renderf (w,h) = do (widths, heights, xweights, yweights) <- getSizes gt let widths' = addExtraSpace w widths xweights let heights' = addExtraSpace h heights yweights let borders = (ctotal widths',ctotal heights') rf1 borders (0,0) gt -- (x borders, y borders) -> (x,y) -> grid -> drawing rf1 borders loc@(i,j) t = case t of Null -> return nullPickFn Empty -> return nullPickFn (Value (r,spn,_)) -> do let (Rect p0 p1) = mkRect borders loc spn (Point x0 y0) <- alignFillPoint p0 (Point x1 y1) <- alignFillPoint p1 withTranslation (Point x0 y0) $ do pf <- render r (x1-x0,y1-y0) return (newpf pf x0 y0) (Above t1 t2 _) -> do pf1 <- rf1 borders (i,j) t1 pf2 <- rf1 borders (i,j+height t1) t2 let pf p@(Point _ y) = if y < (snd borders ! (j + height t1)) then pf1 p else pf2 p return pf (Beside t1 t2 _) -> do pf1 <- rf1 borders (i,j) t1 pf2 <- rf1 borders (i+width t1,j) t2 let pf p@(Point x _) = if x < (fst borders ! (i + width t1)) then pf1 p else pf2 p return pf (Overlay t1 t2 _) -> do pf2 <- rf1 borders (i,j) t2 pf1 <- rf1 borders (i,j) t1 let pf p = pf1 p `mplus` pf2 p return pf newpf pf x0 y0 (Point x1 y1) = pf (Point (x1-x0) (y1-y0)) -- (x borders, y borders) -> (x,y) -> (w,h) -- -> rectangle of grid[x..x+w, y..y+h] mkRect :: (DArray, DArray) -> (Int,Int) -> (Int,Int) -> Rect mkRect (cwidths,cheights) (x,y) (w,h) = Rect (Point x1 y1) (Point x2 y2) where x1 = cwidths ! x y1 = cheights ! y x2 = cwidths ! min (x+w) (snd $ bounds cwidths) y2 = cheights ! min (y+h) (snd $ bounds cheights) -- mx = fst (bounds cwidths) -- my = fst (bounds cheights) -- total size -> item sizes -> item weights -> new item sizes such that -- their sum == total size, and added size is proportional to weight addExtraSpace :: Double -> DArray -> DArray -> DArray addExtraSpace size sizes weights' = if totalws == 0 then sizes else listArray (bounds sizes) sizes' where ws = elems weights' totalws = sum ws extra = size - sum (elems sizes) extras = map (*(extra/totalws)) ws sizes' = zipWith (+) extras (elems sizes) -- [1,2,3] -> [0,1,3,6]. ctotal :: DArray -> DArray ctotal a = listArray (let (i,j) = bounds a in (i,j+1)) (scanl (+) 0 (elems a)) Chart-1.9.5/Graphics/Rendering/Chart/Layout.hs0000644000000000000000000010424507346545000017315 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Chart.Layout -- 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) Chart-1.9.5/Graphics/Rendering/Chart/Legend.hs0000644000000000000000000001007307346545000017231 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Chart.Legend -- Copyright : (c) Tim Docker 2006, 2014 -- License : BSD-style (see chart/COPYRIGHT) -- -- Types and functions for handling the legend(s) on a chart. A legend -- is an area on the chart used to label the plotted values. {-# LANGUAGE TemplateHaskell #-} module Graphics.Rendering.Chart.Legend( Legend(..), LegendStyle(..), LegendOrientation(..), LegendPosition(..), legendToRenderable, legend_label_style, legend_margin, legend_plot_size, legend_orientation, legend_position ) where import Data.List (partition,intersperse) import Control.Lens import Data.Default.Class import Graphics.Rendering.Chart.Geometry import Graphics.Rendering.Chart.Drawing import Graphics.Rendering.Chart.Renderable import Graphics.Rendering.Chart.Grid ---------------------------------------------------------------------- -- Legend data LegendStyle = LegendStyle { _legend_label_style :: FontStyle, _legend_margin :: Double, _legend_plot_size :: Double, _legend_orientation :: LegendOrientation, _legend_position :: LegendPosition } -- | Legends can be constructed in two orientations: in rows -- (where we specify the maximum number of columns), and in -- columns (where we specify the maximum number of rows) data LegendOrientation = LORows Int | LOCols Int -- | Defines the position of the legend, relative to the plot. data LegendPosition = LegendAbove | LegendBelow | LegendRight | LegendLeft data Legend x y = Legend LegendStyle [(String, Rect -> BackendProgram ())] instance ToRenderable (Legend x y) where toRenderable = setPickFn nullPickFn . legendToRenderable legendToRenderable :: Legend x y -> Renderable String legendToRenderable (Legend ls lvs) = gridToRenderable grid where grid :: Grid (Renderable String) grid = case _legend_orientation ls of LORows n -> mkGrid n aboveG besideG LOCols n -> mkGrid n besideG aboveG aboveG, besideG :: [Grid (Renderable String)] -> Grid (Renderable String) aboveG = aboveN.intersperse ggap1 besideG = besideN.intersperse ggap1 mkGrid :: Int -> ([Grid (Renderable String)] -> Grid (Renderable String)) -> ([Grid (Renderable String)] -> Grid (Renderable String)) -> Grid (Renderable String) mkGrid n join1 join2 = join1 [ join2 (map rf ps1) | ps1 <- groups n ps ] ps :: [(String, [Rect -> BackendProgram ()])] ps = join_nub lvs rf :: (String, [Rect -> BackendProgram ()]) -> Grid (Renderable String) rf (title,rfs) = besideN [gpic,ggap2,gtitle] where gpic :: Grid (Renderable String) gpic = besideN $ intersperse ggap2 (map rp rfs) gtitle :: Grid (Renderable String) gtitle = tval $ lbl title rp :: (Rect -> BackendProgram ()) -> Grid (Renderable String) rp rfn = tval Renderable { minsize = return (_legend_plot_size ls, 0), render = \(w,h) -> do _ <- rfn (Rect (Point 0 0) (Point w h)) return (\_-> Just title) } ggap1, ggap2 :: Grid (Renderable String) ggap1 = tval $ spacer (_legend_margin ls,_legend_margin ls / 2) ggap2 = tval $ spacer1 (lbl "X") lbl :: String -> Renderable String lbl = label (_legend_label_style ls) HTA_Left VTA_Centre groups :: Int -> [a] -> [[a]] groups _ [] = [] groups n vs = let (vs1,vs2) = splitAt n vs in vs1:groups n vs2 join_nub :: [(String, a)] -> [(String, [a])] join_nub ((x,a1):ys) = case partition ((==x) . fst) ys of (xs, rest) -> (x, a1:map snd xs) : join_nub rest join_nub [] = [] instance Default LegendStyle where def = LegendStyle { _legend_label_style = def , _legend_margin = 20 , _legend_plot_size = 20 , _legend_orientation = LORows 4 , _legend_position = LegendBelow } $( makeLenses ''LegendStyle ) Chart-1.9.5/Graphics/Rendering/Chart/Plot.hs0000644000000000000000000000302607346545000016751 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Chart.Plot -- Copyright : (c) Tim Docker 2006 -- License : BSD-style (see chart/COPYRIGHT) -- -- Code to calculate and render various types of plots. -- module Graphics.Rendering.Chart.Plot( module Graphics.Rendering.Chart.Plot.Types, module Graphics.Rendering.Chart.Plot.Lines, module Graphics.Rendering.Chart.Plot.Vectors, module Graphics.Rendering.Chart.Plot.Points, module Graphics.Rendering.Chart.Plot.FillBetween, module Graphics.Rendering.Chart.Plot.ErrBars, module Graphics.Rendering.Chart.Plot.Candle, module Graphics.Rendering.Chart.Plot.Bars, module Graphics.Rendering.Chart.Plot.Hidden, module Graphics.Rendering.Chart.Plot.Annotation, module Graphics.Rendering.Chart.Plot.AreaSpots, module Graphics.Rendering.Chart.Plot.Pie, module Graphics.Rendering.Chart.Plot.Histogram, ) where import Graphics.Rendering.Chart.Plot.Types import Graphics.Rendering.Chart.Plot.Lines import Graphics.Rendering.Chart.Plot.Vectors import Graphics.Rendering.Chart.Plot.Points import Graphics.Rendering.Chart.Plot.FillBetween import Graphics.Rendering.Chart.Plot.ErrBars import Graphics.Rendering.Chart.Plot.Candle import Graphics.Rendering.Chart.Plot.Bars import Graphics.Rendering.Chart.Plot.Hidden import Graphics.Rendering.Chart.Plot.Annotation import Graphics.Rendering.Chart.Plot.AreaSpots import Graphics.Rendering.Chart.Plot.Pie import Graphics.Rendering.Chart.Plot.Histogram Chart-1.9.5/Graphics/Rendering/Chart/Plot/0000755000000000000000000000000007346545000016414 5ustar0000000000000000Chart-1.9.5/Graphics/Rendering/Chart/Plot/Annotation.hs0000644000000000000000000000732007346545000021064 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Chart.Plot.Annotation -- Copyright : (c) Tim Docker 2006, 2014 -- License : BSD-style (see chart/COPYRIGHT) -- -- Show textual annotations on a chart. {-# LANGUAGE TemplateHaskell #-} module Graphics.Rendering.Chart.Plot.Annotation( PlotAnnotation(..), plot_annotation_hanchor, plot_annotation_vanchor, plot_annotation_angle, plot_annotation_style, plot_annotation_background, plot_annotation_offset, plot_annotation_values ) where import Control.Lens import Data.Default.Class import Graphics.Rendering.Chart.Geometry import Graphics.Rendering.Chart.Drawing import Graphics.Rendering.Chart.Renderable import Graphics.Rendering.Chart.Plot.Types import Graphics.Rendering.Chart.Drawing import Graphics.Rendering.Chart.Geometry import Graphics.Rendering.Chart.Plot.Types -- | Value for describing a series of text annotations -- to be placed at arbitrary points on the graph. Annotations -- can be rotated and styled. data PlotAnnotation x y = PlotAnnotation { _plot_annotation_hanchor :: HTextAnchor, _plot_annotation_vanchor :: VTextAnchor, _plot_annotation_angle :: Double, -- ^ Angle, in degrees, to rotate the annotation about the anchor point. _plot_annotation_style :: FontStyle, _plot_annotation_background :: Rectangle, -- ^ Rectangle which style determines the background of the annotation -- text and which '_rect_minsize' determines the additional width and -- height of the background area _plot_annotation_offset :: Vector, _plot_annotation_values :: [(x,y,String)] } instance ToPlot PlotAnnotation where toPlot p = Plot { _plot_render = renderAnnotation p, _plot_legend = [], _plot_all_points = (map (^._1) vs , map (^._2) vs) } where vs = _plot_annotation_values p renderAnnotation :: PlotAnnotation x y -> PointMapFn x y -> BackendProgram () renderAnnotation p pMap = withFontStyle style $ do mapM_ drawRect values mapM_ drawOne values where hta = _plot_annotation_hanchor p vta = _plot_annotation_vanchor p values = _plot_annotation_values p angle = _plot_annotation_angle p style = _plot_annotation_style p offset = _plot_annotation_offset p rectangle = _plot_annotation_background p (x1,y1) = _rect_minsize rectangle drawRect (x,y,s) = do ts <- textSize s let (x2,y2) = (textSizeWidth ts, textSizeHeight ts) Point x3 y3 = point x y -- position of top-left vertex of the rectangle xvp HTA_Left = x3 - x1 / 2 xvp HTA_Centre = x3 - (x1 + x2) / 2 xvp HTA_Right = x3 - x2 - x1 / 2 yvp VTA_Top = y3 - y1 / 2 yvp VTA_Centre = y3 - (y1 + y2) / 2 yvp VTA_Bottom = y3 - y2 - y1 / 2 yvp VTA_BaseLine = y3 - y1 / 2 - textSizeAscent ts drawRectangle (Point (xvp hta) (yvp vta) `pvadd` offset) rectangle{ _rect_minsize = (x1+x2,y1+y2) } drawOne (x,y,s) = drawTextsR hta vta angle (point x y) s point x y = pMap (LValue x, LValue y) `pvadd` offset instance Default (PlotAnnotation x y) where def = PlotAnnotation { _plot_annotation_hanchor = HTA_Centre , _plot_annotation_vanchor = VTA_Centre , _plot_annotation_angle = 0 , _plot_annotation_style = def , _plot_annotation_background = def , _plot_annotation_values = [] , _plot_annotation_offset = Vector 0 0 } $( makeLenses ''PlotAnnotation ) Chart-1.9.5/Graphics/Rendering/Chart/Plot/AreaSpots.hs0000644000000000000000000001761207346545000020660 0ustar0000000000000000-- | -- Module : Graphics.Rendering.Chart.Plot.AreaSpots -- Copyright : (c) Malcolm Wallace 2009 -- License : BSD-style (see COPYRIGHT file) -- -- Area spots are a collection of unconnected filled circles, -- with x,y position, and an independent z value to be represented -- by the relative area of the spots. {-# LANGUAGE TemplateHaskell #-} module Graphics.Rendering.Chart.Plot.AreaSpots ( AreaSpots(..) , area_spots_title , area_spots_linethick , area_spots_linecolour , area_spots_fillcolour , area_spots_opacity , area_spots_max_radius , area_spots_values , AreaSpots4D(..) , area_spots_4d_title , area_spots_4d_linethick , area_spots_4d_palette , area_spots_4d_opacity , area_spots_4d_max_radius , area_spots_4d_values ) where import Graphics.Rendering.Chart.Geometry hiding (scale, x0, y0) import Graphics.Rendering.Chart.Drawing import Graphics.Rendering.Chart.Plot.Types import Graphics.Rendering.Chart.Axis import Control.Lens import Data.Colour hiding (over) import Data.Colour.Names import Data.Default.Class import Control.Monad -- | A collection of unconnected spots, with x,y position, and an -- independent z value to be represented by the area of the spot. data AreaSpots z x y = AreaSpots { _area_spots_title :: String , _area_spots_linethick :: Double , _area_spots_linecolour :: AlphaColour Double , _area_spots_fillcolour :: Colour Double , _area_spots_opacity :: Double , _area_spots_max_radius :: Double -- ^ the largest size of spot , _area_spots_values :: [(x,y,z)] } instance Default (AreaSpots z x y) where def = AreaSpots { _area_spots_title = "" , _area_spots_linethick = 0.1 , _area_spots_linecolour = opaque blue , _area_spots_fillcolour = blue , _area_spots_opacity = 0.2 , _area_spots_max_radius = 20 -- in pixels , _area_spots_values = [] } instance (PlotValue z) => ToPlot (AreaSpots z) where toPlot p = Plot { _plot_render = renderAreaSpots p , _plot_legend = [(_area_spots_title p, renderSpotLegend p)] , _plot_all_points = ( map (^._1) (_area_spots_values p) , map (^._2) (_area_spots_values p) ) } renderAreaSpots :: (PlotValue z) => AreaSpots z x y -> PointMapFn x y -> BackendProgram () renderAreaSpots p pmap = forM_ (scaleMax (_area_spots_max_radius p^(2::Integer)) (_area_spots_values p)) (\ (x,y,z)-> do let radius = sqrt z let psSpot = filledCircles radius $ flip withOpacity (_area_spots_opacity p) $ _area_spots_fillcolour p drawPoint psSpot (pmap (LValue x, LValue y)) let psOutline = hollowCircles radius (_area_spots_linethick p) (_area_spots_linecolour p) drawPoint psOutline (pmap (LValue x, LValue y)) ) where scaleMax :: PlotValue z => Double -> [(x,y,z)] -> [(x,y,Double)] scaleMax n points = let largest = maximum (map (^._3.to toValue) points) scale v = n * toValue v / largest in over (mapped._3) scale points renderSpotLegend :: AreaSpots z x y -> Rect -> BackendProgram () renderSpotLegend p (Rect p1 p2) = do let radius = min (abs (p_y p1 - p_y p2)) (abs (p_x p1 - p_x p2)) centre = linearInterpolate p1 p2 psSpot = filledCircles radius $ withOpacity (_area_spots_fillcolour p) (_area_spots_opacity p) psOutline = hollowCircles radius (_area_spots_linethick p) (_area_spots_linecolour p) drawPoint psSpot centre drawPoint psOutline centre where linearInterpolate (Point x0 y0) (Point x1 y1) = Point (x0 + abs(x1-x0)/2) (y0 + abs(y1-y0)/2) -- | A collection of unconnected spots, with x,y position, an -- independent z value to be represented by the area of the spot, -- and in addition, a fourth variable t to be represented by a colour -- from a given palette. (A linear transfer function from t to palette -- is assumed.) data AreaSpots4D z t x y = AreaSpots4D { _area_spots_4d_title :: String , _area_spots_4d_linethick :: Double , _area_spots_4d_palette :: [Colour Double] , _area_spots_4d_opacity :: Double , _area_spots_4d_max_radius :: Double -- ^ the largest size of spot , _area_spots_4d_values :: [(x,y,z,t)] } instance Default (AreaSpots4D z t x y) where def = AreaSpots4D { _area_spots_4d_title = "" , _area_spots_4d_linethick = 0.1 , _area_spots_4d_palette = [ blue, green, yellow, orange, red ] , _area_spots_4d_opacity = 0.2 , _area_spots_4d_max_radius = 20 -- in pixels , _area_spots_4d_values = [] } instance (PlotValue z, PlotValue t, Show t) => ToPlot (AreaSpots4D z t) where toPlot p = Plot { _plot_render = renderAreaSpots4D p , _plot_legend = [ (_area_spots_4d_title p , renderSpotLegend4D p) ] , _plot_all_points = ( map (^._1) (_area_spots_4d_values p) , map (^._2) (_area_spots_4d_values p) ) } renderAreaSpots4D :: (PlotValue z, PlotValue t, Show t) => AreaSpots4D z t x y -> PointMapFn x y -> BackendProgram () renderAreaSpots4D p pmap = forM_ (scaleMax (_area_spots_4d_max_radius p^(2::Integer)) (length (_area_spots_4d_palette p)) (_area_spots_4d_values p)) (\ (x,y,z,t)-> do let radius = sqrt z let colour = _area_spots_4d_palette p !! t let psSpot = filledCircles radius $ withOpacity colour (_area_spots_4d_opacity p) drawPoint psSpot (pmap (LValue x, LValue y)) let psOutline = hollowCircles radius (_area_spots_4d_linethick p) (opaque colour) drawPoint psOutline (pmap (LValue x, LValue y)) ) where scaleMax :: (PlotValue z, PlotValue t, Show t) => Double -> Int -> [(x,y,z,t)] -> [(x,y,Double,Int)] scaleMax n c points = let largest = maximum (map (^._3.to toValue) points) scale v = n * toValue v / largest colVals = map (^._4.to toValue) points colMin = minimum colVals colMax = maximum colVals select t = min (c-1) $ truncate ( fromIntegral c * (toValue t-colMin) / (colMax-colMin)) in map (\ (x,y,z,t) -> (x,y, scale z, select t)) points renderSpotLegend4D :: AreaSpots4D z t x y -> Rect -> BackendProgram () renderSpotLegend4D p (Rect p1 p2) = do let radius = min (abs (p_y p1 - p_y p2)) (abs (p_x p1 - p_x p2)) centre = linearInterpolate p1 p2 palCol = head $ _area_spots_4d_palette p psSpot = filledCircles radius $ withOpacity palCol (_area_spots_4d_opacity p) psOutline = hollowCircles radius (_area_spots_4d_linethick p) (opaque palCol) drawPoint psSpot centre drawPoint psOutline centre where linearInterpolate (Point x0 y0) (Point x1 y1) = Point (x0 + abs(x1-x0)/2) (y0 + abs(y1-y0)/2) $( makeLenses ''AreaSpots ) $( makeLenses ''AreaSpots4D ) Chart-1.9.5/Graphics/Rendering/Chart/Plot/Bars.hs0000644000000000000000000003603007346545000017641 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Chart.Plot.Bars -- Copyright : (c) Tim Docker 2006, 2014 -- License : BSD-style (see chart/COPYRIGHT) -- -- Bar Charts -- {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} module Graphics.Rendering.Chart.Plot.Bars( PlotBars(..), PlotBarsStyle(..), PlotBarsSpacing(..), PlotBarsAlignment(..), BarsPlotValue(..), BarHorizAnchor(..), BarVertAnchor(..), plotBars, plotHBars, plot_bars_style, plot_bars_item_styles, plot_bars_titles, plot_bars_spacing, plot_bars_alignment, plot_bars_singleton_width, plot_bars_label_bar_hanchor, plot_bars_label_bar_vanchor, plot_bars_label_text_hanchor, plot_bars_label_text_vanchor, plot_bars_label_angle, plot_bars_label_style, plot_bars_label_offset, plot_bars_values, plot_bars_settings, plot_bars_values_with_labels, addLabels ) where import Control.Arrow import Control.Lens import Control.Monad import Data.Colour (opaque) import Data.Colour.Names (black) import Data.Default.Class import Data.Tuple(swap) import Data.List(nub,sort) import Graphics.Rendering.Chart.Axis import Graphics.Rendering.Chart.Drawing import Graphics.Rendering.Chart.Geometry hiding (x0, y0) import Graphics.Rendering.Chart.Plot.Types import Graphics.Rendering.Chart.Utils class PlotValue a => BarsPlotValue a where barsIsNull :: a -> Bool -- | The starting level for the chart, a function of some statistic -- (normally the lowest value or just const 0). barsReference :: [a] -> a barsAdd :: a -> a -> a instance BarsPlotValue Double where barsIsNull a = a == 0.0 barsReference = const 0 barsAdd = (+) instance BarsPlotValue Int where barsIsNull a = a == 0 barsReference = const 0 barsAdd = (+) instance BarsPlotValue LogValue where barsIsNull (LogValue a) = a == 0.0 barsReference as = 10.0 ^^ (floor (log10 $ minimum $ filter (/= 0.0) as) :: Integer) barsAdd = (+) data PlotBarsStyle = BarsStacked -- ^ Bars for a fixed x are stacked vertically -- on top of each other. | BarsClustered -- ^ Bars for a fixed x are put horizontally -- beside each other. deriving (Show) data PlotBarsSpacing = BarsFixWidth Double -- ^ All bars have the same width in pixels. | BarsFixGap Double Double -- ^ (BarsFixGap g mw) means make the gaps between -- the bars equal to g, but with a minimum bar width -- of mw deriving (Show) -- | How bars for a given (x,[y]) are aligned with respect to screen -- coordinate corresponding to x (deviceX). data PlotBarsAlignment = BarsLeft -- ^ The left edge of bars is at deviceX | BarsCentered -- ^ Bars are centered around deviceX | BarsRight -- ^ The right edge of bars is at deviceX deriving (Show) data BarHorizAnchor = BHA_Left | BHA_Centre | BHA_Right deriving (Show) data BarVertAnchor = BVA_Bottom | BVA_Centre | BVA_Top deriving (Show) -- | Value describing how to plot a set of bars. -- Note that the input data is typed [(x,[y])], ie for each x value -- we plot several y values. Typically the size of each [y] list would -- be the same. data BarsSettings = BarsSettings { -- | This value specifies whether each value from [y] should be -- shown beside or above the previous value. _bars_settings_style :: PlotBarsStyle, -- | The style in which to draw each element of [y]. A fill style -- is required, and if a linestyle is given, each bar will be -- outlined. _bars_settings_item_styles :: [ (FillStyle,Maybe LineStyle) ], -- | This value controls how the widths of the bars are -- calculated. Either the widths of the bars, or the gaps between -- them can be fixed. _bars_settings_spacing :: PlotBarsSpacing, -- | This value controls how bars for a fixed x are aligned with -- respect to the device coordinate corresponding to x. _bars_settings_alignment :: PlotBarsAlignment, _bars_settings_singleton_width :: Double, -- | The point on the bar to horizontally anchor the label to _bars_settings_label_bar_hanchor :: BarHorizAnchor, -- | The point on the bar to vertically anchor the label to _bars_settings_label_bar_vanchor :: BarVertAnchor, -- | The anchor point on the label. _bars_settings_label_text_hanchor :: HTextAnchor, -- | The anchor point on the label. _bars_settings_label_text_vanchor :: VTextAnchor, -- | Angle, in degrees, to rotate the label about the anchor point. _bars_settings_label_angle :: Double, -- | The style to use for the label. _bars_settings_label_style :: FontStyle, -- | The offset from the anchor point to display the label at. _bars_settings_label_offset :: Vector } instance Default BarsSettings where def = BarsSettings { _bars_settings_style = BarsClustered , _bars_settings_item_styles = cycle istyles , _bars_settings_spacing = BarsFixGap 10 2 , _bars_settings_alignment = BarsCentered , _bars_settings_singleton_width = 20 , _bars_settings_label_bar_hanchor = BHA_Centre , _bars_settings_label_bar_vanchor = BVA_Top , _bars_settings_label_text_hanchor = HTA_Centre , _bars_settings_label_text_vanchor = VTA_Bottom , _bars_settings_label_angle = 0 , _bars_settings_label_style = def , _bars_settings_label_offset = Vector 0 0 } where istyles = map mkstyle defaultColorSeq mkstyle c = (solidFillStyle c, Just (solidLine 1.0 $ opaque black)) data PlotBars x y = PlotBars { _plot_bars_settings :: BarsSettings, -- | The title of each element of [y]. These will be shown in the legend. _plot_bars_titles :: [String], -- | The actual points to be plotted, and their labels _plot_bars_values_with_labels :: [(x, [(y, String)])] } instance Default (PlotBars x y) where def = PlotBars { _plot_bars_settings = def , _plot_bars_titles = [] , _plot_bars_values_with_labels = [] } plotBars :: (BarsPlotValue y) => PlotBars x y -> Plot x y plotBars p = Plot { _plot_render = \pmap -> renderBars s vals yref0 (barRect pmap) (mapX pmap), _plot_legend = zip (_plot_bars_titles p) (map renderPlotLegendBars (_bars_settings_item_styles s)), _plot_all_points = allBarPoints s vals } where s = _plot_bars_settings p vals = _plot_bars_values_with_labels p yref0 = refVal s vals barRect pmap xos width x y0 y1 = Rect (Point (x'+xos) y0') (Point (x'+xos+width) y') where Point x' y' = mapXY pmap (x,y1) Point _ y0' = mapXY pmap (x,y0) mapX pmap x = p_x (mapXY pmap (x, yref0)) plotHBars :: (BarsPlotValue x) => PlotBars y x -> Plot x y plotHBars p = Plot { _plot_render = \pmap -> renderBars s vals xref0 (barRect pmap) (mapY pmap), _plot_legend = zip (_plot_bars_titles p) (map renderPlotLegendBars (_bars_settings_item_styles s)), _plot_all_points = swap $ allBarPoints s vals } where s = _plot_bars_settings p vals = _plot_bars_values_with_labels p xref0 = refVal s vals barRect pmap yos height y x0 x1 = Rect (Point x0' (y'+yos)) (Point x' (y'+yos+height)) where Point x' y' = mapXY pmap (x1,y) Point x0' _ = mapXY pmap (x0,y) mapY pmap y = p_y (mapXY pmap (xref0, y)) renderBars :: (BarsPlotValue v) => BarsSettings -> [(k, [(v, String)])] -> v -> (Double -> Double -> k -> v -> v -> Rect) -> (k -> Double) -> BackendProgram () renderBars p vals vref0 r mapk = case _bars_settings_style p of BarsClustered -> forM_ vals clusteredBars BarsStacked -> forM_ vals stackedBars where clusteredBars (k,vs) = do let offset i = case _bars_settings_alignment p of BarsLeft -> fromIntegral i * bsize BarsRight -> fromIntegral (i-nvs) * bsize BarsCentered -> fromIntegral (2*i-nvs) * bsize/2 forM_ (zip3 [0,1..] vs styles) $ \(i, (v, _), (fstyle,_)) -> unless (barsIsNull v) $ withFillStyle fstyle $ alignFillPath (barPath (offset i) k vref0 v) >>= fillPath forM_ (zip3 [0,1..] vs styles) $ \(i, (v, _), (_,mlstyle)) -> unless (barsIsNull v) $ whenJust mlstyle $ \lstyle -> withLineStyle lstyle $ alignStrokePath (barPath (offset i) k vref0 v) >>= strokePath withFontStyle (_bars_settings_label_style p) $ forM_ (zip [0,1..] vs) $ \(i, (v, txt)) -> unless (null txt) $ do let ha = _bars_settings_label_bar_hanchor p let va = _bars_settings_label_bar_vanchor p let pt = rectCorner ha va (r (offset i) bsize k vref0 v) drawTextR (_bars_settings_label_text_hanchor p) (_bars_settings_label_text_vanchor p) (_bars_settings_label_angle p) (pvadd pt $ _bars_settings_label_offset p) txt stackedBars (k,vs) = do let (vs', lbls) = unzip vs let vs'' = map (\v -> if barsIsNull v then vref0 else v) (stack vs') let v2s = zip (vref0:vs'') vs'' let ofs = case _bars_settings_alignment p of BarsLeft -> 0 BarsRight -> -bsize BarsCentered -> -(bsize/2) forM_ (zip v2s styles) $ \((v0,v1), (fstyle,_)) -> unless (v0 >= v1) $ withFillStyle fstyle $ alignFillPath (barPath ofs k v0 v1) >>= fillPath forM_ (zip v2s styles) $ \((v0,v1), (_,mlstyle)) -> unless (v0 >= v1) $ whenJust mlstyle $ \lstyle -> withLineStyle lstyle $ alignStrokePath (barPath ofs k v0 v1) >>= strokePath withFontStyle (_bars_settings_label_style p) $ forM_ (zip v2s lbls) $ \((v0, v1), txt) -> unless (null txt) $ do let ha = _bars_settings_label_bar_hanchor p let va = _bars_settings_label_bar_vanchor p let pt = rectCorner ha va (r ofs bsize k v0 v1) drawTextR (_bars_settings_label_text_hanchor p) (_bars_settings_label_text_vanchor p) (_bars_settings_label_angle p) (pvadd pt $ _bars_settings_label_offset p) txt styles = _bars_settings_item_styles p barPath os k v0 v1 = rectPath $ r os bsize k v0 v1 bsize = case _bars_settings_spacing p of BarsFixGap gap minw -> let w = max (minKInterval - gap) minw in case _bars_settings_style p of BarsClustered -> w / fromIntegral nvs BarsStacked -> w BarsFixWidth width' -> width' minKInterval = let diffs = zipWith (-) (tail mks) mks in if null diffs then _bars_settings_singleton_width p else minimum diffs where mks = nub $ sort $ map (mapk . fst) vals nvs = maximum $ map (length . snd) vals rectCorner :: BarHorizAnchor -> BarVertAnchor -> Rect -> Point rectCorner h v (Rect (Point x0 y0) (Point x1 y1)) = Point x' y' where x' = case h of BHA_Left -> x0 BHA_Right -> x1 BHA_Centre -> (x0 + x1) / 2 y' = case v of BVA_Bottom -> y0 BVA_Top -> y1 BVA_Centre -> (y0 + y1) / 2 -- Helper function for printing bar values as labels addLabels :: Show y => [(x, [y])] -> [(x, [(y, String)])] addLabels = map . second $ map (\y -> (y, show y)) refVal :: (BarsPlotValue y) => BarsSettings -> [(x, [(y, String)])] -> y refVal p vals = barsReference $ case _bars_settings_style p of BarsClustered -> concatMap (map fst . snd) vals BarsStacked -> concatMap (take 1 . dropWhile barsIsNull . stack . map fst . snd) vals allBarPoints :: (BarsPlotValue y) => BarsSettings -> [(x, [(y, String)])] -> ([x],[y]) allBarPoints p vals = case _bars_settings_style p of BarsClustered -> let ys = concatMap (map fst) yls in ( xs, barsReference ys:ys ) BarsStacked -> let ys = map (stack . map fst) yls in ( xs, barsReference (concatMap (take 1 . dropWhile barsIsNull) ys):concat ys) where (xs, yls) = unzip vals stack :: (BarsPlotValue y) => [y] -> [y] stack = scanl1 barsAdd renderPlotLegendBars :: (FillStyle,Maybe LineStyle) -> Rect -> BackendProgram () renderPlotLegendBars (fstyle,_) r = withFillStyle fstyle $ fillPath (rectPath r) $( makeLenses ''BarsSettings ) $( makeLenses ''PlotBars ) -- Lens provided for backward compat. -- Note that this one does not satisfy the lens laws, as it discards/overwrites the labels. plot_bars_values :: Lens' (PlotBars x y) [(x, [y])] plot_bars_values = lens getter setter where getter = mapYs fst . _plot_bars_values_with_labels setter pb vals' = pb { _plot_bars_values_with_labels = mapYs (, "") vals' } mapYs :: (a -> b) -> [(c, [a])] -> [(c, [b])] mapYs f = map (over _2 $ map f) plot_bars_style :: Lens' (PlotBars x y) PlotBarsStyle plot_bars_style = plot_bars_settings . bars_settings_style plot_bars_item_styles :: Lens' (PlotBars x y) [(FillStyle, Maybe LineStyle)] plot_bars_item_styles = plot_bars_settings . bars_settings_item_styles plot_bars_spacing :: Lens' (PlotBars x y) PlotBarsSpacing plot_bars_spacing = plot_bars_settings . bars_settings_spacing plot_bars_alignment :: Lens' (PlotBars x y) PlotBarsAlignment plot_bars_alignment = plot_bars_settings . bars_settings_alignment plot_bars_singleton_width :: Lens' (PlotBars x y) Double plot_bars_singleton_width = plot_bars_settings . bars_settings_singleton_width plot_bars_label_bar_hanchor :: Lens' (PlotBars x y) BarHorizAnchor plot_bars_label_bar_hanchor = plot_bars_settings . bars_settings_label_bar_hanchor plot_bars_label_bar_vanchor :: Lens' (PlotBars x y) BarVertAnchor plot_bars_label_bar_vanchor = plot_bars_settings . bars_settings_label_bar_vanchor plot_bars_label_text_hanchor :: Lens' (PlotBars x y) HTextAnchor plot_bars_label_text_hanchor = plot_bars_settings . bars_settings_label_text_hanchor plot_bars_label_text_vanchor :: Lens' (PlotBars x y) VTextAnchor plot_bars_label_text_vanchor = plot_bars_settings . bars_settings_label_text_vanchor plot_bars_label_angle :: Lens' (PlotBars x y) Double plot_bars_label_angle = plot_bars_settings . bars_settings_label_angle plot_bars_label_style :: Lens' (PlotBars x y) FontStyle plot_bars_label_style = plot_bars_settings . bars_settings_label_style plot_bars_label_offset :: Lens' (PlotBars x y) Vector plot_bars_label_offset = plot_bars_settings . bars_settings_label_offset Chart-1.9.5/Graphics/Rendering/Chart/Plot/Candle.hs0000644000000000000000000001323507346545000020142 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Chart.Plot.Candle -- Copyright : (c) Tim Docker 2006, 2014 -- License : BSD-style (see chart/COPYRIGHT) -- -- Candlestick charts for financial plotting -- {-# LANGUAGE TemplateHaskell #-} module Graphics.Rendering.Chart.Plot.Candle( PlotCandle(..), Candle(..), plot_candle_title, plot_candle_line_style, plot_candle_tick_length, plot_candle_width, plot_candle_centre, plot_candle_fill, plot_candle_rise_fill_style, plot_candle_fall_fill_style, plot_candle_values, ) where import Control.Lens hiding (op) import Graphics.Rendering.Chart.Geometry hiding (close) import Graphics.Rendering.Chart.Drawing import Graphics.Rendering.Chart.Plot.Types import Control.Monad import Data.Colour (opaque) import Data.Colour.Names (white, blue) import Data.Default.Class -- | Value defining a financial interval: opening and closing prices, with -- maxima and minima; and a style in which to render them. -- By convention, there are different fill styles depending on whether -- the price rises (open < close) or falls (close < open). -- (This plot type can also be re-purposed for statistical intervals, e.g. -- minimum, first quartile, median, third quartile, maximum.) data PlotCandle x y = PlotCandle { _plot_candle_title :: String, _plot_candle_line_style :: LineStyle, _plot_candle_fill :: Bool, _plot_candle_rise_fill_style :: FillStyle, _plot_candle_fall_fill_style :: FillStyle, _plot_candle_tick_length :: Double, _plot_candle_width :: Double, _plot_candle_centre :: Double, _plot_candle_values :: [Candle x y] } -- | A Value holding price intervals for a given x-coord. -- An alternative view is that these are statistical intervals: the -- 0th, 25th, 50th, 75th, and 100th percentiles. data Candle x y = Candle { candle_x :: x , candle_low :: y , candle_open :: y , candle_mid :: y , candle_close :: y , candle_high :: y } deriving (Show) instance ToPlot PlotCandle where toPlot p = Plot { _plot_render = renderPlotCandle p, _plot_legend = [(_plot_candle_title p, renderPlotLegendCandle p)], _plot_all_points = ( map candle_x pts , concat [ [candle_low c, candle_high c] | c <- pts ] ) } where pts = _plot_candle_values p renderPlotCandle :: PlotCandle x y -> PointMapFn x y -> BackendProgram () renderPlotCandle p pmap = mapM_ (drawCandle p . candlemap) (_plot_candle_values p) where candlemap (Candle x lo op mid cl hi) = Candle x' lo' op' mid' cl' hi' where (Point x' mid') = pmap' (x,mid) (Point _ lo') = pmap' (x,lo) (Point _ op') = pmap' (x,op) (Point _ cl') = pmap' (x,cl) (Point _ hi') = pmap' (x,hi) pmap' = mapXY pmap drawCandle :: PlotCandle x y -> Candle Double Double -> BackendProgram () drawCandle ps (Candle x lo open mid close hi) = do let tl = _plot_candle_tick_length ps let wd = _plot_candle_width ps let ct = _plot_candle_centre ps let f = _plot_candle_fill ps -- the pixel coordinate system is inverted wrt the value coords. when f $ withFillStyle (if open >= close then _plot_candle_rise_fill_style ps else _plot_candle_fall_fill_style ps) $ fillPath $ moveTo' (x-wd) open <> lineTo' (x-wd) close <> lineTo' (x+wd) close <> lineTo' (x+wd) open <> lineTo' (x-wd) open withLineStyle (_plot_candle_line_style ps) $ do strokePath $ moveTo' (x-wd) open <> lineTo' (x-wd) close <> lineTo' (x+wd) close <> lineTo' (x+wd) open <> lineTo' (x-wd) open strokePath $ moveTo' x (min lo hi) <> lineTo' x (min open close) <> moveTo' x (max open close) <> lineTo' x (max hi lo) when (tl > 0) $ strokePath $ moveTo' (x-tl) lo <> lineTo' (x+tl) lo <> moveTo' (x-tl) hi <> lineTo' (x+tl) hi when (ct > 0) $ strokePath $ moveTo' (x-ct) mid <> lineTo' (x+ct) mid renderPlotLegendCandle :: PlotCandle x y -> Rect -> BackendProgram () renderPlotLegendCandle pc (Rect p1 p2) = do drawCandle pc2 (Candle (xwid*1/4) lo open mid close hi) drawCandle pc2 (Candle (xwid*2/3) lo close mid open hi) where pc2 = pc { _plot_candle_width = 2 } xwid = p_x p1 + p_x p2 lo = max (p_y p1) (p_y p2) mid = (p_y p1 + p_y p2)/2 hi = min (p_y p1) (p_y p2) open = (lo + mid) / 2 close = (mid + hi) / 2 instance Default (PlotCandle x y) where def = PlotCandle { _plot_candle_title = "" , _plot_candle_line_style = solidLine 1 $ opaque blue , _plot_candle_fill = False , _plot_candle_rise_fill_style = solidFillStyle $ opaque white , _plot_candle_fall_fill_style = solidFillStyle $ opaque blue , _plot_candle_tick_length = 2 , _plot_candle_width = 5 , _plot_candle_centre = 0 , _plot_candle_values = [] } $( makeLenses ''PlotCandle ) Chart-1.9.5/Graphics/Rendering/Chart/Plot/ErrBars.hs0000644000000000000000000001026507346545000020314 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Chart.Plot.ErrBars -- Copyright : (c) Tim Docker 2006, 2014 -- License : BSD-style (see chart/COPYRIGHT) -- -- Plot series of points with associated error bars. -- {-# LANGUAGE TemplateHaskell #-} module Graphics.Rendering.Chart.Plot.ErrBars( PlotErrBars(..), ErrPoint(..), ErrValue(..), symErrPoint, -- * Accessors -- | These accessors are generated by template haskell plot_errbars_title, plot_errbars_line_style, plot_errbars_tick_length, plot_errbars_overhang, plot_errbars_values, ) where import Control.Lens import Graphics.Rendering.Chart.Geometry import Graphics.Rendering.Chart.Drawing import Graphics.Rendering.Chart.Plot.Types import Data.Colour (opaque) import Data.Colour.Names (blue) import Data.Default.Class -- | Value for holding a point with associated error bounds for each axis. data ErrValue x = ErrValue { ev_low :: x, ev_best :: x, ev_high :: x } deriving Show data ErrPoint x y = ErrPoint { ep_x :: ErrValue x, ep_y :: ErrValue y } deriving Show -- | When the error is symmetric, we can simply pass in dx for the error. symErrPoint :: (Num a, Num b) => a -> b -> a -> b -> ErrPoint a b symErrPoint x y dx dy = ErrPoint (ErrValue (x-dx) x (x+dx)) (ErrValue (y-dy) y (y+dy)) -- | Value defining a series of error intervals, and a style in -- which to render them. data PlotErrBars x y = PlotErrBars { _plot_errbars_title :: String, _plot_errbars_line_style :: LineStyle, _plot_errbars_tick_length :: Double, _plot_errbars_overhang :: Double, _plot_errbars_values :: [ErrPoint x y] } instance ToPlot PlotErrBars where toPlot p = Plot { _plot_render = renderPlotErrBars p, _plot_legend = [(_plot_errbars_title p, renderPlotLegendErrBars p)], _plot_all_points = ( concat [ [ev_low x,ev_high x] | ErrPoint x _ <- pts ] , concat [ [ev_low y,ev_high y] | ErrPoint _ y <- pts ] ) } where pts = _plot_errbars_values p renderPlotErrBars :: PlotErrBars x y -> PointMapFn x y -> BackendProgram () renderPlotErrBars p pmap = mapM_ (drawErrBar.epmap) (_plot_errbars_values p) where epmap (ErrPoint (ErrValue xl x xh) (ErrValue yl y yh)) = ErrPoint (ErrValue xl' x' xh') (ErrValue yl' y' yh') where (Point x' y') = pmap' (x,y) (Point xl' yl') = pmap' (xl,yl) (Point xh' yh') = pmap' (xh,yh) drawErrBar = drawErrBar0 p pmap' = mapXY pmap drawErrBar0 :: PlotErrBars x y -> ErrPoint Double Double -> BackendProgram () drawErrBar0 ps (ErrPoint (ErrValue xl x xh) (ErrValue yl y yh)) = do let tl = _plot_errbars_tick_length ps let oh = _plot_errbars_overhang ps withLineStyle (_plot_errbars_line_style ps) $ strokePath $ moveTo' (xl-oh) y <> lineTo' (xh+oh) y <> moveTo' x (yl-oh) <> lineTo' x (yh+oh) <> moveTo' xl (y-tl) <> lineTo' xl (y+tl) <> moveTo' (x-tl) yl <> lineTo' (x+tl) yl <> moveTo' xh (y-tl) <> lineTo' xh (y+tl) <> moveTo' (x-tl) yh <> lineTo' (x+tl) yh renderPlotLegendErrBars :: PlotErrBars x y -> Rect -> BackendProgram () renderPlotLegendErrBars p (Rect p1 p2) = do drawErrBar (symErrPoint (p_x p1) y dx dx) drawErrBar (symErrPoint ((p_x p1 + p_x p2)/2) y dx dx) drawErrBar (symErrPoint (p_x p2) y dx dx) where drawErrBar = drawErrBar0 p dx = min ((p_x p2 - p_x p1)/6) ((p_y p2 - p_y p1)/2) y = (p_y p1 + p_y p2)/2 instance Default (PlotErrBars x y) where def = PlotErrBars { _plot_errbars_title = "" , _plot_errbars_line_style = solidLine 1 $ opaque blue , _plot_errbars_tick_length = 3 , _plot_errbars_overhang = 0 , _plot_errbars_values = [] } $( makeLenses ''PlotErrBars ) Chart-1.9.5/Graphics/Rendering/Chart/Plot/FillBetween.hs0000644000000000000000000000555507346545000021162 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Chart.Plot.FillBetween -- Copyright : (c) Tim Docker 2006, 2014 -- License : BSD-style (see chart/COPYRIGHT) -- -- Plots that fill the area between two lines. -- {-# LANGUAGE TemplateHaskell #-} module Graphics.Rendering.Chart.Plot.FillBetween( PlotFillBetween(..), -- * Accessors -- | These accessors are generated by template haskell plot_fillbetween_title, plot_fillbetween_style, plot_fillbetween_line, plot_fillbetween_values, ) where import Control.Lens import Graphics.Rendering.Chart.Geometry import Graphics.Rendering.Chart.Drawing import Graphics.Rendering.Chart.Plot.Types import Data.Colour (opaque) import Data.Colour.SRGB (sRGB) import Data.Default.Class -- | Value specifying a plot filling the area between two sets of Y -- coordinates, given common X coordinates. data PlotFillBetween x y = PlotFillBetween { _plot_fillbetween_title :: String, _plot_fillbetween_style :: FillStyle, _plot_fillbetween_line :: Maybe LineStyle, _plot_fillbetween_values :: [ (x, (y,y))] } instance ToPlot PlotFillBetween where toPlot p = Plot { _plot_render = renderPlotFillBetween p, _plot_legend = [(_plot_fillbetween_title p,renderPlotLegendFill p)], _plot_all_points = plotAllPointsFillBetween p } renderPlotFillBetween :: PlotFillBetween x y -> PointMapFn x y -> BackendProgram () renderPlotFillBetween p = renderPlotFillBetween' p (_plot_fillbetween_values p) renderPlotFillBetween' :: PlotFillBetween x y -> [(a, (b, b))] -> ((Limit a, Limit b) -> Point) -> BackendProgram () renderPlotFillBetween' _ [] _ = return () renderPlotFillBetween' p vs pmap = withFillStyle (_plot_fillbetween_style p) $ do ps <- alignFillPoints $ [p0] ++ p1s ++ reverse p2s ++ [p0] fillPointPath ps case _plot_fillbetween_line p of Nothing -> return () Just lineStyle -> withLineStyle lineStyle $ strokePointPath ps where pmap' = mapXY pmap (p0:p1s) = map pmap' [ (x,y1) | (x,(y1,_)) <- vs ] p2s = map pmap' [ (x,y2) | (x,(_,y2)) <- vs ] renderPlotLegendFill :: PlotFillBetween x y -> Rect -> BackendProgram () renderPlotLegendFill p r = withFillStyle (_plot_fillbetween_style p) $ fillPath (rectPath r) plotAllPointsFillBetween :: PlotFillBetween x y -> ([x],[y]) plotAllPointsFillBetween p = ( [ x | (x,(_,_)) <- pts ] , concat [ [y1,y2] | (_,(y1,y2)) <- pts ] ) where pts = _plot_fillbetween_values p instance Default (PlotFillBetween x y) where def = PlotFillBetween { _plot_fillbetween_title = "" , _plot_fillbetween_style = solidFillStyle (opaque $ sRGB 0.5 0.5 1.0) , _plot_fillbetween_line = Nothing , _plot_fillbetween_values = [] } $( makeLenses ''PlotFillBetween ) Chart-1.9.5/Graphics/Rendering/Chart/Plot/Hidden.hs0000644000000000000000000000176407346545000020153 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Chart.Plot.Hidden -- Copyright : (c) Tim Docker 2006, 2014 -- License : BSD-style (see chart/COPYRIGHT) -- -- Plots that don't show, but occupy space so as to effect axis -- scaling -- {-# LANGUAGE TemplateHaskell #-} module Graphics.Rendering.Chart.Plot.Hidden( PlotHidden(..), plot_hidden_x_values, plot_hidden_y_values ) where import Control.Lens import Graphics.Rendering.Chart.Plot.Types -- | Value defining some hidden x and y values. The values are -- not displayed, but they still affect axis scaling. data PlotHidden x y = PlotHidden { _plot_hidden_x_values :: [x], _plot_hidden_y_values :: [y] } instance ToPlot PlotHidden where toPlot ph = Plot { _plot_render = \_ -> return (), _plot_legend = [], _plot_all_points = (_plot_hidden_x_values ph, _plot_hidden_y_values ph) } $( makeLenses ''PlotHidden ) Chart-1.9.5/Graphics/Rendering/Chart/Plot/Histogram.hs0000644000000000000000000001553507346545000020716 0ustar0000000000000000{-# 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 ) Chart-1.9.5/Graphics/Rendering/Chart/Plot/Lines.hs0000644000000000000000000000630707346545000020030 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Chart.Plot.Lines -- Copyright : (c) Tim Docker 2006, 2014 -- License : BSD-style (see chart/COPYRIGHT) -- -- Line plots -- {-# LANGUAGE TemplateHaskell #-} module Graphics.Rendering.Chart.Plot.Lines( PlotLines(..), defaultPlotLineStyle, hlinePlot, vlinePlot, plot_lines_title, plot_lines_style, plot_lines_values, plot_lines_limit_values, ) where import Control.Lens import Graphics.Rendering.Chart.Geometry import Graphics.Rendering.Chart.Drawing import Graphics.Rendering.Chart.Plot.Types import Data.Colour (opaque) import Data.Colour.Names (blue) import Data.Default.Class -- | Value defining a series of (possibly disjointed) lines, -- and a style in which to render them. data PlotLines x y = PlotLines { _plot_lines_title :: String, _plot_lines_style :: LineStyle, -- | The lines to be plotted _plot_lines_values :: [[(x,y)]], -- | Additional lines to be plotted, specified using -- the Limit type to allow referencing the edges of -- the plot area. _plot_lines_limit_values :: [[(Limit x, Limit y)]] } instance ToPlot PlotLines where toPlot p = Plot { _plot_render = renderPlotLines p, _plot_legend = [(_plot_lines_title p, renderPlotLegendLines p)], _plot_all_points = ( map fst pts ++ xs, map snd pts ++ ys ) } where pts = concat (_plot_lines_values p) xs = [ x | (LValue x,_) <- concat (_plot_lines_limit_values p)] ys = [ y | (_,LValue y) <- concat (_plot_lines_limit_values p)] renderPlotLines :: PlotLines x y -> PointMapFn x y -> BackendProgram () renderPlotLines p pmap = withLineStyle (_plot_lines_style p) $ do mapM_ (drawLines (mapXY pmap)) (_plot_lines_values p) mapM_ (drawLines pmap) (_plot_lines_limit_values p) where drawLines mapfn pts = alignStrokePoints (map mapfn pts) >>= strokePointPath renderPlotLegendLines :: PlotLines x y -> Rect -> BackendProgram () renderPlotLegendLines p (Rect p1 p2) = withLineStyle (_plot_lines_style p) $ do let y = (p_y p1 + p_y p2) / 2 ps <- alignStrokePoints [Point (p_x p1) y, Point (p_x p2) y] strokePointPath ps defaultPlotLineStyle :: LineStyle defaultPlotLineStyle = (solidLine 1 $ opaque blue){ _line_cap = LineCapRound, _line_join = LineJoinRound } instance Default (PlotLines x y) where def = PlotLines { _plot_lines_title = "" , _plot_lines_style = defaultPlotLineStyle , _plot_lines_values = [] , _plot_lines_limit_values = [] } -- | Helper function to plot a single horizontal line. hlinePlot :: String -> LineStyle -> b -> Plot a b hlinePlot t ls v = toPlot def { _plot_lines_title = t, _plot_lines_style = ls, _plot_lines_limit_values = [[(LMin, LValue v),(LMax, LValue v)]] } -- | Helper function to plot a single vertical line. vlinePlot :: String -> LineStyle -> a -> Plot a b vlinePlot t ls v = toPlot def { _plot_lines_title = t, _plot_lines_style = ls, _plot_lines_limit_values = [[(LValue v,LMin),(LValue v,LMax)]] } $( makeLenses ''PlotLines ) Chart-1.9.5/Graphics/Rendering/Chart/Plot/Pie.hs0000644000000000000000000001674207346545000017477 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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 ) Chart-1.9.5/Graphics/Rendering/Chart/Plot/Points.hs0000644000000000000000000000371107346545000020226 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Chart.Plot.Points -- Copyright : (c) Tim Docker 2006, 2014 -- License : BSD-style (see chart/COPYRIGHT) -- -- Functions to plot sets of points, marked in various styles. {-# LANGUAGE TemplateHaskell #-} module Graphics.Rendering.Chart.Plot.Points( PlotPoints(..), -- * Accessors -- | These accessors are generated by template haskell plot_points_title, plot_points_style, plot_points_values, ) where import Control.Lens import Graphics.Rendering.Chart.Geometry import Graphics.Rendering.Chart.Drawing import Graphics.Rendering.Chart.Plot.Types import Data.Default.Class -- | Value defining a series of datapoints, and a style in -- which to render them. data PlotPoints x y = PlotPoints { _plot_points_title :: String, _plot_points_style :: PointStyle, _plot_points_values :: [(x,y)] } instance ToPlot PlotPoints where toPlot p = Plot { _plot_render = renderPlotPoints p, _plot_legend = [(_plot_points_title p, renderPlotLegendPoints p)], _plot_all_points = (map fst pts, map snd pts) } where pts = _plot_points_values p renderPlotPoints :: PlotPoints x y -> PointMapFn x y -> BackendProgram () renderPlotPoints p pmap = mapM_ (drawPoint ps . pmap') (_plot_points_values p) where pmap' = mapXY pmap ps = _plot_points_style p renderPlotLegendPoints :: PlotPoints x y -> Rect -> BackendProgram () renderPlotLegendPoints p (Rect p1 p2) = do drawPoint ps (Point (p_x p1) y) drawPoint ps (Point ((p_x p1 + p_x p2)/2) y) drawPoint ps (Point (p_x p2) y) where ps = _plot_points_style p y = (p_y p1 + p_y p2)/2 instance Default (PlotPoints x y) where def = PlotPoints { _plot_points_title = "" , _plot_points_style = def , _plot_points_values = [] } $( makeLenses ''PlotPoints ) Chart-1.9.5/Graphics/Rendering/Chart/Plot/Types.hs0000644000000000000000000000443307346545000020060 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Chart.Plot.Types -- Copyright : (c) Tim Docker 2006, 2014 -- License : BSD-style (see chart/COPYRIGHT) -- -- Datatypes and functions common to the implementation of the various -- plot types. -- {-# LANGUAGE TemplateHaskell #-} module Graphics.Rendering.Chart.Plot.Types( Plot(..), joinPlot, ToPlot(..), mapXY, plot_render, plot_legend, plot_all_points, ) where import Graphics.Rendering.Chart.Geometry import Graphics.Rendering.Chart.Drawing import Control.Lens -- | Interface to control plotting on a 2D area. data Plot x y = Plot { -- | Given the mapping between model space coordinates and device -- coordinates, render this plot into a chart. _plot_render :: PointMapFn x y -> BackendProgram (), -- | Details for how to show this plot in a legend. For each item -- the string is the text to show, and the function renders a -- graphical sample of the plot. _plot_legend :: [ (String, Rect -> BackendProgram ()) ], -- | All of the model space coordinates to be plotted. These are -- used to autoscale the axes where necessary. _plot_all_points :: ([x],[y]) } -- | A type class abstracting the conversion of a value to a Plot. class ToPlot a where toPlot :: a x y -> Plot x y instance ToPlot Plot where toPlot p = p -- | Join any two plots together (they will share a legend). joinPlot :: Plot x y -> Plot x y -> Plot x y joinPlot Plot{ _plot_render = renderP , _plot_legend = legendP , _plot_all_points = (xsP,ysP) } Plot{ _plot_render = renderQ , _plot_legend = legendQ , _plot_all_points = (xsQ,ysQ) } = Plot{ _plot_render = \a-> renderP a >> renderQ a , _plot_legend = legendP ++ legendQ , _plot_all_points = ( xsP++xsQ, ysP++ysQ ) } ---------------------------------------------------------------------- mapXY :: PointMapFn x y -> (x,y) -> Point mapXY f (x,y) = f (LValue x, LValue y) ---------------------------------------------------------------------- ---------------------------------------------------------------------- $( makeLenses ''Plot ) Chart-1.9.5/Graphics/Rendering/Chart/Plot/Vectors.hs0000644000000000000000000001260307346545000020377 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Chart.Plot.Vectors -- Copyright : (c) Anton Vorontsov 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 = [] } Chart-1.9.5/Graphics/Rendering/Chart/Renderable.hs0000644000000000000000000002141607346545000020101 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Chart.Renderable -- Copyright : (c) Tim Docker 2006, 2014 -- License : BSD-style (see chart/COPYRIGHT) -- -- This module contains the definition of the 'Renderable' type, which -- is a composable drawing element, along with assorted functions to -- them. -- {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE TemplateHaskell #-} module Graphics.Rendering.Chart.Renderable( Renderable(..), ToRenderable(..), PickFn, Rectangle(..), RectCornerStyle(..), rectangleToRenderable, drawRectangle, fillBackground, addMargins, emptyRenderable, embedRenderable, label, rlabel, spacer, spacer1, setPickFn, mapMaybePickFn, mapPickFn, nullPickFn, rect_minsize, rect_fillStyle, rect_lineStyle, rect_cornerStyle, ) where import Control.Monad import Control.Lens import Data.Default.Class import Graphics.Rendering.Chart.Geometry import Graphics.Rendering.Chart.Drawing import Graphics.Rendering.Chart.Utils -- | A function that maps a point in device coordinates to some value. -- -- Perhaps it might be generalised from Maybe a to -- (MonadPlus m ) => m a in the future. type PickFn a = Point -> Maybe a nullPickFn :: PickFn a nullPickFn = const Nothing -- | A Renderable is a record of functions required to layout a -- graphic element. data Renderable a = Renderable { -- | Calculate the minimum size of the renderable. minsize :: BackendProgram RectSize, -- | Draw the renderable with a rectangle, which covers -- the origin to a given point. -- -- The resulting "pick" function maps a point in the image to a value. render :: RectSize -> BackendProgram (PickFn a) } deriving (Functor) -- | A type class abtracting the conversion of a value to a Renderable. class ToRenderable a where toRenderable :: a -> Renderable () instance ToRenderable (Renderable a) where toRenderable = void emptyRenderable :: Renderable a emptyRenderable = spacer (0,0) -- | Create a blank renderable with a specified minimum size. spacer :: RectSize -> Renderable a spacer sz = Renderable { minsize = return sz, render = \_ -> return nullPickFn } -- | Create a blank renderable with a minimum size the same as -- some other renderable. spacer1 :: Renderable a -> Renderable b spacer1 r = r{ render = \_ -> return nullPickFn } -- | Replace the pick function of a renderable with another. setPickFn :: PickFn b -> Renderable a -> Renderable b setPickFn pickfn r = r{ render = \sz -> render r sz >> return pickfn } -- | Map a function over the result of a renderable's pickfunction, keeping only 'Just' results. mapMaybePickFn :: (a -> Maybe b) -> Renderable a -> Renderable b mapMaybePickFn f r = r{ render = \sz -> do pf <- render r sz return (join . fmap f . pf) } -- | Map a function over result of a renderable's pickfunction. mapPickFn :: (a -> b) -> Renderable a -> Renderable b mapPickFn f = mapMaybePickFn (Just . f) -- | Add some spacing at the edges of a renderable. addMargins :: (Double,Double,Double,Double) -- ^ The spacing to be added. -> Renderable a -- ^ The source renderable. -> Renderable a addMargins (t,b,l,r) rd = Renderable { minsize = mf, render = rf } where mf = do (w,h) <- minsize rd return (w+l+r,h+t+b) rf (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 -- | Overlay a renderable over a solid background fill. fillBackground :: FillStyle -> Renderable a -> Renderable a fillBackground fs r = r{ render = rf } where rf rsize@(w,h) = do 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 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 } } ---------------------------------------------------------------------- -- Labels -- | Construct a renderable from a text string, aligned with the axes. label :: FontStyle -> HTextAnchor -> VTextAnchor -> String -> Renderable String label fs hta vta = rlabel fs hta vta 0 -- | Construct a renderable from a text string, rotated wrt to axes. The angle -- of rotation is in degrees, measured clockwise from the horizontal. rlabel :: FontStyle -> HTextAnchor -> VTextAnchor -> Double -> String -> Renderable String rlabel fs hta vta rot s = Renderable { minsize = mf, render = rf } where mf = withFontStyle fs $ do ts <- textSize s let 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 data RectCornerStyle = RCornerSquare | RCornerBevel Double | RCornerRounded Double data Rectangle = Rectangle { _rect_minsize :: RectSize, _rect_fillStyle :: Maybe FillStyle, _rect_lineStyle :: Maybe LineStyle, _rect_cornerStyle :: RectCornerStyle } instance Default Rectangle where def = Rectangle { _rect_minsize = (0,0) , _rect_fillStyle = Nothing , _rect_lineStyle = Nothing , _rect_cornerStyle = RCornerSquare } 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 } -- | 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 fill p sz fs = withFillStyle fs $ fillPath $ strokeRectangleP p sz (_rect_cornerStyle rectangle) stroke p sz ls = withLineStyle ls $ strokePath $ strokeRectangleP p sz (_rect_cornerStyle rectangle) strokeRectangleP (Point x1 y1) (x2,y2) RCornerSquare = let (x3,y3) = (x1+x2,y1+y2) in moveTo' x1 y1 <> lineTo' x1 y3 <> lineTo' x3 y3 <> lineTo' x3 y1 <> lineTo' x1 y1 strokeRectangleP (Point x1 y1) (x2,y2) (RCornerBevel s) = let (x3,y3) = (x1+x2,y1+y2) in moveTo' x1 (y1+s) <> lineTo' x1 (y3-s) <> lineTo' (x1+s) y3 <> lineTo' (x3-s) y3 <> lineTo' x3 (y3-s) <> lineTo' x3 (y1+s) <> lineTo' (x3-s) y1 <> lineTo' (x1+s) y1 <> lineTo' x1 (y1+s) strokeRectangleP (Point x1 y1) (x2,y2) (RCornerRounded s) = let (x3,y3) = (x1+x2,y1+y2) in arcNeg (Point (x1+s) (y3-s)) s (pi2*2) pi2 <> arcNeg (Point (x3-s) (y3-s)) s pi2 0 <> arcNeg (Point (x3-s) (y1+s)) s 0 (pi2*3) <> arcNeg (Point (x1+s) (y1+s)) s (pi2*3) (pi2*2) <> lineTo' x1 (y3-s) pi2 = pi / 2 $( makeLenses ''Rectangle ) Chart-1.9.5/Graphics/Rendering/Chart/SparkLine.hs0000644000000000000000000001402007346545000017717 0ustar0000000000000000--------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Chart.Sparkline -- Copyright : (c) Hitesh Jasani, 2008, Malcolm Wallace 2011, Tim Docker 2014 -- License : BSD3 -- -- Sparklines are mini graphs inspired by Edward Tufte; see -- -- and -- for more information. -- -- The original implementation (by Hitesh Jasani) used the gd -- package as a backend renderer, and is still available at -- . -- -- The present version integrates with -- the Chart package, in the sense that Sparklines are just another -- kind of (@ToRenderable a => a@), so they can be composed into grids -- and used with the rest of Chart. -- -- > dp :: [Double] -- > dp = [24,21,32.3,24,15,34,43,55,57,72,74,75,73,72,55,44] -- > -- > sl = SparkLine barSpark dp -- > fopts = FileOptions (sparkSize sl) PNG -- > renderableToFile fopts (sparkLineToRenderable sl) "bar_spark.png" -- > --------------------------------------------------------------- module Graphics.Rendering.Chart.SparkLine ( -- * SparkLine type SparkLine(..) -- * Drawing options , SparkOptions(..) , smoothSpark , barSpark -- * Size calculation , sparkSize -- * Rendering function , renderSparkLine , sparkLineToRenderable , sparkWidth ) where import Control.Monad import Data.List import Data.Ord import Graphics.Rendering.Chart.Geometry import Graphics.Rendering.Chart.Drawing import Graphics.Rendering.Chart.Renderable import Data.Colour import Data.Colour.Names -- | A sparkline is a single sequence of data values, treated as y-values. -- The x-values are anonymous and implicit in the sequence. data SparkLine = SparkLine { sl_options :: SparkOptions , sl_data :: [Double] } -- | Options to render the sparklines in different ways. data SparkOptions = SparkOptions { so_smooth :: Bool -- ^ smooth or bars , so_step :: Int -- ^ step size , so_height :: Int -- ^ graph height (pixels) , so_limits :: (Double,Double) -- ^ data point limits , so_bgColor :: Colour Double -- ^ background color , so_minColor :: Colour Double -- ^ color of minimum datapoint , so_maxColor :: Colour Double -- ^ color of maximum datapoint , so_lastColor :: Colour Double -- ^ color of last datapoint , so_minMarker :: Bool -- ^ display minimum marker , so_maxMarker :: Bool -- ^ display maximum marker , so_lastMarker :: Bool -- ^ display last marker } deriving (Show) -- | Default options for a smooth sparkline. smoothSpark :: SparkOptions smoothSpark = SparkOptions { so_smooth = True , so_step = 2 , so_height = 20 , so_limits = (0,100) , so_bgColor = white , so_minColor = red , so_maxColor = green , so_lastColor = blue , so_minMarker = True , so_maxMarker = True , so_lastMarker = True } -- | Default options for a barchart sparkline. barSpark :: SparkOptions barSpark = smoothSpark { so_smooth=False } -- | Create a renderable from a SparkLine. sparkLineToRenderable :: SparkLine -> Renderable () sparkLineToRenderable sp = Renderable { minsize = let (w,h) = sparkSize sp in return (fromIntegral w , fromIntegral h) , render = \_rect-> renderSparkLine sp } instance ToRenderable SparkLine where toRenderable = sparkLineToRenderable -- | Compute the width of a SparkLine, for rendering purposes. sparkWidth :: SparkLine -> Int sparkWidth SparkLine{sl_options=opt, sl_data=ds} = let w = 4 + (so_step opt) * (length ds - 1) + extrawidth extrawidth | so_smooth opt = 0 | otherwise = bw * length ds bw | so_smooth opt = 0 | otherwise = 2 in w -- | Return the width and height of the SparkLine. sparkSize :: SparkLine -> (Int,Int) sparkSize s = (sparkWidth s, so_height (sl_options s)) -- | Render a SparkLine to a drawing surface. renderSparkLine :: SparkLine -> BackendProgram (PickFn ()) renderSparkLine SparkLine{sl_options=opt, sl_data=ds} = let w = 4 + (so_step opt) * (length ds - 1) + extrawidth extrawidth | so_smooth opt = 0 | otherwise = bw * length ds bw | so_smooth opt = 0 | otherwise = 2 h = so_height opt dmin = fst (so_limits opt) dmax = snd (so_limits opt) coords = zipWith (\x y-> Point (fi x) y) [1,(1+bw+so_step opt)..(1+(so_step opt+bw)*(length ds))] [ fi h - ( (y-dmin) / ((dmax-dmin+1) / fi (h-4)) ) | y <- ds ] -- remember y increases as we go down the page minpt = maximumBy (comparing p_y) coords maxpt = minimumBy (comparing p_y) coords endpt = last coords boxpt :: Point -> Rect boxpt (Point x y) = Rect (Point (x-1)(y-1)) (Point (x+1)(y+1)) fi :: (Num b, Integral a) => a -> b fi = fromIntegral in do withFillStyle (solidFillStyle (opaque (so_bgColor opt))) $ do fillPath (rectPath (Rect (Point 0 0) (Point (fi w) (fi h)))) if so_smooth opt then do withLineStyle (solidLine 1 (opaque grey)) $ do p <- alignStrokePoints coords strokePointPath p else do withFillStyle (solidFillStyle (opaque grey)) $ do forM_ coords $ \ (Point x y) -> fillPath (rectPath (Rect (Point (x-1) y) (Point (x+1) (fi h)))) when (so_minMarker opt) $ do withFillStyle (solidFillStyle (opaque (so_minColor opt))) $ do p <- alignFillPath (rectPath (boxpt minpt)) fillPath p when (so_maxMarker opt) $ do withFillStyle (solidFillStyle (opaque (so_maxColor opt))) $ do p <- alignFillPath (rectPath (boxpt maxpt)) fillPath p when (so_lastMarker opt) $ do withFillStyle (solidFillStyle (opaque (so_lastColor opt))) $ do p <- alignFillPath (rectPath (boxpt endpt)) fillPath p return nullPickFn Chart-1.9.5/Graphics/Rendering/Chart/State.hs0000644000000000000000000000623607346545000017121 0ustar0000000000000000{-# 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) Chart-1.9.5/Graphics/Rendering/Chart/Utils.hs0000644000000000000000000000130007346545000017124 0ustar0000000000000000-- | 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 Chart-1.9.5/LICENSE0000644000000000000000000000271207346545000011767 0ustar0000000000000000Copyright (c) 2006, Tim Docker All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * The names of contributors may not be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Chart-1.9.5/Numeric/0000755000000000000000000000000007346545000012362 5ustar0000000000000000Chart-1.9.5/Numeric/Histogram.hs0000644000000000000000000000474507346545000014665 0ustar0000000000000000{-# 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 Chart-1.9.5/Setup.hs0000644000000000000000000000014707346545000012416 0ustar0000000000000000#!/usr/bin/env runghc module Main where import Distribution.Simple main :: IO () main = defaultMain