mirrors/haskell-plot
1
0
Fork 0
mirror of https://github.com/codedownio/haskell-plot.git synced 2025-04-26 18:36:04 +00:00
Code Issues Actions Packages Projects Releases Wiki Activity

Fix build with mtl-2.3

Browse Source
This commit is contained in:
Tom McLaughlin 2023-11-23 16:12:10 -07:00
parent cb4ac9e227
commit a51efe80f8
8 changed files with 228 additions and 200 deletions
lib
Control/Monad
Supply.hs
Graphics/Rendering/Plot
Figure/Plot
Axis.hsData.hs
Render
Plot.hs
Plot
Annotation.hsAxis.hsData.hsLegend.hs

11
lib/Control/Monad/Supply.hs

@ -37,7 +37,9 @@ import Control.Monad.Trans()
import Control.Monad.Fail ( MonadFail, fail ) import Control.Monad.Fail ( MonadFail, fail )
import Prelude hiding ( fail ) import Prelude hiding ( fail )
#endif #endif
#if MIN_VERSION_mtl(2,3,0)
import Control.Monad
#endif
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
class Supply a b where class Supply a b where
@ -59,7 +61,7 @@ supplyN n = replicateM n supply
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
newtype SupplyT s m a = SupplyT { runSupplyT :: s -> m (a, s) } newtype SupplyT s m a = SupplyT { runSupplyT :: s -> m (a, s) }
evalSupplyT :: Monad m => SupplyT s m a -> s -> m a evalSupplyT :: Monad m => SupplyT s m a -> s -> m a
evalSupplyT st s = do evalSupplyT st s = do
~(a,_) <- runSupplyT st s ~(a,_) <- runSupplyT st s
@ -84,14 +86,14 @@ instance Monad m => Applicative (SupplyT s m) where
(<*>) = ap (<*>) = ap
instance Monad m => Monad (SupplyT s m) where instance Monad m => Monad (SupplyT s m) where
return a = SupplyT $ \s -> return (a, s) return a = SupplyT $ \s -> return (a, s)
m >>= f = SupplyT $ \s -> do m >>= f = SupplyT $ \s -> do
~(a,s') <- runSupplyT m s ~(a,s') <- runSupplyT m s
runSupplyT (f a) s' runSupplyT (f a) s'
instance (MonadFail m, Monad m) => MonadFail (SupplyT s m) where instance (MonadFail m, Monad m) => MonadFail (SupplyT s m) where
fail str = SupplyT $ \_ -> fail str fail str = SupplyT $ \_ -> fail str
instance MonadTrans (SupplyT s) where instance MonadTrans (SupplyT s) where
lift m = SupplyT $ \s -> do lift m = SupplyT $ \s -> do
a <- m a <- m
@ -125,4 +127,3 @@ instance MonadWriter w m => MonadWriter w (SupplyT s m) where
return ((a,s'),f) return ((a,s'),f)
----------------------------------------------------------------------------- -----------------------------------------------------------------------------

21
lib/Graphics/Rendering/Plot/Figure/Plot/Axis.hs

@ -1,3 +1,4 @@
{-# LANGUAGE CPP #-}
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- | -- |
-- Module : Graphics.Rendering.Plot.Figure.Plot.Axis -- Module : Graphics.Rendering.Plot.Figure.Plot.Axis
@ -33,6 +34,9 @@ import Data.Maybe (fromMaybe)
import Control.Monad.State import Control.Monad.State
import Control.Monad.Reader import Control.Monad.Reader
#if MIN_VERSION_mtl(2,3,0)
import Control.Monad
#endif
import Graphics.Rendering.Plot.Types import Graphics.Rendering.Plot.Types
import Graphics.Rendering.Plot.Defaults import Graphics.Rendering.Plot.Defaults
@ -87,20 +91,20 @@ withGridLine t m = do
-- | format the axis ticks -- | format the axis ticks
setTicks :: Tick -> TickValues -> Axis () setTicks :: Tick -> TickValues -> Axis ()
setTicks Minor (TickNumber 0) = modify $ \s -> setTicks Minor (TickNumber 0) = modify $ \s ->
changeMinorTicks (const Nothing) s changeMinorTicks (const Nothing) s
setTicks Minor ts = modify $ \s -> setTicks Minor ts = modify $ \s ->
changeMinorTicks (setTickValues ts) s changeMinorTicks (setTickValues ts) s
setTicks Major (TickNumber 0) = modify $ \s -> setTicks Major (TickNumber 0) = modify $ \s ->
changeMajorTicks (const Nothing) s changeMajorTicks (const Nothing) s
setTicks Major ts = modify $ \s -> setTicks Major ts = modify $ \s ->
changeMajorTicks (setTickValues ts) s changeMajorTicks (setTickValues ts) s
-- | should gridlines be displayed? -- | should gridlines be displayed?
setGridlines :: Tick -> GridLines -> Axis () setGridlines :: Tick -> GridLines -> Axis ()
setGridlines Minor gl = modify $ \s -> setGridlines Minor gl = modify $ \s ->
changeMinorTicks (setTickGridlines (if gl then defaultGridLine else NoLine)) s changeMinorTicks (setTickGridlines (if gl then defaultGridLine else NoLine)) s
setGridlines Major gl = modify $ \s -> setGridlines Major gl = modify $ \s ->
changeMajorTicks (setTickGridlines (if gl then defaultGridLine else NoLine)) s changeMajorTicks (setTickGridlines (if gl then defaultGridLine else NoLine)) s
-- | set the tick label format -- | set the tick label format
@ -109,7 +113,7 @@ setTickLabelFormat tf = modify $ \s -> changeTickFormat tf s
-- | a list of data labels -- | a list of data labels
setTickLabels :: [String] -> Axis () setTickLabels :: [String] -> Axis ()
setTickLabels dl = modify $ \s -> setTickLabels dl = modify $ \s ->
changeTickLabels (const (map BareText dl)) s changeTickLabels (const (map BareText dl)) s
-- | format the tick labels -- | format the tick labels
@ -124,7 +128,7 @@ withAxisLabel :: Text () -> Axis ()
withAxisLabel m = do withAxisLabel m = do
ax <- get ax <- get
to <- asks _textoptions to <- asks _textoptions
put $ ax { _label = execText m to (_label ax) } put $ ax { _label = execText m to (_label ax) }
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
@ -137,4 +141,3 @@ withTickLabelFormat m = do
put $ ax { _tick_labels = map (execText m to) (_tick_labels ax) } put $ ax { _tick_labels = map (execText m to) (_tick_labels ax) }
----------------------------------------------------------------------------- -----------------------------------------------------------------------------

84
lib/Graphics/Rendering/Plot/Figure/Plot/Data.hs

@ -2,6 +2,7 @@
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE CPP #-}
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- | -- |
-- Module : Graphics.Rendering.Plot.Figure.Plot.Data -- Module : Graphics.Rendering.Plot.Figure.Plot.Data
@ -57,6 +58,10 @@ import Graphics.Rendering.Plot.Figure.Line
import Graphics.Rendering.Plot.Figure.Point import Graphics.Rendering.Plot.Figure.Point
import Graphics.Rendering.Plot.Figure.Bar import Graphics.Rendering.Plot.Figure.Bar
#if MIN_VERSION_mtl(2,3,0)
import Control.Monad
#endif
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
dataSeriesNum :: DataSeries -> Int dataSeriesNum :: DataSeries -> Int
@ -218,9 +223,9 @@ instance SeriesTypes Decoration where
lt <- toLine c lt <- toLine c
return $ DecStep lt return $ DecStep lt
setSeriesType'' Step (DecLinPt lt _) = return $ DecStep lt setSeriesType'' Step (DecLinPt lt _) = return $ DecStep lt
setSeriesType'' Step (DecImpulse lt) = return $ DecStep lt setSeriesType'' Step (DecImpulse lt) = return $ DecStep lt
setSeriesType'' Step d@(DecStep _) = return d setSeriesType'' Step d@(DecStep _) = return d
setSeriesType'' Step (DecArea lt) = return $ DecStep lt setSeriesType'' Step (DecArea lt) = return $ DecStep lt
setSeriesType'' Step (DecBar bt) = do setSeriesType'' Step (DecBar bt) = do
let c = getBarColour bt let c = getBarColour bt
lt <- toLine c lt <- toLine c
@ -243,8 +248,8 @@ instance SeriesTypes Decoration where
lt <- toLine c lt <- toLine c
return $ DecArea lt return $ DecArea lt
setSeriesType'' Area (DecLinPt lt _) = return $ DecArea lt setSeriesType'' Area (DecLinPt lt _) = return $ DecArea lt
setSeriesType'' Area (DecImpulse lt) = return $ DecArea lt setSeriesType'' Area (DecImpulse lt) = return $ DecArea lt
setSeriesType'' Area (DecStep lt) = return $ DecArea lt setSeriesType'' Area (DecStep lt) = return $ DecArea lt
setSeriesType'' Area d@(DecArea _) = return d setSeriesType'' Area d@(DecArea _) = return d
setSeriesType'' Area (DecBar bt) = do setSeriesType'' Area (DecBar bt) = do
let c = getBarColour bt let c = getBarColour bt
@ -383,23 +388,23 @@ instance SeriesTypes DecoratedSeries where
setSeriesType' :: Int -> SeriesType -> DataSeries -> Data DataSeries setSeriesType' :: Int -> SeriesType -> DataSeries -> Data DataSeries
setSeriesType' i t (DS_Y a) = do setSeriesType' i t (DS_Y a) = do
s' <- setSeriesType'' t $ a A.! i s' <- setSeriesType'' t $ a A.! i
return $ DS_Y $ a A.// [(i,s')] return $ DS_Y $ a A.// [(i,s')]
setSeriesType' i t (DS_1toN x a) = do setSeriesType' i t (DS_1toN x a) = do
s' <- setSeriesType'' t $ a A.! i s' <- setSeriesType'' t $ a A.! i
return $ DS_1toN x $ a A.// [(i,s')] return $ DS_1toN x $ a A.// [(i,s')]
setSeriesType' i t (DS_1to1 a) = do setSeriesType' i t (DS_1to1 a) = do
let (x,s) = a A.! i let (x,s) = a A.! i
s' <- setSeriesType'' t s s' <- setSeriesType'' t s
return $ DS_1to1 $ a A.// [(i,(x,s'))] return $ DS_1to1 $ a A.// [(i,(x,s'))]
setSeriesType' _ _ d@(DS_Surf _) = return d setSeriesType' _ _ d@(DS_Surf _) = return d
-- | set the series type of a given data series -- | set the series type of a given data series
setSeriesType :: SeriesType -> Int -> Data () setSeriesType :: SeriesType -> Int -> Data ()
setSeriesType t i = do setSeriesType t i = do
ds <- get ds <- get
ds' <- setSeriesType' i t ds ds' <- setSeriesType' i t ds
put ds' put ds'
-- | set the series type of all data series -- | set the series type of all data series
setAllSeriesTypes :: SeriesType -> Data () setAllSeriesTypes :: SeriesType -> Data ()
setAllSeriesTypes t = do setAllSeriesTypes t = do
@ -464,19 +469,19 @@ instance PlotFormats Bar where
modifyFormat _ d@(DecSeries _ (DecArea _)) = return d modifyFormat _ d@(DecSeries _ (DecArea _)) = return d
modifyFormat _ d@(DecSeries _ (DecPoint _)) = return d modifyFormat _ d@(DecSeries _ (DecPoint _)) = return d
modifyFormat _ d@(DecSeries _ (DecLinPt _ _)) = return d modifyFormat _ d@(DecSeries _ (DecLinPt _ _)) = return d
modifyFormat b (DecSeries o (DecBar bt)) = do modifyFormat b (DecSeries o (DecBar bt)) = do
bo <- asks _baroptions bo <- asks _baroptions
let bt' = execBar b bo bt let bt' = execBar b bo bt
return $ DecSeries o (DecBar bt') return $ DecSeries o (DecBar bt')
modifyFormat b (DecSeries o (DecHist bt)) = do modifyFormat b (DecSeries o (DecHist bt)) = do
bo <- asks _baroptions bo <- asks _baroptions
let bt' = execBar b bo bt let bt' = execBar b bo bt
return $ DecSeries o (DecHist bt') return $ DecSeries o (DecHist bt')
modifyFormat b (DecSeries o (DecCand bt)) = do modifyFormat b (DecSeries o (DecCand bt)) = do
bo <- asks _baroptions bo <- asks _baroptions
let bt' = execBar b bo bt let bt' = execBar b bo bt
return $ DecSeries o (DecCand bt') return $ DecSeries o (DecCand bt')
modifyFormat b (DecSeries o (DecWhisk bt)) = do modifyFormat b (DecSeries o (DecWhisk bt)) = do
bo <- asks _baroptions bo <- asks _baroptions
let bt' = execBar b bo bt let bt' = execBar b bo bt
return $ DecSeries o (DecWhisk bt') return $ DecSeries o (DecWhisk bt')
@ -511,7 +516,7 @@ withAllSeriesFormats f = do
ds <- get ds <- get
let ln = dataSeriesNum ds let ln = dataSeriesNum ds
mapM_ (\i -> withSeriesFormat i (f i)) [1..ln] mapM_ (\i -> withSeriesFormat i (f i)) [1..ln]
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
class Abscissa a where class Abscissa a where
@ -594,7 +599,7 @@ step :: (Ordinate a, LineFormat b) => a -> b -> FormattedSeries
step o f = do step o f = do
f' <- toLine f f' <- toLine f
setSeriesType'' Step (format o f') setSeriesType'' Step (format o f')
area :: (Ordinate a, LineFormat b) => a -> b -> FormattedSeries area :: (Ordinate a, LineFormat b) => a -> b -> FormattedSeries
area o f = do area o f = do
f' <- toLine f f' <- toLine f
@ -629,7 +634,7 @@ getType Line = do
return $ toDecoration lt return $ toDecoration lt
getType Point = do getType Point = do
g <- supply g <- supply
pt <- toPoint (g :: Glyph) pt <- toPoint (g :: Glyph)
return $ toDecoration pt return $ toDecoration pt
getType LinePoint = do getType LinePoint = do
c <- supply c <- supply
@ -676,9 +681,9 @@ class Dataset a where
instance Dataset Surface where instance Dataset Surface where
toDataSeries m = return $ DS_Surf m toDataSeries m = return $ DS_Surf m
instance (Ordinate a) => Dataset (SeriesType,[a]) where
instance (Ordinate a) => Dataset (SeriesType,[a]) where
toDataSeries (Line,os) = do toDataSeries (Line,os) = do
let ln = length os let ln = length os
cs <- supplyN ln cs <- supplyN ln
@ -745,14 +750,14 @@ instance (Abscissa a, Ordinate b) => Dataset (SeriesType,a,[b]) where
let ln = length os let ln = length os
cs <- supplyN ln cs <- supplyN ln
ls <- mapM toLine (cs :: [Color]) ls <- mapM toLine (cs :: [Color])
return $ DS_1toN (toAbscissa t) $ A.listArray (1,ln) return $ DS_1toN (toAbscissa t) $ A.listArray (1,ln)
$ zipWith format os ls $ zipWith format os ls
toDataSeries (Point,t,os) = do toDataSeries (Point,t,os) = do
let ln = length os let ln = length os
cs <- supplyN ln cs <- supplyN ln
gs <- supplyN ln gs <- supplyN ln
ps <- mapM toPoint (zip (gs :: [Glyph]) (cs :: [Color])) ps <- mapM toPoint (zip (gs :: [Glyph]) (cs :: [Color]))
return $ DS_1toN (toAbscissa t) $ A.listArray (1,ln) return $ DS_1toN (toAbscissa t) $ A.listArray (1,ln)
$ zipWith format os ps $ zipWith format os ps
toDataSeries (LinePoint,t,os) = do toDataSeries (LinePoint,t,os) = do
let ln = length os let ln = length os
@ -761,55 +766,55 @@ instance (Abscissa a, Ordinate b) => Dataset (SeriesType,a,[b]) where
ls <- mapM toLine cs ls <- mapM toLine cs
ps <- mapM toPoint (zip (gs :: [Glyph]) (cs :: [Color])) ps <- mapM toPoint (zip (gs :: [Glyph]) (cs :: [Color]))
let ds = toDecorations (zip ls ps) let ds = toDecorations (zip ls ps)
return $ DS_1toN (toAbscissa t) $ A.listArray (1,ln) return $ DS_1toN (toAbscissa t) $ A.listArray (1,ln)
$ zipWith format os ds $ zipWith format os ds
toDataSeries (Impulse,t,os) = do toDataSeries (Impulse,t,os) = do
let ln = length os let ln = length os
cs <- supplyN ln cs <- supplyN ln
ls <- mapM toLine (cs :: [Color]) ls <- mapM toLine (cs :: [Color])
ds <- mapM (setSeriesType'' Impulse) $ toDecorations ls ds <- mapM (setSeriesType'' Impulse) $ toDecorations ls
return $ DS_1toN (toAbscissa t) $ A.listArray (1,ln) return $ DS_1toN (toAbscissa t) $ A.listArray (1,ln)
$ zipWith format os ds $ zipWith format os ds
toDataSeries (Step,t,os) = do toDataSeries (Step,t,os) = do
let ln = length os let ln = length os
cs <- supplyN ln cs <- supplyN ln
ls <- mapM toLine (cs :: [Color]) ls <- mapM toLine (cs :: [Color])
ds <- mapM (setSeriesType'' Step) $ toDecorations ls ds <- mapM (setSeriesType'' Step) $ toDecorations ls
return $ DS_1toN (toAbscissa t) $ A.listArray (1,ln) return $ DS_1toN (toAbscissa t) $ A.listArray (1,ln)
$ zipWith format os ds $ zipWith format os ds
toDataSeries (Area,t,os) = do toDataSeries (Area,t,os) = do
let ln = length os let ln = length os
cs <- supplyN ln cs <- supplyN ln
ls <- mapM toLine (cs :: [Color]) ls <- mapM toLine (cs :: [Color])
ds <- mapM (setSeriesType'' Area) $ toDecorations ls ds <- mapM (setSeriesType'' Area) $ toDecorations ls
return $ DS_1toN (toAbscissa t) $ A.listArray (1,ln) return $ DS_1toN (toAbscissa t) $ A.listArray (1,ln)
$ zipWith format os ds $ zipWith format os ds
toDataSeries (Bar,t,os) = do toDataSeries (Bar,t,os) = do
let ln = length os let ln = length os
cs <- supplyN ln cs <- supplyN ln
bs <- mapM toBar (cs :: [Color]) bs <- mapM toBar (cs :: [Color])
return $ DS_1toN (toAbscissa t) $ A.listArray (1,ln) return $ DS_1toN (toAbscissa t) $ A.listArray (1,ln)
$ zipWith format os bs $ zipWith format os bs
toDataSeries (Hist,t,os) = do toDataSeries (Hist,t,os) = do
let ln = length os let ln = length os
cs <- supplyN ln cs <- supplyN ln
bs <- mapM toBar (cs :: [Color]) bs <- mapM toBar (cs :: [Color])
ds <- mapM (setSeriesType'' Hist) $ toDecorations bs ds <- mapM (setSeriesType'' Hist) $ toDecorations bs
return $ DS_1toN (toAbscissa t) $ A.listArray (1,ln) return $ DS_1toN (toAbscissa t) $ A.listArray (1,ln)
$ zipWith format os ds $ zipWith format os ds
toDataSeries (Candle,t,os) = do toDataSeries (Candle,t,os) = do
let ln = length os let ln = length os
cs <- supplyN ln cs <- supplyN ln
bs <- mapM toBar (cs :: [Color]) bs <- mapM toBar (cs :: [Color])
ds <- mapM (setSeriesType'' Candle) $ toDecorations bs ds <- mapM (setSeriesType'' Candle) $ toDecorations bs
return $ DS_1toN (toAbscissa t) $ A.listArray (1,ln) return $ DS_1toN (toAbscissa t) $ A.listArray (1,ln)
$ zipWith format os ds $ zipWith format os ds
toDataSeries (Whisker,t,os) = do toDataSeries (Whisker,t,os) = do
let ln = length os let ln = length os
cs <- supplyN ln cs <- supplyN ln
bs <- mapM toBar (cs :: [Color]) bs <- mapM toBar (cs :: [Color])
ds <- mapM (setSeriesType'' Whisker) $ toDecorations bs ds <- mapM (setSeriesType'' Whisker) $ toDecorations bs
return $ DS_1toN (toAbscissa t) $ A.listArray (1,ln) return $ DS_1toN (toAbscissa t) $ A.listArray (1,ln)
$ zipWith format os ds $ zipWith format os ds
instance (Abscissa a, Ordinate b) => Dataset [(SeriesType,a,b)] where instance (Abscissa a, Ordinate b) => Dataset [(SeriesType,a,b)] where
@ -822,57 +827,57 @@ instance (Abscissa a, Ordinate b) => Dataset [(SeriesType,a,b)] where
toDataSeries' :: Ordinate b => (SeriesType,b) -> Data DecoratedSeries toDataSeries' :: Ordinate b => (SeriesType,b) -> Data DecoratedSeries
toDataSeries' (Line,o) = do toDataSeries' (Line,o) = do
c <- supply c <- supply
l <- toLine (c :: Color) l <- toLine (c :: Color)
return $ format o l return $ format o l
toDataSeries' (Point,o) = do toDataSeries' (Point,o) = do
c <- supply c <- supply
g <- supply g <- supply
p <- toPoint ((g :: Glyph),(c :: Color)) p <- toPoint ((g :: Glyph),(c :: Color))
return $ format o p return $ format o p
toDataSeries' (LinePoint,o) = do toDataSeries' (LinePoint,o) = do
c <- supply c <- supply
g <- supply g <- supply
l <- toLine (c :: Color) l <- toLine (c :: Color)
p <- toPoint ((g :: Glyph),(c :: Color)) p <- toPoint ((g :: Glyph),(c :: Color))
let d = toDecoration (l,p) let d = toDecoration (l,p)
return $ format o d return $ format o d
toDataSeries' (Impulse,o) = do toDataSeries' (Impulse,o) = do
c <- supply c <- supply
l <- toLine (c :: Color) l <- toLine (c :: Color)
d <- setSeriesType'' Impulse $ toDecoration l d <- setSeriesType'' Impulse $ toDecoration l
return $ format o d return $ format o d
toDataSeries' (Step,o) = do toDataSeries' (Step,o) = do
c <- supply c <- supply
l <- toLine (c :: Color) l <- toLine (c :: Color)
d <- setSeriesType'' Step $ toDecoration l d <- setSeriesType'' Step $ toDecoration l
return $ format o d return $ format o d
toDataSeries' (Area,o) = do toDataSeries' (Area,o) = do
c <- supply c <- supply
l <- toLine (c :: Color) l <- toLine (c :: Color)
d <- setSeriesType'' Area $ toDecoration l d <- setSeriesType'' Area $ toDecoration l
return $ format o d return $ format o d
toDataSeries' (Bar,o) = do toDataSeries' (Bar,o) = do
c <- supply c <- supply
b <- toBar (c :: Color) b <- toBar (c :: Color)
return $ format o b return $ format o b
toDataSeries' (Hist,o) = do toDataSeries' (Hist,o) = do
c <- supply c <- supply
b <- toBar (c :: Color) b <- toBar (c :: Color)
d <- setSeriesType'' Hist $ toDecoration b d <- setSeriesType'' Hist $ toDecoration b
return $ format o d return $ format o d
toDataSeries' (Candle,o) = do toDataSeries' (Candle,o) = do
c <- supply c <- supply
b <- toBar (c :: Color) b <- toBar (c :: Color)
d <- setSeriesType'' Candle $ toDecoration b d <- setSeriesType'' Candle $ toDecoration b
return $ format o d return $ format o d
toDataSeries' (Whisker,o) = do toDataSeries' (Whisker,o) = do
c <- supply c <- supply
b <- toBar (c :: Color) b <- toBar (c :: Color)
d <- setSeriesType'' Whisker $ toDecoration b d <- setSeriesType'' Whisker $ toDecoration b
return $ format o d return $ format o d
instance Dataset [FormattedSeries] where instance Dataset [FormattedSeries] where
toDataSeries ds = do toDataSeries ds = do
let ln = length ds let ln = length ds
ds' <- sequence ds ds' <- sequence ds
@ -911,4 +916,3 @@ isMonotoneIncreasing :: Vector Double -> Bool
isMonotoneIncreasing v = maybe False (\_ -> True) $ evalState (runMaybeT $ (mapVectorM_ monoStep (subVector 1 (size v -1) v))) (v `atIndex` 0) isMonotoneIncreasing v = maybe False (\_ -> True) $ evalState (runMaybeT $ (mapVectorM_ monoStep (subVector 1 (size v -1) v))) (v `atIndex` 0)
----------------------------------------------------------------------------- -----------------------------------------------------------------------------

11
lib/Graphics/Rendering/Plot/Render/Plot.hs

@ -1,3 +1,4 @@
{-# LANGUAGE CPP #-}
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- | -- |
-- Module : Graphics.Rendering.Plot.Render.Plot -- Module : Graphics.Rendering.Plot.Render.Plot
@ -60,6 +61,10 @@ import Graphics.Rendering.Plot.Render.Plot.Annotation
--import Prelude hiding(min,max) --import Prelude hiding(min,max)
--import qualified Prelude(max) --import qualified Prelude(max)
#if MIN_VERSION_mtl(2,3,0)
import Control.Monad
#endif
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
bbPlot :: Int -> Int -> (Int,Int) -> Render () bbPlot :: Int -> Int -> (Int,Int) -> Render ()
@ -109,7 +114,7 @@ renderPlot (Plot b c p hd r a bc sd d l an) = do
cairo C.save cairo C.save
axes axes
cairo C.restore cairo C.restore
renderBorder :: Border -> Render () renderBorder :: Border -> Render ()
renderBorder False = return () renderBorder False = return ()
renderBorder True = do renderBorder True = do
@ -118,7 +123,5 @@ renderBorder True = do
C.setLineWidth 0.5 C.setLineWidth 0.5
C.rectangle (x+0.5) (y+0.5) w h C.rectangle (x+0.5) (y+0.5) w h
C.stroke C.stroke
----------------------------------------------------------------------------- -----------------------------------------------------------------------------

11
lib/Graphics/Rendering/Plot/Render/Plot/Annotation.hs

@ -1,3 +1,4 @@
{-# LANGUAGE CPP #-}
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- | -- |
-- Module : Graphics.Rendering.Plot.Render.Plot.Annotation -- Module : Graphics.Rendering.Plot.Render.Plot.Annotation
@ -37,6 +38,10 @@ import Graphics.Rendering.Plot.Render.Plot.Format
--import Prelude hiding(min,max) --import Prelude hiding(min,max)
--import qualified Prelude(max) --import qualified Prelude(max)
#if MIN_VERSION_mtl(2,3,0)
import Control.Monad
#endif
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
renderAnnotations :: Ranges -> Annotations -> Render () renderAnnotations :: Ranges -> Annotations -> Render ()
@ -44,13 +49,13 @@ renderAnnotations r an = do
(BoundingBox x y w h) <- get (BoundingBox x y w h) <- get
let (xsc,xmin',xmax') = getRanges XAxis Lower r let (xsc,xmin',xmax') = getRanges XAxis Lower r
let (xmin,xmax) = if xsc == Log then (logBase 10 xmin',logBase 10 xmax') else (xmin',xmax') let (xmin,xmax) = if xsc == Log then (logBase 10 xmin',logBase 10 xmax') else (xmin',xmax')
let xscale = w/(xmax-xmin) let xscale = w/(xmax-xmin)
cairo $ C.save cairo $ C.save
let (yscl,yminl',ymaxl') = getRanges YAxis Lower r let (yscl,yminl',ymaxl') = getRanges YAxis Lower r
let (yminl,ymaxl) = if yscl == Log then (logBase 10 yminl',logBase 10 ymaxl') else (yminl',ymaxl') let (yminl,ymaxl) = if yscl == Log then (logBase 10 yminl',logBase 10 ymaxl') else (yminl',ymaxl')
let yscalel = h/(ymaxl-yminl) let yscalel = h/(ymaxl-yminl)
-- transform to data coordinates -- transform to data coordinates
cairo $ do cairo $ do
C.translate x (y+h) C.translate x (y+h)
--C.scale xscale yscalel --C.scale xscale yscalel
C.translate (-xmin*xscale) (yminl*yscalel) C.translate (-xmin*xscale) (yminl*yscalel)

105
lib/Graphics/Rendering/Plot/Render/Plot/Axis.hs

@ -1,3 +1,4 @@
{-# LANGUAGE CPP #-}
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- | -- |
-- Module : Graphics.Rendering.Plot.Render.Plot.Axis -- Module : Graphics.Rendering.Plot.Render.Plot.Axis
@ -25,7 +26,7 @@ module Graphics.Rendering.Plot.Render.Plot.Axis (
import Data.Either import Data.Either
import Data.List import Data.List
import Numeric.LinearAlgebra.Data hiding (Range) import Numeric.LinearAlgebra.Data hiding (Range)
@ -48,6 +49,10 @@ import qualified Text.Printf as Printf
import Prelude hiding(min,max) import Prelude hiding(min,max)
import qualified Prelude(max) import qualified Prelude(max)
#if MIN_VERSION_mtl(2,3,0)
import Control.Monad
#endif
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
moveTo :: Double -> Double -> C.Render () moveTo :: Double -> Double -> C.Render ()
@ -135,7 +140,7 @@ shiftForAxisLabel p (Axis ax sd _ _ _ _ _ lb) = do
YAxis -> do YAxis -> do
(_,((w',h'))) <- textSizeVertical lo Centre Middle 0 0 (_,((w',h'))) <- textSizeVertical lo Centre Middle 0 0
return (h',w') return (h',w')
shiftForAxisLabel' p ax sd w h shiftForAxisLabel' p ax sd w h
where shiftForAxisLabel' (Padding l r b t) XAxis (Side Lower) _ h' = do where shiftForAxisLabel' (Padding l r b t) XAxis (Side Lower) _ h' = do
bbRaiseBottom (h'+2*textPad) bbRaiseBottom (h'+2*textPad)
return $ Padding l r (b+h'+2*textPad) t return $ Padding l r (b+h'+2*textPad) t
@ -177,38 +182,38 @@ renderAxisLabel _ (Axis _ (Value _) _ _ _ _ _ _ ) = return ()
shiftForTicks :: Ranges -> Padding -> AxisData -> Render Padding shiftForTicks :: Ranges -> Padding -> AxisData -> Render Padding
shiftForTicks (Ranges (Left (Range _ xmin xmax)) _) shiftForTicks (Ranges (Left (Range _ xmin xmax)) _)
p (Axis XAxis (Side Lower) _ min maj tf dl _) p (Axis XAxis (Side Lower) _ min maj tf dl _)
= shiftForTicks' p min maj XAxis (Side Lower) tf dl = shiftForTicks' p min maj XAxis (Side Lower) tf dl
(negate $ Prelude.max (abs xmin) (abs xmax)) (negate $ Prelude.max (abs xmin) (abs xmax))
shiftForTicks (Ranges (Left (Range _ xmin xmax)) _) shiftForTicks (Ranges (Left (Range _ xmin xmax)) _)
p (Axis XAxis (Side Upper) _ min maj tf dl _) p (Axis XAxis (Side Upper) _ min maj tf dl _)
= shiftForTicks' p min maj XAxis (Side Upper) tf dl = shiftForTicks' p min maj XAxis (Side Upper) tf dl
(negate $ Prelude.max (abs xmin) (abs xmax)) (negate $ Prelude.max (abs xmin) (abs xmax))
shiftForTicks (Ranges (Right ((Range _ xmin xmax),_)) _) shiftForTicks (Ranges (Right ((Range _ xmin xmax),_)) _)
p (Axis XAxis (Side Lower) _ min maj tf dl _) p (Axis XAxis (Side Lower) _ min maj tf dl _)
= shiftForTicks' p min maj XAxis (Side Lower) tf dl = shiftForTicks' p min maj XAxis (Side Lower) tf dl
(negate $ Prelude.max (abs xmin) (abs xmax)) (negate $ Prelude.max (abs xmin) (abs xmax))
shiftForTicks (Ranges (Right (_,(Range _ xmin xmax))) _) shiftForTicks (Ranges (Right (_,(Range _ xmin xmax))) _)
p (Axis XAxis (Side Upper) _ min maj tf dl _) p (Axis XAxis (Side Upper) _ min maj tf dl _)
= shiftForTicks' p min maj XAxis (Side Upper) tf dl = shiftForTicks' p min maj XAxis (Side Upper) tf dl
(negate $ Prelude.max (abs xmin) (abs xmax)) (negate $ Prelude.max (abs xmin) (abs xmax))
shiftForTicks (Ranges _ (Left (Range _ ymin ymax))) shiftForTicks (Ranges _ (Left (Range _ ymin ymax)))
p (Axis YAxis (Side Lower) _ min maj tf dl _) p (Axis YAxis (Side Lower) _ min maj tf dl _)
= shiftForTicks' p min maj YAxis (Side Lower) tf dl = shiftForTicks' p min maj YAxis (Side Lower) tf dl
(negate $ Prelude.max (abs ymin) (abs ymax)) (negate $ Prelude.max (abs ymin) (abs ymax))
shiftForTicks (Ranges _ (Left (Range _ ymin ymax))) shiftForTicks (Ranges _ (Left (Range _ ymin ymax)))
p (Axis YAxis (Side Upper) _ min maj tf dl _) p (Axis YAxis (Side Upper) _ min maj tf dl _)
= shiftForTicks' p min maj YAxis (Side Upper) tf dl = shiftForTicks' p min maj YAxis (Side Upper) tf dl
(negate $ Prelude.max (abs ymin) (abs ymax)) (negate $ Prelude.max (abs ymin) (abs ymax))
shiftForTicks (Ranges _ (Right ((Range _ ymin ymax),_))) shiftForTicks (Ranges _ (Right ((Range _ ymin ymax),_)))
p (Axis YAxis (Side Lower) _ min maj tf dl _) p (Axis YAxis (Side Lower) _ min maj tf dl _)
= shiftForTicks' p min maj YAxis (Side Lower) tf dl = shiftForTicks' p min maj YAxis (Side Lower) tf dl
(negate $ Prelude.max (abs ymin) (abs ymax)) (negate $ Prelude.max (abs ymin) (abs ymax))
shiftForTicks (Ranges _ (Right (_,(Range _ ymin ymax)))) shiftForTicks (Ranges _ (Right (_,(Range _ ymin ymax))))
p (Axis YAxis (Side Upper) _ min maj tf dl _) p (Axis YAxis (Side Upper) _ min maj tf dl _)
= shiftForTicks' p min maj YAxis (Side Upper) tf dl = shiftForTicks' p min maj YAxis (Side Upper) tf dl
(negate $ Prelude.max (abs ymin) (abs ymax)) (negate $ Prelude.max (abs ymin) (abs ymax))
shiftForTicks _ p (Axis _ (Value _) _ _ _ _ _ _) shiftForTicks _ p (Axis _ (Value _) _ _ _ _ _ _)
= return p = return p
shiftForTicks' :: Padding -> Maybe Ticks -> Maybe Ticks -> AxisType -> AxisPosn -> TickFormat -> [TextEntry] -> Double -> Render Padding shiftForTicks' :: Padding -> Maybe Ticks -> Maybe Ticks -> AxisType -> AxisPosn -> TickFormat -> [TextEntry] -> Double -> Render Padding
@ -222,7 +227,7 @@ shiftForTicks' p _ (Just (Ticks _ _)) ax sd tf dl
s' = if null dl then s else case head dl of s' = if null dl then s else case head dl of
NoText -> error "NoText as a datalabel" NoText -> error "NoText as a datalabel"
BareText bt -> bt BareText bt -> bt
SizeText _ _ st -> st SizeText _ _ st -> st
FontText _ ft -> ft FontText _ ft -> ft
lt <- pango $ P.layoutText pc s' lt <- pango $ P.layoutText pc s'
setTextOptions (scaleFontSize tickLabelScale to) lt setTextOptions (scaleFontSize tickLabelScale to) lt
@ -259,9 +264,9 @@ shiftForTicks' (Padding l r b t) (Ticks _ (Left _)) (Ticks _ (Left 0)) YAxis (Si
-} -}
renderAxis :: Ranges -> AxisData -> Render () renderAxis :: Ranges -> AxisData -> Render ()
renderAxis _ (Axis _ _ NoLine _ _ _ _ _) = return () renderAxis _ (Axis _ _ NoLine _ _ _ _ _) = return ()
renderAxis r (Axis ax sd renderAxis r (Axis ax sd
(ColourLine c) (ColourLine c)
min maj tf dl l) = do min maj tf dl l) = do
lo <- asks (_lineoptions . _renderoptions) lo <- asks (_lineoptions . _renderoptions)
renderAxis r (Axis ax sd (TypeLine lo c) min maj tf dl l) renderAxis r (Axis ax sd (TypeLine lo c) min maj tf dl l)
@ -278,7 +283,7 @@ lowerRange (Right (r@(Range _ _ _),_)) = r
renderAxisLine :: Ranges -> AxisType -> AxisPosn -> Render () renderAxisLine :: Ranges -> AxisType -> AxisPosn -> Render ()
renderAxisLine (Ranges _ yr) XAxis (Value v) = do renderAxisLine (Ranges _ yr) XAxis (Value v) = do
let (Range _ min max) = lowerRange yr let (Range _ min max) = lowerRange yr
(BoundingBox x y w h) <- get (BoundingBox x y w h) <- get
cairo $ do cairo $ do
lw' <- C.getLineWidth lw' <- C.getLineWidth
@ -287,7 +292,7 @@ renderAxisLine (Ranges _ yr) XAxis (Value v) = do
lineTo (x+w+lw) (y+h*((max-v)/(max-min))) lineTo (x+w+lw) (y+h*((max-v)/(max-min)))
C.stroke C.stroke
renderAxisLine (Ranges xr _) YAxis (Value v) = do renderAxisLine (Ranges xr _) YAxis (Value v) = do
let (Range _ min max) = lowerRange xr let (Range _ min max) = lowerRange xr
(BoundingBox x y w h) <- get (BoundingBox x y w h) <- get
cairo $ do cairo $ do
lw' <- C.getLineWidth lw' <- C.getLineWidth
@ -329,7 +334,7 @@ renderAxisLine _ YAxis (Side Upper) = do
C.stroke C.stroke
tickPosition :: Tick -> Scale -> Double -> Double -> Either Int [Double] -> [(Double,Double)] tickPosition :: Tick -> Scale -> Double -> Double -> Either Int [Double] -> [(Double,Double)]
tickPosition _ sc min max nv = tickPosition _ sc min max nv =
let ticks = either (\n -> take n [(0::Double)..]) id nv let ticks = either (\n -> take n [(0::Double)..]) id nv
l = fromIntegral $ length ticks - 1 l = fromIntegral $ length ticks - 1
pos = case nv of pos = case nv of
@ -367,7 +372,7 @@ renderAxisTicks (Ranges xrange yrange) ax sd tmn tmj tf dl = do
(Right (_,Range scl xmin xmax)) -> (scl,xmin,xmax) (Right (_,Range scl xmin xmax)) -> (scl,xmin,xmax)
(Value _) -> case xrange of (Value _) -> case xrange of
(Left (Range scl xmin xmax)) -> (scl,xmin,xmax) (Left (Range scl xmin xmax)) -> (scl,xmin,xmax)
(Right (Range scl xmin xmax,_)) -> (scl,xmin,xmax) (Right (Range scl xmin xmax,_)) -> (scl,xmin,xmax)
YAxis -> case sd of YAxis -> case sd of
(Side Lower) -> case yrange of (Side Lower) -> case yrange of
(Left (Range scl ymin ymax)) -> (scl,ymin,ymax) (Left (Range scl ymin ymax)) -> (scl,ymin,ymax)
@ -382,31 +387,31 @@ renderAxisTicks (Ranges xrange yrange) ax sd tmn tmj tf dl = do
let sd' = case sd of let sd' = case sd of
(Side _) -> sd (Side _) -> sd
(Value v) -> case ax of (Value v) -> case ax of
XAxis -> let (Range _ b t) = XAxis -> let (Range _ b t) =
lowerRange yrange lowerRange yrange
in Value (y+h*(t-v)/(t-b)) in Value (y+h*(t-v)/(t-b))
YAxis -> let (Range _ b t) = YAxis -> let (Range _ b t) =
lowerRange xrange lowerRange xrange
in Value (x+w*(v-b)/(t-b)) in Value (x+w*(v-b)/(t-b))
let renderAxisTick' = renderAxisTick pc to x y w h let renderAxisTick' = renderAxisTick pc to x y w h
sc min max ax sd' tf sc min max ax sd' tf
(majpos',gmaj',tjpos,tmaj') <- case tmj of (majpos',gmaj',tjpos,tmaj') <- case tmj of
(Just (Ticks gmaj (TickNumber tmaj))) -> do (Just (Ticks gmaj (TickNumber tmaj))) -> do
let (pos,val) = unzip (tickPosition Major sc min max let (pos,val) = unzip (tickPosition Major sc min max
(Left tmaj)) (Left tmaj))
let ln = length pos let ln = length pos
let dl' = if null dl let dl' = if null dl
then replicate ln Nothing then replicate ln Nothing
else map Just dl else map Just dl
let majpos = let ones = 1.0 : ones let majpos = let ones = 1.0 : ones
in zip4 pos (take ln ones) val dl' in zip4 pos (take ln ones) val dl'
return $ (Just majpos,Just gmaj,Just pos,Just tmaj) return $ (Just majpos,Just gmaj,Just pos,Just tmaj)
(Just (Ticks gmaj (TickValues tmaj))) -> do (Just (Ticks gmaj (TickValues tmaj))) -> do
let (pos,val) = unzip (tickPosition Major sc min max let (pos,val) = unzip (tickPosition Major sc min max
(Right $ toList tmaj)) (Right $ toList tmaj))
ln = length pos ln = length pos
let dl' = if null dl let dl' = if null dl
then replicate ln Nothing then replicate ln Nothing
else map Just dl else map Just dl
let majpos = let ones = 1.0 : ones let majpos = let ones = 1.0 : ones
in zip4 pos (take ln ones) val dl' in zip4 pos (take ln ones) val dl'
@ -414,31 +419,31 @@ renderAxisTicks (Ranges xrange yrange) ax sd tmn tmj tf dl = do
Nothing -> return (Nothing,Nothing,Nothing,Nothing) Nothing -> return (Nothing,Nothing,Nothing,Nothing)
(minpos',gmin') <- case tmn of (minpos',gmin') <- case tmn of
(Just (Ticks gmin (TickNumber tmin))) -> do (Just (Ticks gmin (TickNumber tmin))) -> do
let (pos',val') = unzip (tickPosition Minor sc min max let (pos',val') = unzip (tickPosition Minor sc min max
(Left tmin)) (Left tmin))
ln' = length pos' ln' = length pos'
minpos' = zip4 pos' (minorTickLengths tmin minpos' = zip4 pos' (minorTickLengths tmin
(maybe 0 id tmaj')) val' (maybe 0 id tmaj')) val'
(replicate ln' Nothing) (replicate ln' Nothing)
minpos = filter (not . (\(p,_,_,_) -> minpos = filter (not . (\(p,_,_,_) ->
elem p (maybe [] id tjpos))) minpos' elem p (maybe [] id tjpos))) minpos'
return $ (Just minpos,Just gmin) return $ (Just minpos,Just gmin)
(Just (Ticks gmin (TickValues tmin))) -> do (Just (Ticks gmin (TickValues tmin))) -> do
let (pos,val) = unzip (tickPosition Minor sc min max let (pos,val) = unzip (tickPosition Minor sc min max
(Right $ toList tmin)) (Right $ toList tmin))
ln = length pos ln = length pos
minpos' = let halves = 0.7 : halves minpos' = let halves = 0.7 : halves
in zip4 pos halves pos (replicate ln Nothing) in zip4 pos halves pos (replicate ln Nothing)
minpos = filter (not . (\(p,_,_,_) -> minpos = filter (not . (\(p,_,_,_) ->
elem p (maybe [] id tjpos))) minpos' elem p (maybe [] id tjpos))) minpos'
return $ (Just minpos,Just gmin) return $ (Just minpos,Just gmin)
Nothing -> return (Nothing,Nothing) Nothing -> return (Nothing,Nothing)
case majpos' of case majpos' of
(Just m) -> mapM_ (renderAxisTick' Major (Just m) -> mapM_ (renderAxisTick' Major
(maybe NoLine id gmaj')) m (maybe NoLine id gmaj')) m
Nothing -> return () Nothing -> return ()
case minpos' of case minpos' of
(Just m) -> mapM_ (renderAxisTick' Minor (Just m) -> mapM_ (renderAxisTick' Minor
(maybe NoLine id gmin')) m (maybe NoLine id gmin')) m
Nothing -> return () Nothing -> return ()
return () return ()
@ -449,7 +454,7 @@ minorTickLengths min maj = let num = (min-1) `div` (maj-1)
in map ((/ 2) . (+ 1) . (* 2) . (/ (fromIntegral num)) . fromIntegral . (\x -> if x > (num `div` 2) then num - x else x) . (`mod` num)) (take (min+1) [0..]) in map ((/ 2) . (+ 1) . (* 2) . (/ (fromIntegral num)) . fromIntegral . (\x -> if x > (num `div` 2) then num - x else x) . (`mod` num)) (take (min+1) [0..])
--map ((/) 2 . (+) 1 . (/) (fromIntegral tmaj) . fromIntegral . (mod tmaj)) (take (tmin+1) [0..]) --map ((/) 2 . (+) 1 . (/) (fromIntegral tmaj) . fromIntegral . (mod tmaj)) (take (tmin+1) [0..])
renderAxisTick :: P.PangoContext -> TextOptions renderAxisTick :: P.PangoContext -> TextOptions
-> Double -> Double -> Double -> Double -> Scale -> Double -> Double -> Double -> Double -> Double -> Double -> Scale -> Double -> Double
-> AxisType -> AxisPosn -> TickFormat -> Tick -> LineType -> AxisType -> AxisPosn -> TickFormat -> Tick -> LineType
-> (Double,Double,Double,Maybe TextEntry) -> C.Render () -> (Double,Double,Double,Maybe TextEntry) -> C.Render ()
@ -493,12 +498,12 @@ renderAxisTick pc to x y w h sc min max xa sd tf t gl (p,l,v,dl) = do
(Value _) -> let yt y' = (y + h) - (y'-min)*h/(max-min) (Value _) -> let yt y' = (y + h) - (y'-min)*h/(max-min)
in (x,yt p,x+w,yt p) in (x,yt p,x+w,yt p)
C.save C.save
setLineStyle gl setLineStyle gl
moveTo x3 y3 moveTo x3 y3
lineTo x4 y4 lineTo x4 y4
C.stroke C.stroke
C.restore) C.restore)
let majlab = case sd of let majlab = case sd of
(Side _) -> True (Side _) -> True
(Value _) -> False (Value _) -> False
when (t == Major && majlab) $ do when (t == Major && majlab) $ do
@ -513,7 +518,7 @@ renderAxisTick pc to x y w h sc min max xa sd tf t gl (p,l,v,dl) = do
FontText _ ft -> ft FontText _ ft -> ft
lo <- pango $ P.layoutText pc s'' lo <- pango $ P.layoutText pc s''
setTextOptions (scaleFontSize tickLabelScale to) lo setTextOptions (scaleFontSize tickLabelScale to) lo
case xa of case xa of
XAxis -> do XAxis -> do
case sd of case sd of
(Side Lower) -> do (Side Lower) -> do

101
lib/Graphics/Rendering/Plot/Render/Plot/Data.hs

@ -1,6 +1,7 @@
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UnicodeSyntax #-} {-# LANGUAGE UnicodeSyntax #-}
{-# LANGUAGE CPP #-}
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- | -- |
@ -26,7 +27,7 @@ module Graphics.Rendering.Plot.Render.Plot.Data (
import Data.List(partition) import Data.List(partition)
--import Prelude.Unicode --import Prelude.Unicode
--import Foreign.Storable --import Foreign.Storable
--import Foreign.Ptr --import Foreign.Ptr
import Numeric.LinearAlgebra hiding (Upper, Lower) import Numeric.LinearAlgebra hiding (Upper, Lower)
@ -39,7 +40,7 @@ import qualified Data.Array.Base as B
import Data.Word import Data.Word
import Data.Maybe import Data.Maybe
import qualified Graphics.Rendering.Cairo as C import qualified Graphics.Rendering.Cairo as C
import qualified Graphics.Rendering.Cairo.Matrix as CM import qualified Graphics.Rendering.Cairo.Matrix as CM
@ -58,6 +59,10 @@ import Graphics.Rendering.Plot.Defaults
import Prelude hiding(min,max,abs) import Prelude hiding(min,max,abs)
import qualified Prelude import qualified Prelude
#if MIN_VERSION_mtl(2,3,0)
import Control.Monad
#endif
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
findMinIdx, findMaxIdx :: Vector Double -> Double -> Int -> Int -> Int findMinIdx, findMaxIdx :: Vector Double -> Double -> Int -> Int -> Int
@ -94,7 +99,7 @@ zeroToOne x
| otherwise = x | otherwise = x
renderData :: Ranges -> BarSetting -> SampleData -> DataSeries -> Render () renderData :: Ranges -> BarSetting -> SampleData -> DataSeries -> Render ()
renderData _ _ _ (DS_Surf m) = do renderData _ _ _ (DS_Surf m) = do
(BoundingBox x y w h) <- get (BoundingBox x y w h) <- get
let r = rows m let r = rows m
c = cols m c = cols m
@ -126,25 +131,25 @@ renderData _ _ _ (DS_Surf m) = do
renderData r bc sd ds = do renderData r bc sd ds = do
let aos = case ds of let aos = case ds of
(DS_Y os') -> zip (repeat (AbsFunction id)) (A.elems os') (DS_Y os') -> zip (repeat (AbsFunction id)) (A.elems os')
(DS_1toN abs' os') -> zip (repeat abs') (A.elems os') (DS_1toN abs' os') -> zip (repeat abs') (A.elems os')
(DS_1to1 aos') -> A.elems aos' (DS_1to1 aos') -> A.elems aos'
_ -> error "renderData: DataSeries not handled" _ -> error "renderData: DataSeries not handled"
let (los,ups) = partition (\(_,DecSeries o _) -> isLower o) aos let (los,ups) = partition (\(_,DecSeries o _) -> isLower o) aos
(BoundingBox x y w h) <- get (BoundingBox x y w h) <- get
let (xsc,xmin',xmax') = getRanges XAxis Lower r let (xsc,xmin',xmax') = getRanges XAxis Lower r
let (xmin,xmax) = if xsc == Log then (logBase 10 $ zeroToOne xmin',logBase 10 $ zeroToOne xmax') else (xmin',xmax') let (xmin,xmax) = if xsc == Log then (logBase 10 $ zeroToOne xmin',logBase 10 $ zeroToOne xmax') else (xmin',xmax')
let xscale = w/(xmax-xmin) let xscale = w/(xmax-xmin)
cairo $ C.save cairo $ C.save
let (yscl,yminl',ymaxl') = getRanges YAxis Lower r let (yscl,yminl',ymaxl') = getRanges YAxis Lower r
let (yminl,ymaxl) = if yscl == Log then (logBase 10 $ zeroToOne yminl',logBase 10 $ zeroToOne ymaxl') else (yminl',ymaxl') let (yminl,ymaxl) = if yscl == Log then (logBase 10 $ zeroToOne yminl',logBase 10 $ zeroToOne ymaxl') else (yminl',ymaxl')
let yscalel = h/(ymaxl-yminl) let yscalel = h/(ymaxl-yminl)
-- transform to data coordinates -- transform to data coordinates
cairo $ do cairo $ do
C.translate x (y+h) C.translate x (y+h)
--C.scale xscale yscalel --C.scale xscale yscalel
C.translate (-xmin*xscale) (yminl*yscalel) C.translate (-xmin*xscale) (yminl*yscalel)
flipVertical flipVertical
los' <- configureBars xsc yscl xmin xmax xscale yscalel bc los los' <- configureBars xsc yscl xmin xmax xscale yscalel bc los
mapM_ (renderSeries xsc yscl xmin xmax xscale yscalel sd) los' mapM_ (renderSeries xsc yscl xmin xmax xscale yscalel sd) los'
cairo $ C.restore cairo $ C.restore
when (not $ null ups) when (not $ null ups)
@ -152,14 +157,14 @@ renderData r bc sd ds = do
cairo $ C.save cairo $ C.save
let (yscu,yminu',ymaxu') = getRanges YAxis Upper r let (yscu,yminu',ymaxu') = getRanges YAxis Upper r
let (yminu,ymaxu) = if yscu == Log then (logBase 10 $ zeroToOne yminu',logBase 10 $ zeroToOne ymaxu') else (yminu',ymaxu') let (yminu,ymaxu) = if yscu == Log then (logBase 10 $ zeroToOne yminu',logBase 10 $ zeroToOne ymaxu') else (yminu',ymaxu')
let yscaleu = h/(ymaxu-yminu) let yscaleu = h/(ymaxu-yminu)
-- transform to data coordinates -- transform to data coordinates
cairo $ do cairo $ do
C.translate x (y+h) C.translate x (y+h)
--C.scale xscale yscaleu --C.scale xscale yscaleu
C.translate (-xmin*xscale) (yminu*yscaleu) C.translate (-xmin*xscale) (yminu*yscaleu)
flipVertical flipVertical
ups' <- configureBars xsc yscu xmin xmax xscale yscaleu bc ups ups' <- configureBars xsc yscu xmin xmax xscale yscaleu bc ups
mapM_ (renderSeries xsc yscu xmin xmax xscale yscaleu sd) ups' mapM_ (renderSeries xsc yscu xmin xmax xscale yscaleu sd) ups'
cairo $ C.restore) cairo $ C.restore)
-- could filter annotations as well -- could filter annotations as well
@ -169,7 +174,7 @@ logSeries :: Scale -> Vector Double -> Vector Double
logSeries Log a = logBase 10 $ cmap zeroToOne a logSeries Log a = logBase 10 $ cmap zeroToOne a
logSeries _ a = a logSeries _ a = a
midpoints :: (Fractional t, Num (Vector t), Container Vector t) midpoints :: (Fractional t, Num (Vector t), Container Vector t)
=> (t1, Vector t) -> (t1, Vector t) => (t1, Vector t) -> (t1, Vector t)
midpoints(mi,v) = let v' = subVector 1 (size v - 1) v midpoints(mi,v) = let v' = subVector 1 (size v - 1) v
w' = subVector 0 (size v - 1) v w' = subVector 0 (size v - 1) v
@ -179,8 +184,8 @@ logSeriesMinMax :: Scale -> (Vector Double,Vector Double) -> (Vector Double,Vect
logSeriesMinMax Log (v,w) = (logSeries Log v,logSeries Log w) logSeriesMinMax Log (v,w) = (logSeries Log v,logSeries Log w)
logSeriesMinMax Linear x = x logSeriesMinMax Linear x = x
getBar :: (Integer,(Abscissae,DecoratedSeries)) getBar :: (Integer,(Abscissae,DecoratedSeries))
-> Maybe (Integer,(Abscissae,DecoratedSeries,BarType)) -> Maybe (Integer,(Abscissae,DecoratedSeries,BarType))
getBar (ix,(as,DecSeries os ds)) = let d = decorationGetBarType ds getBar (ix,(as,DecSeries os ds)) = let d = decorationGetBarType ds
in case d of in case d of
Just d' -> Just (ix,(as,DecSeries os ds,d')) Just d' -> Just (ix,(as,DecSeries os ds,d'))
@ -201,9 +206,9 @@ shiftAbscissa :: (Integer,(Abscissae,DecoratedSeries,BarType)) -> Double
shiftAbscissa (j,(AbsFunction f,ds,_)) s = (j,(AbsFunction ((+) s . f),ds)) shiftAbscissa (j,(AbsFunction f,ds,_)) s = (j,(AbsFunction ((+) s . f),ds))
shiftAbscissa (j,(AbsPoints mi t,ds,_)) s = (j,(AbsPoints mi ((+) (vector [s]) t),ds)) shiftAbscissa (j,(AbsPoints mi t,ds,_)) s = (j,(AbsPoints mi ((+) (vector [s]) t),ds))
replaceBars :: [(Integer,(Abscissae,DecoratedSeries))] replaceBars :: [(Integer,(Abscissae,DecoratedSeries))]
-> [(Abscissae,DecoratedSeries)] -> [(Abscissae,DecoratedSeries)]
-> [(Abscissae,DecoratedSeries)] -> [(Abscissae,DecoratedSeries)]
replaceBars [] as = as replaceBars [] as = as
replaceBars ((j,ds):dss) as = replaceBars dss $ replace j ds as replaceBars ((j,ds):dss) as = replaceBars dss $ replace j ds as
@ -225,7 +230,7 @@ convertBarToCandle (v,w) os =
mkCandlesFromBars :: (Vector Double,Vector Double) mkCandlesFromBars :: (Vector Double,Vector Double)
-> (Integer,(Abscissae,DecoratedSeries,BarType)) -> (Integer,(Abscissae,DecoratedSeries,BarType))
-> (Integer,(Abscissae,DecoratedSeries)) -> (Integer,(Abscissae,DecoratedSeries))
mkCandlesFromBars (v,w) (j,(a,DecSeries (OrdPoints ax o mb_l) _,bt)) = mkCandlesFromBars (v,w) (j,(a,DecSeries (OrdPoints ax o mb_l) _,bt)) =
(j,(a,DecSeries (OrdPoints ax ordSeries mb_l) (DecCand bt))) (j,(a,DecSeries (OrdPoints ax ordSeries mb_l) (DecCand bt)))
where where
ordSeries = convertBarToCandle (v,w) o ordSeries = convertBarToCandle (v,w) o
@ -238,8 +243,8 @@ getOrdData' _ = error "Data.hs:getOrdData': unrea
configureBars :: Scale -> Scale configureBars :: Scale -> Scale
-> Double -> Double -> Double -> Double -> Double -> Double -> Double -> Double
-> BarSetting -> BarSetting
-> [(Abscissae,DecoratedSeries)] -> [(Abscissae,DecoratedSeries)]
-> Render [(Abscissae,DecoratedSeries)] -> Render [(Abscissae,DecoratedSeries)]
configureBars _ _ _ _ xscale _ bs aos = do configureBars _ _ _ _ xscale _ bs aos = do
let bars = mapMaybe getBar $ zip [0..] aos let bars = mapMaybe getBar $ zip [0..] aos
case bs of case bs of
@ -256,7 +261,7 @@ configureBars _ _ _ _ xscale _ bs aos = do
let od = (getOrdData' . (\(_,b,_) -> b) . snd . head) bars let od = (getOrdData' . (\(_,b,_) -> b) . snd . head) bars
let ln = size $ od let ln = size $ od
let zero = konst 0 ln let zero = konst 0 ln
let pairs = pair $ scanl scanStacked zero bars let pairs = pair $ scanl scanStacked zero bars
let candles = zipWith mkCandlesFromBars pairs bars let candles = zipWith mkCandlesFromBars pairs bars
let aos' = replaceBars candles aos let aos' = replaceBars candles aos
return aos' return aos'
@ -265,8 +270,8 @@ configureBars _ _ _ _ xscale _ bs aos = do
pair [x,y] = [(x,y)] pair [x,y] = [(x,y)]
pair (x:y:xs) = (x,y) : pair (y:xs) pair (x:y:xs) = (x,y) : pair (y:xs)
renderSeries :: Scale -> Scale renderSeries :: Scale -> Scale
-> Double -> Double -> Double -> Double -> SampleData -> Double -> Double -> Double -> Double -> SampleData
-> (Abscissae,DecoratedSeries) -> Render () -> (Abscissae,DecoratedSeries) -> Render ()
renderSeries xsc ysc xmin xmax xscale yscale sd (abs,(DecSeries o d)) = do renderSeries xsc ysc xmin xmax xscale yscale sd (abs,(DecSeries o d)) = do
dat <- case o of dat <- case o of
@ -276,7 +281,7 @@ renderSeries xsc ysc xmin xmax xscale yscale sd (abs,(DecSeries o d)) = do
return $ Left $ Left ((True,t),logSeries ysc $ f t) return $ Left $ Left ((True,t),logSeries ysc $ f t)
(OrdPoints _ (Plain o') _) -> do (OrdPoints _ (Plain o') _) -> do
let t = case abs of let t = case abs of
AbsFunction f -> AbsFunction f ->
if isHist d if isHist d
then (True,cmap f $ fromList [0.0..(fromIntegral $ size o')]) then (True,cmap f $ fromList [0.0..(fromIntegral $ size o')])
else (True,cmap f $ fromList [1.0..(fromIntegral $ size o')]) else (True,cmap f $ fromList [1.0..(fromIntegral $ size o')])
@ -284,7 +289,7 @@ renderSeries xsc ysc xmin xmax xscale yscale sd (abs,(DecSeries o d)) = do
return $ Left $ Left ((fst t,logSeries xsc $ snd t),logSeries ysc $ o') return $ Left $ Left ((fst t,logSeries xsc $ snd t),logSeries ysc $ o')
(OrdPoints _ (Error o' (Left e)) _) -> do (OrdPoints _ (Error o' (Left e)) _) -> do
let t = case abs of let t = case abs of
AbsFunction f -> AbsFunction f ->
if isHist d if isHist d
then (True,cmap f $ fromList [0.0..(fromIntegral $ size o')]) then (True,cmap f $ fromList [0.0..(fromIntegral $ size o')])
else (True,cmap f $ fromList [1.0..(fromIntegral $ size o')]) else (True,cmap f $ fromList [1.0..(fromIntegral $ size o')])
@ -293,11 +298,11 @@ renderSeries xsc ysc xmin xmax xscale yscale sd (abs,(DecSeries o d)) = do
return $ Left $ Right $ Left ((t',logSeries ysc $ o'),(t',logSeries ysc $ e)) return $ Left $ Right $ Left ((t',logSeries ysc $ o'),(t',logSeries ysc $ e))
(OrdPoints _ (Error o' (Right (l,h))) _) -> do (OrdPoints _ (Error o' (Right (l,h))) _) -> do
let t = case abs of let t = case abs of
AbsFunction f -> AbsFunction f ->
if isHist d if isHist d
then (True,cmap f $ fromList [0.0..(fromIntegral $ size o')]) then (True,cmap f $ fromList [0.0..(fromIntegral $ size o')])
else (True,cmap f $ fromList [1.0..(fromIntegral $ size o')]) else (True,cmap f $ fromList [1.0..(fromIntegral $ size o')])
AbsPoints mi t' -> (mi,t') AbsPoints mi t' -> (mi,t')
let t' = (fst t,logSeries xsc $ snd t) let t' = (fst t,logSeries xsc $ snd t)
return $ Left $ Right $ Right ((t',logSeries ysc $ o'),(t',logSeries ysc $ l),(t',logSeries ysc $ h)) return $ Left $ Right $ Right ((t',logSeries ysc $ o'),(t',logSeries ysc $ l),(t',logSeries ysc $ h))
(OrdPoints _ (MinMax o' Nothing) _) -> do (OrdPoints _ (MinMax o' Nothing) _) -> do
@ -330,8 +335,8 @@ renderSeries xsc ysc xmin xmax xscale yscale sd (abs,(DecSeries o d)) = do
renderSamples xscale yscale xmin xmax sd Nothing (renderPointSample pz Top) endPointSample t' (y'+e') renderSamples xscale yscale xmin xmax sd Nothing (renderPointSample pz Top) endPointSample t' (y'+e')
Left (Right (Right ((t',y'),(_,l),(_,h)))) -> do Left (Right (Right ((t',y'),(_,l),(_,h)))) -> do
renderSamples xscale yscale xmin xmax sd Nothing (renderPointSample pz g) endPointSample t' y' renderSamples xscale yscale xmin xmax sd Nothing (renderPointSample pz g) endPointSample t' y'
renderSamples xscale yscale xmin xmax sd Nothing (renderPointSample pz Bot) endPointSample t' l renderSamples xscale yscale xmin xmax sd Nothing (renderPointSample pz Bot) endPointSample t' l
renderSamples xscale yscale xmin xmax sd Nothing (renderPointSample pz Top) endPointSample t' h renderSamples xscale yscale xmin xmax sd Nothing (renderPointSample pz Top) endPointSample t' h
_ -> error "Data.hs renderSeries: cannot have MinMax data series with point type" _ -> error "Data.hs renderSeries: cannot have MinMax data series with point type"
(DecLinPt lt pt) -> do (DecLinPt lt pt) -> do
formatLineSeries lt formatLineSeries lt
@ -345,12 +350,12 @@ renderSeries xsc ysc xmin xmax xscale yscale sd (abs,(DecSeries o d)) = do
renderSamples xscale yscale xmin xmax sd Nothing (renderPointSample pz g) endPointSample t' y' renderSamples xscale yscale xmin xmax sd Nothing (renderPointSample pz g) endPointSample t' y'
renderSamples xscale yscale xmin xmax sd Nothing (renderPointSample pz Bot) endPointSample t' (y'-e') renderSamples xscale yscale xmin xmax sd Nothing (renderPointSample pz Bot) endPointSample t' (y'-e')
renderSamples xscale yscale xmin xmax sd Nothing (renderPointSample pz Top) endPointSample t' (y'+e') renderSamples xscale yscale xmin xmax sd Nothing (renderPointSample pz Top) endPointSample t' (y'+e')
-- error "Data.hs renderSeries: cannot have single error value with line-points type" -- error "Data.hs renderSeries: cannot have single error value with line-points type"
Left (Right (Right ((t',y'),(_,l),(_,h)))) -> do Left (Right (Right ((t',y'),(_,l),(_,h)))) -> do
renderSamples xscale yscale xmin xmax sd Nothing renderLineSample endLineSample t' y' renderSamples xscale yscale xmin xmax sd Nothing renderLineSample endLineSample t' y'
renderSamples xscale yscale xmin xmax sd Nothing (renderPointSample pz g) endPointSample t' y' renderSamples xscale yscale xmin xmax sd Nothing (renderPointSample pz g) endPointSample t' y'
renderSamples xscale yscale xmin xmax sd Nothing (renderPointSample pz Bot) endPointSample t' l renderSamples xscale yscale xmin xmax sd Nothing (renderPointSample pz Bot) endPointSample t' l
renderSamples xscale yscale xmin xmax sd Nothing (renderPointSample pz Top) endPointSample t' h renderSamples xscale yscale xmin xmax sd Nothing (renderPointSample pz Top) endPointSample t' h
_ -> error "Data.hs renderSeries: cannot have MinMax data series with line-point type" _ -> error "Data.hs renderSeries: cannot have MinMax data series with line-point type"
(DecImpulse lt) -> do (DecImpulse lt) -> do
formatLineSeries lt formatLineSeries lt
@ -376,21 +381,21 @@ renderSeries xsc ysc xmin xmax xscale yscale sd (abs,(DecSeries o d)) = do
_ -> error "Data.hs renderSeries: cannot have error bars with area type" _ -> error "Data.hs renderSeries: cannot have error bars with area type"
(DecBar bt) -> do (DecBar bt) -> do
(bw,bc,c) <- formatBarSeries bt (bw,bc,c) <- formatBarSeries bt
(gw,_) <- formatPointSeries defaultPointType (gw,_) <- formatPointSeries defaultPointType
case dat of case dat of
Left (Left (t',y')) -> do Left (Left (t',y')) -> do
renderSamples xscale yscale xmin xmax sd Nothing (renderBarSample bw bc c) endBarSample t' y' renderSamples xscale yscale xmin xmax sd Nothing (renderBarSample bw bc c) endBarSample t' y'
Left (Right (Left ((t',y'),(_,e')))) -> do Left (Right (Left ((t',y'),(_,e')))) -> do
renderSamples xscale yscale xmin xmax sd Nothing (renderBarSample bw bc c) endBarSample t' y' renderSamples xscale yscale xmin xmax sd Nothing (renderBarSample bw bc c) endBarSample t' y'
renderSamples xscale yscale xmin xmax sd Nothing (renderPointSampleUpDown gw) endPointSample t' e' renderSamples xscale yscale xmin xmax sd Nothing (renderPointSampleUpDown gw) endPointSample t' e'
Left (Right (Right ((t',y'),(_,l'),(_,h')))) -> do Left (Right (Right ((t',y'),(_,l'),(_,h')))) -> do
renderSamples xscale yscale xmin xmax sd Nothing (renderBarSample bw bc c) endBarSample t' y' renderSamples xscale yscale xmin xmax sd Nothing (renderBarSample bw bc c) endBarSample t' y'
renderSamples xscale yscale xmin xmax sd Nothing (renderPointSample gw Bot) endPointSample t' l' renderSamples xscale yscale xmin xmax sd Nothing (renderPointSample gw Bot) endPointSample t' l'
renderSamples xscale yscale xmin xmax sd Nothing (renderPointSample gw Top) endPointSample t' h' renderSamples xscale yscale xmin xmax sd Nothing (renderPointSample gw Top) endPointSample t' h'
_ -> error "Data.hs renderSeries: cannot have MinMax data series with bar type" _ -> error "Data.hs renderSeries: cannot have MinMax data series with bar type"
(DecHist bt) -> do (DecHist bt) -> do
(bw,bc,c) <- formatBarSeries bt (bw,bc,c) <- formatBarSeries bt
(gw,_) <- formatPointSeries defaultPointType (gw,_) <- formatPointSeries defaultPointType
case dat of case dat of
Left (Left (t',y')) -> do Left (Left (t',y')) -> do
let ln = size $ snd $ t' let ln = size $ snd $ t'
@ -419,7 +424,7 @@ renderSeries xsc ysc xmin xmax xscale yscale sd (abs,(DecSeries o d)) = do
_ -> error "Data.hs renderSeries: cannot have MinMax data series with histogram type" _ -> error "Data.hs renderSeries: cannot have MinMax data series with histogram type"
(DecCand bt) → do (DecCand bt) → do
(bw,bc,c) <- formatBarSeries bt (bw,bc,c) <- formatBarSeries bt
case dat of case dat of
Left _ -> error "Candles series requires two data series (MinMax series)" Left _ -> error "Candles series requires two data series (MinMax series)"
Right (Left (t',y')) -> do Right (Left (t',y')) -> do
renderMinMaxSamples xscale yscale xmin xmax sd Nothing (renderCandleSample bw bc c) endCandleSample t' y' renderMinMaxSamples xscale yscale xmin xmax sd Nothing (renderCandleSample bw bc c) endCandleSample t' y'
@ -428,7 +433,7 @@ renderSeries xsc ysc xmin xmax xscale yscale sd (abs,(DecSeries o d)) = do
renderMinMaxSamples xscale yscale xmin xmax sd Nothing (renderCandleSample bw bc c) endCandleSample t' y' renderMinMaxSamples xscale yscale xmin xmax sd Nothing (renderCandleSample bw bc c) endCandleSample t' y'
(DecWhisk bt) → do (DecWhisk bt) → do
(bw,bc,c) <- formatBarSeries bt (bw,bc,c) <- formatBarSeries bt
case dat of case dat of
Left _ -> error "Candles series requires two data series (MinMax series)" Left _ -> error "Candles series requires two data series (MinMax series)"
Right (Left (t',y')) -> do Right (Left (t',y')) -> do
renderMinMaxSamples xscale yscale xmin xmax sd Nothing (renderCandleSample bw bc c) endCandleSample t' y' renderMinMaxSamples xscale yscale xmin xmax sd Nothing (renderCandleSample bw bc c) endCandleSample t' y'
@ -439,8 +444,8 @@ renderSeries xsc ysc xmin xmax xscale yscale sd (abs,(DecSeries o d)) = do
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
renderSamples :: Double -> Double renderSamples :: Double -> Double
-> Double -> Double -> Double -> Double
-> SampleData -> SampleData
-> Maybe (C.Render ()) -> Maybe (C.Render ())
-> (Double -> Double -> Double -> Double -> C.Render ()) -> (Double -> Double -> C.Render ()) -> (Double -> Double -> Double -> Double -> C.Render ()) -> (Double -> Double -> C.Render ())
@ -469,8 +474,8 @@ renderSamples xscale yscale xmin xmax sd s f e (mono,t) y = do
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
renderMinMaxSamples :: Double -> Double renderMinMaxSamples :: Double -> Double
-> Double -> Double -> Double -> Double
-> SampleData -> SampleData
-> Maybe (C.Render ()) -> Maybe (C.Render ())
-> (Double -> Double -> Double -> (Double,Double) -> C.Render ()) -> (Double -> Double -> C.Render ()) -> (Double -> Double -> Double -> (Double,Double) -> C.Render ()) -> (Double -> Double -> C.Render ())
@ -498,7 +503,7 @@ renderMinMaxSamples xscale yscale xmin xmax sd s f e (mono,t) y = do
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
renderSample :: Int -> Int -> Vector Double renderSample :: Int -> Int -> Vector Double
-> (Double -> Double -> C.Render ()) -> (Double -> Double -> C.Render ())
-> Double -> MaybeT C.Render () -> Double -> MaybeT C.Render ()
renderSample ix xmax_ix t f y renderSample ix xmax_ix t f y
@ -508,8 +513,8 @@ renderSample ix xmax_ix t f y
| otherwise = do | otherwise = do
lift $ f (t `atIndex` ix) y lift $ f (t `atIndex` ix) y
renderMinMaxSample :: Int -> Int -> Double renderMinMaxSample :: Int -> Int -> Double
-> (Double -> (Double,Double) -> C.Render ()) -> C.Render () -> (Double -> (Double,Double) -> C.Render ()) -> C.Render ()
-> (Vector Double,Vector Double) -> MaybeT C.Render () -> (Vector Double,Vector Double) -> MaybeT C.Render ()
renderMinMaxSample ix xmax_ix t f e (yl,yu) renderMinMaxSample ix xmax_ix t f e (yl,yu)
| ix >= xmax_ix = do | ix >= xmax_ix = do
@ -582,7 +587,7 @@ renderBarSample bw c bc xscale yscale x y = do
C.strokePreserve C.strokePreserve
setColour c setColour c
C.fill C.fill
endBarSample :: Double -> Double -> C.Render () endBarSample :: Double -> Double -> C.Render ()
endBarSample _ _ = return () endBarSample _ _ = return ()
@ -636,5 +641,3 @@ endWhiskerSample :: Double -> Double -> C.Render ()
endWhiskerSample _ _ = return () endWhiskerSample _ _ = return ()
----------------------------------------------------------------------------- -----------------------------------------------------------------------------

84
lib/Graphics/Rendering/Plot/Render/Plot/Legend.hs

@ -1,3 +1,4 @@
{-# LANGUAGE CPP #-}
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- | -- |
-- Module : Graphics.Rendering.Plot.Render.Plot.Legend -- Module : Graphics.Rendering.Plot.Render.Plot.Legend
@ -41,6 +42,10 @@ import Graphics.Rendering.Plot.Render.Plot.Glyph
--import Prelude hiding(min,max) --import Prelude hiding(min,max)
--import qualified Prelude(max) --import qualified Prelude(max)
#if MIN_VERSION_mtl(2,3,0)
import Control.Monad
#endif
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
renderLegend :: Maybe LegendData -> DataSeries -> Render (Padding -> Render ()) renderLegend :: Maybe LegendData -> DataSeries -> Render (Padding -> Render ())
@ -53,7 +58,7 @@ renderLegend (Just (Legend b l o to)) d = do
(w,h) <- cairo $ do (w,h) <- cairo $ do
lo <- pango $ P.layoutText pc mx lo <- pango $ P.layoutText pc mx
setTextOptions to lo setTextOptions to lo
(_,twh) <- textSize lo Centre Middle 0 0 (_,twh) <- textSize lo Centre Middle 0 0
return twh return twh
-- if outside shift bounding box -- if outside shift bounding box
case o of case o of
@ -65,21 +70,21 @@ renderLegend (Just (Legend b l o to)) d = do
Inside -> return $ \_ -> renderLegendInside b l w h to ln ls Inside -> return $ \_ -> renderLegendInside b l w h to ln ls
renderLegendOutside :: Bool -> LegendLocation -> Double -> Double -> TextOptions -> Int -> [(SeriesLabel,Decoration)] -> Render (Padding -> Render ()) renderLegendOutside :: Bool -> LegendLocation -> Double -> Double -> TextOptions -> Int -> [(SeriesLabel,Decoration)] -> Render (Padding -> Render ())
renderLegendOutside b l w h to ln ls renderLegendOutside b l w h to ln ls
| l == North = do | l == North = do
let h' = textPad + h + textPad let h' = textPad + h + textPad
bbLowerTop $ h' + 4*textPad bbLowerTop $ h' + 4*textPad
return $ \(Padding _ _ _ t) -> do return $ \(Padding _ _ _ t) -> do
x' <- bbCentreWidth x' <- bbCentreWidth
y' <- bbTopHeight y' <- bbTopHeight
let w' = (fromIntegral ln)*(textPad + legendSampleWidth let w' = (fromIntegral ln)*(textPad + legendSampleWidth
+ legendSampleWidth + textPad + w) + 5*textPad + legendSampleWidth + textPad + w) + 5*textPad
let x = x'- (w'/2) let x = x'- (w'/2)
y = y'- h' - t y = y'- h' - t
when b (cairo $ renderBorder 1.0 black (x+0.5) (y+0.5) w' h') when b (cairo $ renderBorder 1.0 black (x+0.5) (y+0.5) w' h')
renderLegendEntries (x+3*textPad) (y+textPad) renderLegendEntries (x+3*textPad) (y+textPad)
(textPad + legendSampleWidth + legendSampleWidth + textPad (textPad + legendSampleWidth + legendSampleWidth + textPad
+ w + textPad) 0 0 h to ls + w + textPad) 0 0 h to ls
return () return ()
| l == NorthEast = do | l == NorthEast = do
let h' = textPad + h + textPad let h' = textPad + h + textPad
@ -87,17 +92,17 @@ renderLegendOutside b l w h to ln ls
return $ \(Padding _ _ _ t) -> do return $ \(Padding _ _ _ t) -> do
x' <- bbRightWidth x' <- bbRightWidth
y' <- bbTopHeight y' <- bbTopHeight
let w' = (fromIntegral ln)*(textPad + legendSampleWidth let w' = (fromIntegral ln)*(textPad + legendSampleWidth
+ legendSampleWidth + textPad + w) + 5*textPad + legendSampleWidth + textPad + w) + 5*textPad
let x = x'- w' let x = x'- w'
y = y'- h' - t y = y'- h' - t
when b (cairo $ renderBorder 1.0 black (x+0.5) (y+0.5) w' h') when b (cairo $ renderBorder 1.0 black (x+0.5) (y+0.5) w' h')
renderLegendEntries (x+3*textPad) (y+textPad) renderLegendEntries (x+3*textPad) (y+textPad)
(textPad + legendSampleWidth + legendSampleWidth + textPad (textPad + legendSampleWidth + legendSampleWidth + textPad
+ w + textPad) 0 0 h to ls + w + textPad) 0 0 h to ls
return () return ()
| l == East = do | l == East = do
let w' = textPad + legendSampleWidth + legendSampleWidth let w' = textPad + legendSampleWidth + legendSampleWidth
+ textPad + w + textPad + textPad + w + textPad
bbShiftRight $ w' + 4*textPad bbShiftRight $ w' + 4*textPad
return $ \(Padding _ r _ _) -> do return $ \(Padding _ r _ _) -> do
@ -107,8 +112,8 @@ renderLegendOutside b l w h to ln ls
let x = x' + 4*textPad + r let x = x' + 4*textPad + r
y = y'-(h'/2) y = y'-(h'/2)
when b (cairo $ renderBorder 1.0 black (x+0.5) (y+0.5) w' h') when b (cairo $ renderBorder 1.0 black (x+0.5) (y+0.5) w' h')
renderLegendEntries (x+2*textPad) (y+3*textPad) 0 (h+textPad) renderLegendEntries (x+2*textPad) (y+3*textPad) 0 (h+textPad)
0 h to ls 0 h to ls
return () return ()
| l == SouthEast = do | l == SouthEast = do
let h' = textPad + h + textPad let h' = textPad + h + textPad
@ -116,14 +121,14 @@ renderLegendOutside b l w h to ln ls
return $ \(Padding _ _ b' _) -> do return $ \(Padding _ _ b' _) -> do
x' <- bbRightWidth x' <- bbRightWidth
y' <- bbBottomHeight y' <- bbBottomHeight
let w' = (fromIntegral ln)*(textPad + legendSampleWidth let w' = (fromIntegral ln)*(textPad + legendSampleWidth
+ legendSampleWidth + textPad + w) + 5*textPad + legendSampleWidth + textPad + w) + 5*textPad
let x = x'- w' let x = x'- w'
y = y' + b' +textPad y = y' + b' +textPad
when b (cairo $ renderBorder 1.0 black (x+0.5) (y+0.5) w' h') when b (cairo $ renderBorder 1.0 black (x+0.5) (y+0.5) w' h')
renderLegendEntries (x+3*textPad) (y+textPad) renderLegendEntries (x+3*textPad) (y+textPad)
(textPad + legendSampleWidth + legendSampleWidth + textPad (textPad + legendSampleWidth + legendSampleWidth + textPad
+ w + textPad) 0 0 h to ls + w + textPad) 0 0 h to ls
return () return ()
| l == South = do | l == South = do
let h' = textPad + h + textPad let h' = textPad + h + textPad
@ -131,14 +136,14 @@ renderLegendOutside b l w h to ln ls
return $ \(Padding _ _ b' _) -> do return $ \(Padding _ _ b' _) -> do
x' <- bbCentreWidth x' <- bbCentreWidth
y' <- bbBottomHeight y' <- bbBottomHeight
let w' = (fromIntegral ln)*(textPad + legendSampleWidth let w' = (fromIntegral ln)*(textPad + legendSampleWidth
+ legendSampleWidth + textPad + w) + 5*textPad + legendSampleWidth + textPad + w) + 5*textPad
let x = x' - (w'/2) let x = x' - (w'/2)
y = y' + b' +textPad y = y' + b' +textPad
when b (cairo $ renderBorder 1.0 black (x+0.5) (y+0.5) w' h') when b (cairo $ renderBorder 1.0 black (x+0.5) (y+0.5) w' h')
renderLegendEntries (x+3*textPad) (y+textPad) renderLegendEntries (x+3*textPad) (y+textPad)
(textPad + legendSampleWidth + legendSampleWidth + textPad (textPad + legendSampleWidth + legendSampleWidth + textPad
+ w + textPad) 0 0 h to ls + w + textPad) 0 0 h to ls
return () return ()
| l == SouthWest = do | l == SouthWest = do
let h' = textPad + h + textPad let h' = textPad + h + textPad
@ -146,17 +151,17 @@ renderLegendOutside b l w h to ln ls
return $ \(Padding _ _ b' _) -> do return $ \(Padding _ _ b' _) -> do
x' <- bbLeftWidth x' <- bbLeftWidth
y' <- bbBottomHeight y' <- bbBottomHeight
let w' = (fromIntegral ln)*(textPad + legendSampleWidth let w' = (fromIntegral ln)*(textPad + legendSampleWidth
+ legendSampleWidth + textPad + w) + 5*textPad + legendSampleWidth + textPad + w) + 5*textPad
let x = x' let x = x'
y = y' + b' +textPad y = y' + b' +textPad
when b (cairo $ renderBorder 1.0 black (x+0.5) (y+0.5) w' h') when b (cairo $ renderBorder 1.0 black (x+0.5) (y+0.5) w' h')
renderLegendEntries (x+3*textPad) (y+textPad) renderLegendEntries (x+3*textPad) (y+textPad)
(textPad + legendSampleWidth + legendSampleWidth + textPad (textPad + legendSampleWidth + legendSampleWidth + textPad
+ w + textPad) 0 0 h to ls + w + textPad) 0 0 h to ls
return () return ()
| l == West = do | l == West = do
let w' = textPad + legendSampleWidth + legendSampleWidth + textPad let w' = textPad + legendSampleWidth + legendSampleWidth + textPad
+ w + textPad + w + textPad
bbShiftLeft $ w' + 4*textPad bbShiftLeft $ w' + 4*textPad
return $ \(Padding l' _ _ _) -> do return $ \(Padding l' _ _ _) -> do
@ -166,8 +171,8 @@ renderLegendOutside b l w h to ln ls
let x = x' - w' - 4*textPad - l' let x = x' - w' - 4*textPad - l'
y = y'-(h'/2) y = y'-(h'/2)
when b (cairo $ renderBorder 1.0 black (x+0.5) (y+0.5) w' h') when b (cairo $ renderBorder 1.0 black (x+0.5) (y+0.5) w' h')
renderLegendEntries (x+2*textPad) (y+3*textPad) 0 (h+textPad) renderLegendEntries (x+2*textPad) (y+3*textPad) 0 (h+textPad)
0 h to ls 0 h to ls
return () return ()
| l == NorthWest = do | l == NorthWest = do
let h' = textPad + h + textPad let h' = textPad + h + textPad
@ -175,14 +180,14 @@ renderLegendOutside b l w h to ln ls
return $ \(Padding _ _ _ t) -> do return $ \(Padding _ _ _ t) -> do
x' <- bbLeftWidth x' <- bbLeftWidth
y' <- bbTopHeight y' <- bbTopHeight
let w' = (fromIntegral ln)*(textPad + legendSampleWidth let w' = (fromIntegral ln)*(textPad + legendSampleWidth
+ legendSampleWidth + textPad + w) + 5*textPad + legendSampleWidth + textPad + w) + 5*textPad
let x = x' let x = x'
y = y'- h' - t y = y'- h' - t
when b (cairo $ renderBorder 1.0 black (x+0.5) (y+0.5) w' h') when b (cairo $ renderBorder 1.0 black (x+0.5) (y+0.5) w' h')
renderLegendEntries (x+3*textPad) (y+textPad) renderLegendEntries (x+3*textPad) (y+textPad)
(textPad + legendSampleWidth + legendSampleWidth + textPad (textPad + legendSampleWidth + legendSampleWidth + textPad
+ w + textPad) 0 0 h to ls + w + textPad) 0 0 h to ls
return () return ()
renderLegendOutside _ _ _ _ _ _ _ = return (\_ -> return ()) renderLegendOutside _ _ _ _ _ _ _ = return (\_ -> return ())
@ -195,7 +200,7 @@ renderBorder lw c x y w h = do
renderLegendInside :: Bool -> LegendLocation -> Double -> Double -> TextOptions -> Int -> [(SeriesLabel,Decoration)] -> Render () renderLegendInside :: Bool -> LegendLocation -> Double -> Double -> TextOptions -> Int -> [(SeriesLabel,Decoration)] -> Render ()
renderLegendInside b l w h to ln ls = do renderLegendInside b l w h to ln ls = do
let w' = (textPad + legendSampleWidth + legendSampleWidth + textPad let w' = (textPad + legendSampleWidth + legendSampleWidth + textPad
+ w + textPad) + w + textPad)
h' = h+textPad h' = h+textPad
h'' = (fromIntegral ln)*h'+textPad h'' = (fromIntegral ln)*h'+textPad
@ -211,7 +216,7 @@ renderLegendInside b l w h to ln ls = do
East -> do East -> do
x' <- bbRightWidth x' <- bbRightWidth
y' <- bbCentreHeight y' <- bbCentreHeight
let y'' = y' - h''/2 let y'' = y' - h''/2
return (x'-w'-3*textPad,y''-textPad) return (x'-w'-3*textPad,y''-textPad)
SouthEast -> do SouthEast -> do
x' <- bbRightWidth x' <- bbRightWidth
@ -231,7 +236,7 @@ renderLegendInside b l w h to ln ls = do
West -> do West -> do
x' <- bbLeftWidth x' <- bbLeftWidth
y' <- bbCentreHeight y' <- bbCentreHeight
let y'' = y' - h''/2 let y'' = y' - h''/2
return (x'+textPad,y''-textPad) return (x'+textPad,y''-textPad)
NorthWest -> do NorthWest -> do
x' <- bbLeftWidth x' <- bbLeftWidth
@ -244,10 +249,10 @@ renderLegendInside b l w h to ln ls = do
C.rectangle (x+0.5) (y+0.5) w' h'' C.rectangle (x+0.5) (y+0.5) w' h''
C.fill C.fill
C.stroke C.stroke
renderLegendEntries (x+3*textPad) (y+textPad) 0 h' w' renderLegendEntries (x+3*textPad) (y+textPad) 0 h' w'
(h'-textPad) to ls (h'-textPad) to ls
renderLegendEntries :: Double -> Double -> Double -> Double -> Double -> Double renderLegendEntries :: Double -> Double -> Double -> Double -> Double -> Double
-> TextOptions -> TextOptions
-> [(SeriesLabel,Decoration)] -> Render () -> [(SeriesLabel,Decoration)] -> Render ()
renderLegendEntries x y wa ha w h to ls = do renderLegendEntries x y wa ha w h to ls = do
@ -280,7 +285,7 @@ renderLegendSample x y w h d = do
Nothing -> return () Nothing -> return ()
Just p' -> do Just p' -> do
cairo $ do cairo $ do
C.save C.save
C.moveTo (x+w/2) (y+h/2) C.moveTo (x+w/2) (y+h/2)
g <- setPointStyle p' g <- setPointStyle p'
renderGlyph 1 g renderGlyph 1 g
@ -301,4 +306,3 @@ getLabels (DS_1to1 d) = let mls = map (\(_,(DecSeries o d')) -> (maybe "" id $
getLabels (DS_Surf _) = (0,[]) getLabels (DS_Surf _) = (0,[])
----------------------------------------------------------------------------- -----------------------------------------------------------------------------