commit 45a55dbc5e4f3141872a50588aa2424d0d22a80f Author: Vivian McPhail Date: Thu Sep 2 02:54:50 2010 +1200 initial repository darcs-hash:20100901145450-af16d-11f5ac7750d938d81276e005e7b4a63d27620fb0.gz diff --git a/CHANGES b/CHANGES new file mode 100644 index 0000000..4cf0431 --- /dev/null +++ b/CHANGES @@ -0,0 +1,2 @@ +0.1: + * initial version diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..30c528a --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) A. V. H. McPhail 2010 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. 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. +3. Neither the name of the author nor the names of other contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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. diff --git a/README b/README new file mode 100644 index 0000000..f3cb5a8 --- /dev/null +++ b/README @@ -0,0 +1,65 @@ +THIS README COPIED FROM THE diagrams PACKAGE + +Graphics.Rendering.Figures provides an embedded domain-specific +language (EDSL) for creating figures rendered with Cairo + +For some examples of use, see http://code.haskell.org/figures/ . + +------------------------------------------------------------------------ + +To install the Figures library: + +1. Get the dependencies + + The figures library uses Haskell bindings to the Cairo vector + graphics library. In order to build the figures library, you + will first need the following: + + * The Cairo library itself. This is probably available through + your system's package manager and may even already be installed. + On Ubuntu, for example, it is available from the 'libcairo' + package. + + * The Haskell cairo bindings, which are packaged as part of + gtk2hs. Unfortunately, for various technical reasons, gtk2hs is + not cabalized and cannot be downloaded and installed from + Hackage. To get gtk2hs you will need to go to the gtk2hs + website (http://www.haskell.org/gtk2hs/) and follow the + instructions to download and build it. + + * The colour library, which is available from Hackage. If you use + the cabal-install build option described below, the colour + library will be downloaded and installed for you automatically. + +2. Build + + * Option 1: use cabal-install + + If you have cabal-install, *after* installing gtk2hs, you can + install figures and the remaining dependencies with + cabal-install: + + cabal install figures + + Optionally, you can also pass options such as --user + --prefix=$HOME to install locally. + + * Option 2: manual build + + Once all the dependencies are built and installed, you can build + and install figures as follows: + + runhaskell Setup.lhs configure --prefix=$HOME --user + runhaskell Setup.lhs build + runhaskell Setup.lhs install + + (Optionally, you can omit the --prefix and --user arguments to the + configure step, and run the install step with 'sudo' in order to + install the library systemwide.) + +3. Building Haddock documentation (recommended) + + runhaskell Setup.lhs haddock + + Once the documentation has been built, you can access it by + pointing your browser to dist/doc/html/figures/index.html. diff --git a/Setup.lhs b/Setup.lhs new file mode 100755 index 0000000..5bde0de --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/TODO b/TODO new file mode 100644 index 0000000..bf90254 --- /dev/null +++ b/TODO @@ -0,0 +1,12 @@ + * text labels for major ticks + * columns + * bars + * impulses + * steps + * legend + * annotations + +| * pad side opposite of axis label only if there is no label on that side + * using padding functions not raw data structure pdFoo, pdBar + + * simple interface \ No newline at end of file diff --git a/examples/perturbed-sine.hs b/examples/perturbed-sine.hs new file mode 100644 index 0000000..9dcac91 --- /dev/null +++ b/examples/perturbed-sine.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE OverlappingInstances #-} +-- thanks to http://www.muitovar.com/gtk2hs/app1.html + +--module Test where + +import Control.Concurrent +import Control.Concurrent.MVar + +import Control.Monad.Trans + +import Graphics.UI.Gtk hiding(Circle,Cross) +import qualified Graphics.Rendering.Cairo as C +import qualified Graphics.Rendering.Pango as P + +import Data.Colour.Names + +import Data.Packed.Vector +--import Data.Packed.Random +import Data.Packed() + +import qualified Data.Array.IArray as A + +import Numeric.LinearAlgebra.Linear +--import Numeric.LinearAlgebra.Instances +--import Numeric.LinearAlgebra.Interface + +import Numeric.GSL.Statistics + +import Graphics.Rendering.Plot + +import Debug.Trace + +ln = 25 +ts = linspace ln (0,1) +rs = ln |> take ln [0.306399512330476,-0.4243863460546792,-0.20454667402138094,-0.42873761654774106,1.3054721019673694,0.6474765138733175,1.1942346875362946,-1.7404737823144103,0.2607101951530985,-0.26782584645524893,-0.31403631431884504,3.365508546473985e-2,0.6147856889630383,-1.191723225061435,-1.9933460981205509,0.6015225906539229,0.6394073044477114,-0.6030919788928317,0.1832742199706381,0.35532918011648473,0.1982646055874545,1.7928383756822786,-9.992760294442601e-2,-1.401166614128362,-1.1088031929569364,-0.827319908453775,1.0406363628775428,-0.3070345979284644,0.6781735212645198,-0.8431706723519456,-0.4245730055085966,-0.6503687925251668,-1.4775567962221399,0.5587634921497298,-0.6481020127107823,7.313441602898768e-2,0.573580543636529,-0.9036472376122673,2.650805059813826,9.329324044673039e-2,1.9133487025468563,-1.5366337588254542,-1.0159359710920388,7.95982933517428e-2,0.5813673663649735,-6.93329631989878e-2,1.1024137719307867,-0.6046286796589855,-0.8812842030098401,1.4612246471009083,0.9584060744500491,9.210899579679932e-2,-0.15850413664405813,-0.4754694827227343,0.8669922262489788,0.4593351854708853,-0.2015350278936992,0.8829710664887649,0.7195048491420026] + +ss = sin (15*2*pi*ts) +ds = 0.25*rs + ss +es = constant (0.25*(stddev rs)) ln + +fs :: Double -> Double +fs = sin . (15*2*pi*) + +figure = do + withTextDefaults $ setFontFamily "OpenSymbol" + withTitle $ setText "Testing plot package:" + withSubTitle $ do + setText "with 1 second of a 15Hz sine wave" + setFontSize 10 + setPlots 1 1 + withPlot (1,1) $ do + setDataset (ts,[point (ds,es) (Cross,red),line fs blue]) + addAxis XAxis (Side Lower) $ withAxisLabel $ setText "time (s)" + addAxis YAxis (Side Lower) $ withAxisLabel $ setText "amplitude" + addAxis XAxis (Value 0) $ return () + setRangeFromData XAxis Lower + setRange YAxis Lower (-1.25) 1.25 + +display :: ((Int,Int) -> C.Render ()) -> IO () +display r = do + initGUI -- is start + + window <- windowNew + set window [ windowTitle := "Cairo test window" + , windowDefaultWidth := 400 + , windowDefaultHeight := 300 + , containerBorderWidth := 1 + ] + +-- canvas <- pixbufNew ColorspaceRgb True 8 300 200 +-- containerAdd window canvas + frame <- frameNew + containerAdd window frame + canvas <- drawingAreaNew + containerAdd frame canvas + widgetModifyBg canvas StateNormal (Color 65535 65535 65535) + + widgetShowAll window + + on canvas exposeEvent $ tryEvent $ do s <- liftIO $ widgetGetSize canvas + drw <- liftIO $ widgetGetDrawWindow canvas + --dat <- liftIO $ takeMVar d + --liftIO $ renderWithDrawable drw (circle 50 10) + liftIO $ renderWithDrawable drw (r s) + + onDestroy window mainQuit + mainGUI + + +main = display $ render figure + +test = writeFigure PNG "perturbed-sine.png" (400,400) figure \ No newline at end of file diff --git a/examples/perturbed-sine.png b/examples/perturbed-sine.png new file mode 100644 index 0000000..8bbc69b Binary files /dev/null and b/examples/perturbed-sine.png differ diff --git a/lib/Control/Monad/Supply.hs b/lib/Control/Monad/Supply.hs new file mode 100644 index 0000000..40b31ba --- /dev/null +++ b/lib/Control/Monad/Supply.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Supply +-- Copyright : (c) A. V. H. McPhail 2010 +-- License : BSD3 +-- +-- Maintainer : haskell.vivian.mcphail gmail com +-- Stability : provisional +-- Portability : portable +-- +-- a monad that supplies the next value +-- +----------------------------------------------------------------------------- + +module Control.Monad.Supply ( + Supply(..) + , MonadSupply(..) + , supplyN + , SupplyT(..), evalSupplyT, execSupplyT + , mapSupplyT + ) where + +----------------------------------------------------------------------------- + +import Control.Monad.Writer +import Control.Monad.Reader +import Control.Monad.State +import Control.Monad.Trans() + +----------------------------------------------------------------------------- + +class Supply a b where + nextSupply :: a -> (b,a) + +{- +instance Supply [a] a where nextSupply (x:xs) = (x,xs) +instance Supply ([a],[b]) a where nextSupply ((x:xs),ys) = (x,(xs,ys)) +instance Supply ([a],[b]) b where nextSupply (xs,(y:ys)) = (y,(xs,ys)) +-} +----------------------------------------------------------------------------- + +class Monad m => MonadSupply s m | m -> s where + supply :: Supply s a => m a + +supplyN :: (MonadSupply s m, Supply s a) => Int -> m [a] +supplyN n = replicateM n supply + +----------------------------------------------------------------------------- + +newtype SupplyT s m a = SupplyT { runSupplyT :: s -> m (a, s) } + +evalSupplyT :: Monad m => SupplyT s m a -> s -> m a +evalSupplyT st s = do + ~(a,_) <- runSupplyT st s + return a + +execSupplyT :: Monad m => SupplyT s m a -> s -> m s +execSupplyT st s = do + ~(_,s') <- runSupplyT st s + return s' + +mapSupplyT :: (m (a,s) -> n (b,s)) -> SupplyT s m a -> SupplyT s n b +mapSupplyT f st = SupplyT $ f . runSupplyT st + +----------------------------------------------------------------------------- + +instance Monad m => Functor (SupplyT s m) where + fmap f m = SupplyT $ \s -> do + ~(x, s') <- runSupplyT m s + return (f x,s') + +instance Monad m => Monad (SupplyT s m) where + return a = SupplyT $ \s -> return (a, s) + m >>= f = SupplyT $ \s -> do + ~(a,s') <- runSupplyT m s + runSupplyT (f a) s' + fail str = SupplyT $ \_ -> fail str + +instance MonadTrans (SupplyT s) where + lift m = SupplyT $ \s -> do + a <- m + return (a,s) + +instance Monad m => MonadSupply s (SupplyT s m) where + supply = SupplyT $ \s -> return $ nextSupply s + +----------------------------------------------------------------------------- +{- +instance (Monad (t m), MonadSupply s m, MonadTrans t) => MonadSupply s (t m) where + supply = lift supply +-} +----------------------------------------------------------------------------- + +instance MonadState s m => MonadState s (SupplyT s' m) where + get = lift get + put = lift . put + +instance MonadReader r m => MonadReader r (SupplyT s m) where + ask = lift ask + local f m = SupplyT $ \s -> local f (runSupplyT m s) + +instance MonadWriter w m => MonadWriter w (SupplyT s m) where + tell = lift . tell + listen m = SupplyT $ \s -> do + ~((a,s'),w) <- listen (runSupplyT m s) + return ((a,w),s') + pass m = SupplyT $ \s -> pass $ do + ~((a,f),s') <- runSupplyT m s + return ((a,s'),f) + +----------------------------------------------------------------------------- + diff --git a/lib/Graphics/Rendering/Plot.hs b/lib/Graphics/Rendering/Plot.hs new file mode 100644 index 0000000..54b2407 --- /dev/null +++ b/lib/Graphics/Rendering/Plot.hs @@ -0,0 +1,73 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Plot +-- Copyright : (c) A. V. H. McPhail 2010 +-- License : BSD3 +-- +-- Maintainer : haskell.vivian.mcphail gmail com +-- Stability : provisional +-- Portability : portable +-- +-- Graphical plots +-- +----------------------------------------------------------------------------- + +module Graphics.Rendering.Plot ( + -- * Example + -- $example + -- * re-exported for convenience + module Graphics.Rendering.Plot.Figure + , module Graphics.Rendering.Plot.Render + ) where + + +----------------------------------------------------------------------------- + +import Graphics.Rendering.Plot.Figure +import Graphics.Rendering.Plot.Render + +----------------------------------------------------------------------------- +{- $example + +Create some data: + +> ln = 25 +> ts = linspace ln (0,1) +> rs = randomVector 0 Gaussian ln +> +> ss = sin (15*2*pi*ts) +> ds = 0.25*rs + ss +> es = constant (0.25*(stddev rs)) ln +> +> fs :: Double -> Double +> fs = sin . (15*2*pi*) + +Perform actions in 'Figure a' to create a figure + +> test_graph = do +> withTextDefaults $ setFontFamily "OpenSymbol" +> withTitle $ setText "Testing plot package:" +> withSubTitle $ do +> setText "with 1 second of a 15Hz sine wave" +> setFontSize 10 +> setPlots 1 1 +> withPlot (1,1) $ do +> setDataset (ts,[point (ds,es) (Cross,red),line fs blue]) +> addAxis XAxis (Side Lower) $ withAxisLabel $ setText "time (s)" +> addAxis YAxis (Side Lower) $ withAxisLabel $ setText "amplitude" +> addAxis XAxis (Value 0) $ return () +> setRangeFromData XAxis Lower +> setRange YAxis Lower (-1.25) 1.25 + +Render the graph to a Cairo 'Render ()' action that takes the width +and height of the drawing area + +> test_render :: (Double,Double) -> Render () +> test_render = render test_graph + +The 'Render a' action can be used in GTK or with Cairo to write to file in PS, PDF, SVG, or PNG + +-} + + +----------------------------------------------------------------------------- diff --git a/lib/Graphics/Rendering/Plot/Defaults.hs b/lib/Graphics/Rendering/Plot/Defaults.hs new file mode 100644 index 0000000..b8e8087 --- /dev/null +++ b/lib/Graphics/Rendering/Plot/Defaults.hs @@ -0,0 +1,177 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Plot.Defaults +-- Copyright : (c) A. V. H. McPhail 2010 +-- License : BSD3 +-- +-- Maintainer : haskell.vivian.mcphail gmail com +-- Stability : provisional +-- Portability : portable +-- +-- Default values +-- +----------------------------------------------------------------------------- + +module Graphics.Rendering.Plot.Defaults where + +----------------------------------------------------------------------------- + +import Data.Colour.Names + +import qualified Data.Array.IArray as A + +import qualified Graphics.Rendering.Pango as P + +import Graphics.Rendering.Plot.Types + +----------------------------------------------------------------------------- + +defaultColourList :: [Color] +defaultColourList = [blue,red,green,yellow,violet,sienna,royalblue + ,pink,tomato,lavender,cyan,crimson,darkgreen + ,cadetblue,darkred,yellowgreen] + ++ defaultColourList + +----------------------------------------------------------------------------- + +defaultGlyphList :: [Glyph] +defaultGlyphList = [Box, Diamond, Asterisk, Triangle, Circle] + ++ defaultGlyphList + +----------------------------------------------------------------------------- + +defaultPointOptions :: PointOptions +defaultPointOptions = PointOptions 1 black + +defaultGlyph :: Glyph +defaultGlyph = Circle + +defaultPointType :: PointType +defaultPointType = FullPoint defaultPointOptions defaultGlyph + +----------------------------------------------------------------------------- + +defaultDashStyle :: DashStyle +defaultDashStyle = [] + +defaultLineWidth :: LineWidth +defaultLineWidth = 1 + +defaultLineOptions :: LineOptions +defaultLineOptions = LineOptions defaultDashStyle defaultLineWidth + +defaultLineType :: LineType +defaultLineType = ColourLine black + +----------------------------------------------------------------------------- + +defaultFontFamily :: FontFamily +defaultFontFamily = "Sans" + +defaultFontStyle :: P.FontStyle +defaultFontStyle = P.StyleNormal + +defaultFontVariant :: P.Variant +defaultFontVariant = P.VariantNormal + +defaultFontWeight :: P.Weight +defaultFontWeight = P.WeightNormal + +defaultFontStretch :: P.Stretch +defaultFontStretch = P.StretchNormal + +defaultFontOptions :: FontOptions +defaultFontOptions = FontOptions defaultFontFamily defaultFontStyle defaultFontVariant + defaultFontWeight defaultFontStretch + +defaultFontSize :: Double +defaultFontSize = 16 + +defaultFontColour :: Color +defaultFontColour = black + +defaultTextOptions :: TextOptions +defaultTextOptions = TextOptions defaultFontOptions defaultFontSize defaultFontColour + +----------------------------------------------------------------------------- + +defaultBounding :: BoundingBox +defaultBounding = BoundingBox 0 0 1 1 + +----------------------------------------------------------------------------- + +defaultRanges :: Double -> Double -> Double -> Double -> Ranges +defaultRanges xmin xmax ymin ymax = Ranges (Left (Range xmin xmax)) (Left (Range ymin ymax)) + +----------------------------------------------------------------------------- + +zeroPadding, defaultPadding, defaultFigurePadding, defaultPlotPadding :: Padding +zeroPadding = Padding 0 0 0 0 +defaultPadding = Padding 10 10 10 10 +defaultFigurePadding = Padding 10 10 10 10 +defaultPlotPadding = Padding 10 10 10 10 + +----------------------------------------------------------------------------- + +solid, empty :: Solid +solid = True +empty = False + +----------------------------------------------------------------------------- + +defaultOptions :: Options +defaultOptions = Options defaultLineOptions defaultPointOptions defaultTextOptions + +----------------------------------------------------------------------------- + +minorTickLength, majorTickLength, tickLabelScale :: Double +minorTickLength = 5.0 +majorTickLength = 7.0 +tickLabelScale = 0.75 + +defaultMinorTicks :: Ticks +defaultMinorTicks = Ticks False (Left 41) + +defaultMajorTicks :: Ticks +defaultMajorTicks = Ticks False (Left 5) + +defaultTickFormat :: TickFormat +defaultTickFormat = "%1f" + +defaultAxis :: AxisType -> AxisPosn -> AxisData +defaultAxis at axp = Axis at axp defaultLineType defaultMinorTicks defaultMajorTicks + defaultTickFormat NoText + +defaultXAxis, defaultYAxis :: AxisData +defaultXAxis = defaultAxis XAxis (Side Lower) +defaultYAxis = defaultAxis YAxis (Side Lower) + +----------------------------------------------------------------------------- + +defaultSupply :: SupplyData +defaultSupply = SupplyData defaultColourList defaultGlyphList + +----------------------------------------------------------------------------- + +emptyPlot :: PlotData +emptyPlot = Plot False defaultPlotPadding NoText (Ranges (Left (Range (-1) 1)) (Left (Range (-1) 1))) + [] Linear undefined Nothing [] + +----------------------------------------------------------------------------- + +emptyPlots :: Plots +emptyPlots = (A.listArray ((0,0),(0,0)) []) + +----------------------------------------------------------------------------- + +emptyFigure :: FigureData +emptyFigure = Figure defaultFigurePadding NoText NoText emptyPlots + +----------------------------------------------------------------------------- + +defaultFigureState :: FigureState +defaultFigureState = FigureState undefined + defaultSupply + undefined + +----------------------------------------------------------------------------- diff --git a/lib/Graphics/Rendering/Plot/Figure.hs b/lib/Graphics/Rendering/Plot/Figure.hs new file mode 100644 index 0000000..7b8226e --- /dev/null +++ b/lib/Graphics/Rendering/Plot/Figure.hs @@ -0,0 +1,231 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Plot.Figure +-- Copyright : (c) A. V. H. McPhail 2010 +-- License : BSD3 +-- +-- Maintainer : haskell.vivian.mcphail gmail com +-- Stability : provisional +-- Portability : portable +-- +-- Creation and manipulation of 'Figure's +-- +-- The same problem of leaked instances as at occurs here. +-- +-- +-- /with/, /set/, /clear/, /new/, and /add/ are the operations that can +-- be performed on various elements of a figure. +-- +-- /glib/\//data-accessor/ abstractions (verbs/modifiers) are planned for future implementations + +----------------------------------------------------------------------------- + +module Graphics.Rendering.Plot.Figure ( + Figure() + -- * Default options + , withTextDefaults + , withLineDefaults + , withPointDefaults + -- * Figures + -- ** Formatting + , setFigurePadding + , withTitle + , withSubTitle + , setPlots + , withPlot, withPlots + -- * Sub-plots + , Plot() + , PlotType(..) + -- ** Plot elements + , Border + , setBorder + , setPlotPadding + , withHeading + -- ** Series data + , Function(), Series(), ErrorSeries() + , Abscissa(), Ordinate(), Dataset() + , FormattedSeries(), SeriesType(..) + , line, point, linepoint + , setDataset + -- ** Plot type + , setSeriesType + , setAllSeriesTypes + -- ** Formatting + , PlotFormats() + , withSeriesFormat + , withAllSeriesFormats + -- * Range + , setRange + , setRangeFromData + -- * Axes + , Axis + , AxisType(..),AxisSide(..),AxisPosn(..) + , addAxis + -- ** Formatting + , Tick(..), TickValues, GridLines + , setTicks + , setTickLabelFormat + , withAxisLabel + , withAxisLine + -- * Lines + , Line(), LineFormat() + , DashStyle,Dash(..),LineWidth + , clearLineFormat + , setDashStyle + , setLineWidth + , setLineColour + -- * Points + , Point(), PointFormat() + , Glyph(..) + , PointSize + , setGlyph + , setPointSize + , setPointColour + -- * Text labels + , Text() + , FontFamily,FontSize,Color + -- | A text element must exist for formatting to work + , setText + , setFontFamily + , setFontStyle + , setFontVariant + , setFontWeight + , setFontStretch + , setFontSize + , setFontColour + ) where + +----------------------------------------------------------------------------- + +--import Data.Packed.Vector +--import Numeric.LinearAlgebra.Linear + +--import Data.Word +--import Data.Colour.SRGB +import Data.Colour.Names + +import qualified Data.Array.IArray as A + +--import qualified Graphics.Rendering.Cairo as C +--import qualified Graphics.Rendering.Pango as P + +--import Control.Monad.State +--import Control.Monad.Reader + +import Prelude hiding(min,max) + +import Graphics.Rendering.Plot.Figure.Text +import Graphics.Rendering.Plot.Figure.Line +import Graphics.Rendering.Plot.Figure.Point +import Graphics.Rendering.Plot.Figure.Plot + +import Graphics.Rendering.Plot.Types +import Graphics.Rendering.Plot.Defaults + +----------------------------------------------------------------------------- + +-- | perform some actions on the text defaults, must be run before other text element modifications +withTextDefaults :: Text () -> Figure () +withTextDefaults m = do + o <- getDefaults + let to' = _textoptions o + let (FontText to _) = execText m to' (FontText to' "") + modifyDefaults $ \s -> s { _textoptions = to } + +-- | perform some actions on the line defaults, must be run before other line element modifications +withLineDefaults :: Line () -> Figure () +withLineDefaults m = do + o <- getDefaults + let lo' = _lineoptions o + let (TypeLine lo _) = execLine m lo' (TypeLine lo' black) + modifyDefaults $ \s -> s { _lineoptions = lo } + +-- | perform some actions on the point defaults, must be run before other point modifications +withPointDefaults :: Point () -> Figure () +withPointDefaults m = do + o <- getDefaults + let po' = _pointoptions o + let (FullPoint po _) = execPoint m po' (FullPoint po' defaultGlyph) + modifyDefaults $ \s -> s { _pointoptions = po } + +----------------------------------------------------------------------------- + +-- | create a new blank 'Figure' +newFigure :: Figure () +newFigure = putFigure $ Figure defaultFigurePadding NoText NoText + (A.listArray ((1,1),(1,1)) [Nothing]) +{- +newLineFigure :: DataSeries -- ^ the y series + -> FigureData +newLineFigure d@(DS_1toN _ _) = let ((xmin,xmax),(ymin,ymax)) = calculateRanges d + plot = Plot False defaultPlotPadding NoText + (defaultRanges xmin xmax ymin ymax) + [defaultXAxis,defaultYAxis] + Nothing Line d [] + in Figure defaultFigurePadding NoText NoText + (A.listArray ((1,1),(1,1)) [Just plot]) +-} +{- +-- | create a new 'Figure' +newFigure :: PlotType -> DataSeries -> Figure () +newFigure Line d@(DS_1toN _ _) = putFigure $ newLineFigure d +--newFigure _ _ = error "Figure type not implemented" +-} + + +----------------------------------------------------------------------------- + +-- | set the padding of the figure +setFigurePadding :: Double -> Double -> Double -> Double -> Figure () +setFigurePadding l r b t = modifyFigure $ \s -> s { _fig_pads = Padding l r b t } + +-- | operate on the title +withTitle :: Text () -> Figure () +withTitle m = do + o <- getDefaults + modifyFigure $ \s -> s { _title = execText m (_textoptions o) (_title s) } + +-- | operate on the sub-title +withSubTitle :: Text () -> Figure () +withSubTitle m = do + o <- getDefaults + modifyFigure $ \s -> s { _subtitle = execText m (_textoptions o) (_title s) } + +-- | set the shape of the plots, losing all current plots +setPlots :: Int -- ^ rows + -> Int -- ^ columns + -> Figure () +setPlots r c = modifyFigure $ \s -> s { _plots = A.listArray ((1,1),(r,c)) (replicate (r*c) Nothing) } + +-- | perform some actions on the specified subplot +withPlot :: (Int,Int) -> Plot () -> Figure () +withPlot i m = do + o <- getDefaults + s <- getSupplies + modifyFigure $ \p -> p { _plots = let plots = _plots p + plot' = plots A.! i + plot = case plot' of + Nothing -> emptyPlot + Just p' -> p' + -- we revert supplies to the original here + -- since we might want the same colour + -- order for all plots + -- HOWEVER: need a better execPlot group + in plots A.// [(i,Just $ execPlot m s o plot)] } + +-- | perform some actions all subplots +withPlots :: Plot () -> Figure () +withPlots m = do + o <- getDefaults + s <- getSupplies + modifyFigure $ \p -> p { _plots = let plots = _plots p + plot p' = case p' of + Nothing -> emptyPlot + Just p'' -> p'' + in plots A.// map (\(i,e) -> (i,Just $ execPlot m s o (plot e))) (A.assocs plots) } + +----------------------------------------------------------------------------- + diff --git a/lib/Graphics/Rendering/Plot/Figure/Line.hs b/lib/Graphics/Rendering/Plot/Figure/Line.hs new file mode 100644 index 0000000..f36f250 --- /dev/null +++ b/lib/Graphics/Rendering/Plot/Figure/Line.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Plot.Figure.Line +-- Copyright : (c) A. V. H. McPhail 2010 +-- License : BSD3 +-- +-- Maintainer : haskell.vivian.mcphail gmail com +-- Stability : provisional +-- Portability : portable +-- +-- 'Text' operations +-- +----------------------------------------------------------------------------- + +module Graphics.Rendering.Plot.Figure.Line ( + Line, LineFormat(..) + , DashStyle,Dash(..),LineWidth + , clearLineFormat + , setDashStyle + , setLineWidth + , setLineColour + , getLineColour + ) where + +----------------------------------------------------------------------------- + +--import Data.Word +import Data.Colour +--import Data.Colour.Names + +--import qualified Graphics.Rendering.Cairo as C +--import qualified Graphics.Rendering.Pango as P + +import Control.Monad.State +import Control.Monad.Reader +import Control.Monad.Supply + +import Graphics.Rendering.Plot.Types + +----------------------------------------------------------------------------- + +changeDashStyle :: DashStyle -> LineOptions -> LineOptions +changeDashStyle ds (LineOptions _ lw) = LineOptions ds lw + +changeLineWidth :: LineWidth -> LineOptions -> LineOptions +changeLineWidth lw (LineOptions ds _) = LineOptions ds lw + +{-changeLineOptions :: (LineOptions -> LineOptions) -> LineType -> LineType +changeLineOptions f (LineType ls c) = LineType (f ls) c + +changeDashStyle :: DashStyle -> LineType -> LineType +changeDashStyle ds = changeLineOptions (changeDashStyleStyle ds) + +changeLineWidth :: LineWidth -> LineType -> LineType +changeLineWidth lw = changeLineOptions (changeLineWidthStyle lw) +-} +changeLineColour :: Color -> LineType -> LineType +changeLineColour c NoLine = ColourLine c +changeLineColour c (ColourLine _) = ColourLine c +changeLineColour c (TypeLine lo _) = TypeLine lo c + +clearLineFormatting :: LineType -> LineType +clearLineFormatting NoLine = NoLine +clearLineFormatting l@(ColourLine _) = l +clearLineFormatting (TypeLine _ c) = ColourLine c + +clearLine :: LineType -> LineType +clearLine _ = NoLine + +getLineColour :: LineType -> Maybe Color +getLineColour NoLine = Nothing +getLineColour (ColourLine c) = Just c +getLineColour (TypeLine _ c) = Just c + +----------------------------------------------------------------------------- + +-- | clear the formatting of a line +clearLineFormat :: Line () +clearLineFormat = do + lt <- get + case lt of + NoLine -> put NoLine + c@(ColourLine _) -> put c + (TypeLine _ c) -> put $ ColourLine c + +changeLineOptions :: (LineOptions -> LineOptions) -> LineType -> Line () +changeLineOptions o NoLine = do + lo <- ask + put $ TypeLine (o lo) black +changeLineOptions o (ColourLine c) = do + lo <- ask + put $ TypeLine (o lo) c +changeLineOptions o (TypeLine lo c) = put $ TypeLine (o lo) c + +-- | change the dash style of a line +setDashStyle :: DashStyle -> Line () +setDashStyle ds = get >>= changeLineOptions (changeDashStyle ds) + +-- | change the line width of a line +setLineWidth :: LineWidth -> Line () +setLineWidth lw = get >>= changeLineOptions (changeLineWidth lw) + +-- | change the line colour of a line +setLineColour :: Color -> Line () +setLineColour c = modify (changeLineColour c) + +----------------------------------------------------------------------------- + +class LineFormat a where + toLine :: (MonadReader Options m, MonadSupply SupplyData m) => a -> m LineType + +instance Real a => LineFormat (Colour a) where toLine c = return $ ColourLine $ colourConvert c +instance LineFormat DashStyle where toLine ds = do + lo <- asks _lineoptions + c <- supply + return $ TypeLine (changeDashStyle ds lo) c +instance LineFormat LineWidth where toLine lw = do + lo <- asks _lineoptions + c <- supply + return $ TypeLine (changeLineWidth lw lo) c +instance Real a => LineFormat (DashStyle,Colour a) where toLine (ds,c) = do + lo <- asks _lineoptions + return $ TypeLine (changeDashStyle ds lo) $ colourConvert c +instance Real a => LineFormat (LineWidth,Colour a) where toLine (lw,c) = do + lo <- asks _lineoptions + return $ TypeLine (changeLineWidth lw lo) $ colourConvert c +instance LineFormat (DashStyle,LineWidth) where toLine (ds,lw) = do + c <- supply + return $ TypeLine (LineOptions ds lw) c +instance Real a => LineFormat (DashStyle,LineWidth,Colour a) where toLine (ds,lw,c) = return $ TypeLine (LineOptions ds lw) $ colourConvert c + +----------------------------------------------------------------------------- + diff --git a/lib/Graphics/Rendering/Plot/Figure/Plot.hs b/lib/Graphics/Rendering/Plot/Figure/Plot.hs new file mode 100644 index 0000000..70861b4 --- /dev/null +++ b/lib/Graphics/Rendering/Plot/Figure/Plot.hs @@ -0,0 +1,215 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Plot.Figure.Plot +-- Copyright : (c) A. V. H. McPhail 2010 +-- License : BSD3 +-- +-- Maintainer : haskell.vivian.mcphail gmail com +-- Stability : provisional +-- Portability : portable +-- +-- Creation and manipulation of 'Plot's +-- +----------------------------------------------------------------------------- + +module Graphics.Rendering.Plot.Figure.Plot ( + Plot + , PlotType(..) + -- * Plot elements + , Border + , setBorder + , setPlotPadding + , withHeading + -- * Series data + , D.Abscissa(), D.Ordinate(), D.Dataset() + , D.FormattedSeries() + , D.line, D.point, D.linepoint + , setDataset + -- ** Plot type + , setSeriesType + , setAllSeriesTypes + -- ** Formatting + , D.PlotFormats(..) + , withSeriesFormat + , withAllSeriesFormats + -- * Range + , setRange + , setRangeFromData + -- * Axes + , AX.Axis + , AxisType(..),AxisSide(..),AxisPosn(..) + , clearAxes + , addAxis +-- , withAxis + -- ** Formatting + , Tick(..), TickValues, GridLines + , AX.setTicks + , AX.setTickLabelFormat + , AX.withAxisLabel + , AX.withAxisLine + ) where + +----------------------------------------------------------------------------- + +import Data.Packed.Vector +import Numeric.LinearAlgebra.Linear + +import qualified Data.Array.IArray as A + +import Control.Monad.State +import Control.Monad.Reader +--import Control.Monad.Supply + +import Prelude hiding(min,max) + +import Graphics.Rendering.Plot.Types +import Graphics.Rendering.Plot.Defaults +import qualified Graphics.Rendering.Plot.Figure.Plot.Data as D +import qualified Graphics.Rendering.Plot.Figure.Plot.Axis as AX + +----------------------------------------------------------------------------- + +-- | whether to draw a boundary around the plot area +setBorder :: Border -> Plot () +setBorder b = modify $ \s -> s { _border = b } + +-- | set the padding of the subplot +setPlotPadding :: Double -> Double -> Double -> Double -> Plot () +setPlotPadding l r b t = modify $ \s -> s { _plot_pads = Padding l r b t } + +-- | set the heading of the subplot +withHeading :: Text () -> Plot () +withHeading m = do + o <- asks _textoptions + modify $ \s -> s { _heading = execText m o (_heading s) } + +----------------------------------------------------------------------------- + +-- | set the axis range +setRange :: AxisType -> AxisSide -> Double -> Double -> Plot () +setRange XAxis sd min max = modify $ \s -> s { _ranges = setXRanges sd min max (_ranges s) } + where setXRanges Lower min' max' (Ranges (Left _) yr) = Ranges (Left (Range min' max')) yr + setXRanges Lower min' max' (Ranges (Right (_,xr)) yr) = Ranges (Right ((Range min' max',xr))) yr + setXRanges Upper min' max' (Ranges (Left xr) yr) = Ranges (Right (xr,Range min' max')) yr + setXRanges Upper min' max' (Ranges (Right (_,xr)) yr) = Ranges (Right (Range min' max',xr)) yr +setRange YAxis sd min max = modify $ \s -> s { _ranges = setYRanges sd min max (_ranges s) } + where setYRanges Lower min' max' (Ranges xr (Left _)) = Ranges xr (Left (Range min' max')) + setYRanges Lower min' max' (Ranges xr (Right (_,yr))) = Ranges xr (Right ((Range min' max',yr))) + setYRanges Upper min' max' (Ranges xr (Left yr)) = Ranges xr (Right (yr,Range min' max')) + setYRanges Upper min' max' (Ranges xr (Right (_,yr))) = Ranges xr (Right ((Range min' max',yr))) + +-- | set the axis ranges to values based on dataset +setRangeFromData :: AxisType -> AxisSide -> Plot () +setRangeFromData ax sd = do + ds <- gets _data + let ((xmin,xmax),(ymin,ymax)) = calculateRanges ds + case ax of + XAxis -> setRange ax sd xmin xmax + YAxis -> setRange ax sd ymin ymax + +----------------------------------------------------------------------------- + +-- | clear the axes of a subplot +clearAxes :: Plot () +clearAxes = modify $ \s -> s { _axes = [] } + +-- | add an axis to the subplot +addAxis :: AxisType -> AxisPosn -> AX.Axis () -> Plot () +addAxis at axp m = do + ax' <- gets _axes + o <- ask + let ax = execAxis m o (defaultAxis at axp) + modify $ \s -> s { _axes = ax : ax' } + +-- | operate on the given axis +withAxis :: AxisType -> AxisPosn -> AX.Axis () -> Plot () +withAxis at axp m = do + axes' <- gets _axes + o <- ask + modify $ \s -> s { _axes = map (\a@(Axis at' ap' _ _ _ _ _) + -> if at == at' && axp == ap' then execAxis m o a else a) axes' } + +----------------------------------------------------------------------------- + +-- | set the type of the subplot +setPlotType :: PlotType -> Plot () +setPlotType pt = modify $ \s -> s { _type = pt } + +----------------------------------------------------------------------------- + +-- | operate on the data +withData :: D.Data () -> Plot () +withData = dataInPlot + +-- | set the data series of the subplot +setDataset :: D.Dataset a => a -> Plot () +setDataset d = withData $ D.setDataSeries d + +-- | set the plot type of a given data series +setSeriesType :: Int -> SeriesType -> Plot () +setSeriesType i t = withData $ D.setSeriesType t i + +-- | change the plot type of all data series +setAllSeriesTypes :: SeriesType -> Plot () +setAllSeriesTypes t = withData $ D.setAllSeriesTypes t + +-- | format the plot elements of a given series +withSeriesFormat :: D.PlotFormats m => Int -> m () -> Plot () +withSeriesFormat i f = withData $ D.withSeriesFormat i f + +{- | + format the plot elements of all series + + the operation to modify the formats is passed the series index. + This allows, for example, colours to be selected from a list + that gets indexed by the argument + +> setColour i = withAllSeriesFormats (\i -> do +> setLineColour $ [black,blue,red,green,yellow] !! i +> setLineWidth 1.0 +-} +withAllSeriesFormats :: D.PlotFormats m => (Int -> m ()) -> Plot () +withAllSeriesFormats f = withData $ D.withAllSeriesFormats f + +----------------------------------------------------------------------------- + + +----------------------------------------------------------------------------- + +findMinMax :: Abscissae -> Ordinates -> (Double,Double) +findMinMax AbsFunction (OrdFunction f) = let v = mapVector f (linspace 100 (-1,1)) + in (vectorMin v,vectorMax v) +findMinMax (AbsPoints x) (OrdFunction f) = let v = mapVector f x + in (vectorMin v,vectorMax v) + -- what if errors go beyond plot? +findMinMax _ (OrdPoints y) = let o = getOrdData y + in (vectorMin o,vectorMax o) + +abscMinMax :: Abscissae -> (Double,Double) +abscMinMax AbsFunction = (-1,1) +abscMinMax (AbsPoints x) = (vectorMin x,vectorMax x) + + +ordDim :: Ordinates -> Int +ordDim (OrdFunction _) = 1 +ordDim (OrdPoints o) = dim $ getOrdData o + + +calculateRanges :: DataSeries -> ((Double,Double),(Double,Double)) +calculateRanges (DS_Y ys) = let xmax = maximum $ map (\(DecSeries o _) -> fromIntegral $ ordDim o) $ A.elems ys + ym = unzip $ map (\(DecSeries o _) -> findMinMax AbsFunction o) $ A.elems ys + ymm = (minimum $ fst ym,maximum $ snd ym) + in ((0,xmax),ymm) +calculateRanges (DS_1toN x ys) = let ym = unzip $ map (\(DecSeries o _) -> findMinMax x o) $ A.elems ys + ymm = (minimum $ fst ym,maximum $ snd ym) + xmm = abscMinMax x + in (xmm,ymm) +calculateRanges (DS_1to1 ys) = let (xm',ym') = unzip $ A.elems ys + ym = unzip $ map (\(x,(DecSeries o _)) -> findMinMax x o) (zip xm' ym') + ymm = (minimum $ fst ym,maximum $ snd ym) + xm = unzip $ map abscMinMax xm' + xmm = (minimum $ fst xm,maximum $ snd ym) + in (xmm,ymm) + +----------------------------------------------------------------------------- + diff --git a/lib/Graphics/Rendering/Plot/Figure/Plot/Axis.hs b/lib/Graphics/Rendering/Plot/Figure/Plot/Axis.hs new file mode 100644 index 0000000..1375bf1 --- /dev/null +++ b/lib/Graphics/Rendering/Plot/Figure/Plot/Axis.hs @@ -0,0 +1,76 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Plot.Figure.Plot.Axis +-- Copyright : (c) A. V. H. McPhail 2010 +-- License : BSD3 +-- +-- Maintainer : haskell.vivian.mcphail gmail com +-- Stability : provisional +-- Portability : portable +-- +-- Axis +-- +----------------------------------------------------------------------------- + +module Graphics.Rendering.Plot.Figure.Plot.Axis ( + Axis + , AxisType(..),AxisSide(..),AxisPosn(..) + , Tick(..), TickValues, GridLines + , setTicks + , setTickLabelFormat + , withAxisLabel + , withAxisLine + ) where + +----------------------------------------------------------------------------- + +import Control.Monad.State +import Control.Monad.Reader + +import Graphics.Rendering.Plot.Types + +----------------------------------------------------------------------------- + +changeLineType :: LineType -> AxisData -> AxisData +changeLineType lt ax = ax { _line_type = lt } + +changeMinorTicks :: Ticks -> AxisData -> AxisData +changeMinorTicks t ax = ax { _minor_ticks = t } + +changeMajorTicks :: Ticks -> AxisData -> AxisData +changeMajorTicks t ax = ax { _major_ticks = t } + +changeTickFormat :: TickFormat -> AxisData -> AxisData +changeTickFormat tf ax = ax { _tick_format = tf } + +changeLabel :: (TextEntry -> TextEntry) -> AxisData -> AxisData +changeLabel f ax = ax { _label = f (_label ax) } + +----------------------------------------------------------------------------- + +-- | format the axis line +withAxisLine :: Line () -> Axis () +withAxisLine m = do + l <- gets _line_type + lo <- asks _lineoptions + let lt = execLine m lo l + modify $ \s -> s { _line_type = lt } + +-- | format the axis ticks +setTicks :: Tick -> GridLines -> TickValues -> Axis () +setTicks Minor g ts = modify $ \s -> changeMinorTicks (Ticks g ts) s +setTicks Major g ts = modify $ \s -> changeMajorTicks (Ticks g ts) s + +-- | printf format that takes one argument, the tick value +setTickLabelFormat :: String -> Axis () +setTickLabelFormat tf = modify $ \s -> changeTickFormat tf s + +-- | operate on the axis label +withAxisLabel :: Text () -> Axis () +withAxisLabel m = do + ax <- get + to <- asks _textoptions + put $ ax { _label = execText m to (_label ax) } + +----------------------------------------------------------------------------- + diff --git a/lib/Graphics/Rendering/Plot/Figure/Plot/Data.hs b/lib/Graphics/Rendering/Plot/Figure/Plot/Data.hs new file mode 100644 index 0000000..4689b2e --- /dev/null +++ b/lib/Graphics/Rendering/Plot/Figure/Plot/Data.hs @@ -0,0 +1,397 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Plot.Figure.Plot.Data +-- Copyright : (c) A. V. H. McPhail 2010 +-- License : BSD3 +-- +-- Maintainer : haskell.vivian.mcphail gmail com +-- Stability : provisional +-- Portability : portable +-- +-- 'Data' operations +-- +----------------------------------------------------------------------------- + +module Graphics.Rendering.Plot.Figure.Plot.Data ( + Data + -- * Series data + , FormattedSeries() + , line, point, linepoint + , setDataSeries + -- * Plot type + , setSeriesType + , setAllSeriesTypes + -- * Formatting + , PlotType(..), PlotFormats(..) + , withSeriesFormat + , withAllSeriesFormats + -- * Internal + , Abscissa(), Ordinate(), Dataset() + ) where + +----------------------------------------------------------------------------- + +--import Data.Packed.Vector + +import Data.Maybe + +import qualified Data.Array.IArray as A + +import Control.Monad.State +import Control.Monad.Reader +import Control.Monad.Supply + +import Graphics.Rendering.Plot.Types +import Graphics.Rendering.Plot.Figure.Line +import Graphics.Rendering.Plot.Figure.Point + +----------------------------------------------------------------------------- + +dataSeriesNum :: DataSeries -> Int +dataSeriesNum (DS_Y a) = A.rangeSize $ A.bounds $ a +dataSeriesNum (DS_1toN _ a) = A.rangeSize $ A.bounds $ a +dataSeriesNum (DS_1to1 a) = A.rangeSize $ A.bounds $ a + +----------------------------------------------------------------------------- + +class SeriesTypes a where + setSeriesType'' :: SeriesType -> a -> Data a + +instance SeriesTypes Decoration where + setSeriesType'' Line d@(DecLine _) = return d + setSeriesType'' Line (DecPoint pt) = do + let c = getPointColour pt + lt <- toLine c + return $ DecLine lt + setSeriesType'' Line (DecLinPt lt _) = return $ DecLine lt + setSeriesType'' Point (DecLine lt) = do + let c = fromJust $ getLineColour lt + g <- supply + pt <- toPoint (g :: Glyph,c) + return $ DecPoint pt + setSeriesType'' Point d@(DecPoint _) = return d + setSeriesType'' Point (DecLinPt _ pt) = return $ DecPoint pt + setSeriesType'' LinePoint (DecLine lt) = do + let c = fromJust $ getLineColour lt + g <- supply + pt <- toPoint (g :: Glyph,c) + return $ DecLinPt lt pt + setSeriesType'' LinePoint (DecPoint pt) = do + let c = getPointColour pt + lt <- toLine (c :: Color) + return $ DecLinPt lt pt + setSeriesType'' LinePoint d@(DecLinPt _ _) = return d + +instance SeriesTypes DecoratedSeries where + setSeriesType'' t (DecSeries o d) = do + d' <- setSeriesType'' t d + return $ DecSeries o d' + +setSeriesType' :: Int -> SeriesType -> DataSeries -> Data DataSeries +setSeriesType' i t (DS_Y a) = do + s' <- setSeriesType'' t $ a A.! i + return $ DS_Y $ a A.// [(i,s')] +setSeriesType' i t (DS_1toN x a) = do + s' <- setSeriesType'' t $ a A.! i + return $ DS_1toN x $ a A.// [(i,s')] +setSeriesType' i t (DS_1to1 a) = do + let (x,s) = a A.! i + s' <- setSeriesType'' t s + return $ DS_1to1 $ a A.// [(i,(x,s'))] + +-- | set the series type of a given data series +setSeriesType :: SeriesType -> Int -> Data () +setSeriesType t i = do + ds <- get + ds' <- setSeriesType' i t ds + put ds' + +-- | set the series type of all data series +setAllSeriesTypes :: SeriesType -> Data () +setAllSeriesTypes t = do + ds <- get + let ln = dataSeriesNum ds + mapM_ (setSeriesType t) [1..ln] + +----------------------------------------------------------------------------- + +class PlotFormats m where + modifyFormat :: m () -> DecoratedSeries -> Data DecoratedSeries + +instance PlotFormats Line where + modifyFormat l (DecSeries o (DecLine lt)) = do + lo <- asks _lineoptions + let lt' = execLine l lo lt + return $ DecSeries o (DecLine lt') + modifyFormat _ d@(DecSeries _ (DecPoint _)) = return d + modifyFormat l (DecSeries o (DecLinPt lt pt)) = do + lo <- asks _lineoptions + let lt' = execLine l lo lt + return $ DecSeries o (DecLinPt lt' pt) + +instance PlotFormats Point where + modifyFormat _ d@(DecSeries _ (DecLine _)) = return d + modifyFormat p (DecSeries o (DecPoint pt)) = do + po <- asks _pointoptions + let pt' = execPoint p po pt + return $ DecSeries o (DecPoint pt') + modifyFormat p (DecSeries o (DecLinPt lt pt)) = do + po <- asks _pointoptions + let pt' = execPoint p po pt + return $ DecSeries o (DecLinPt lt pt') + +-- | format the plot elements of a given series +withSeriesFormat :: PlotFormats m => Int -> m () -> Data () +withSeriesFormat i f = do + ds <- get + ds' <- case ds of + (DS_Y a) -> do + let d = a A.! i + d' <- modifyFormat f d + return $ DS_Y $ a A.// [(i,d')] + (DS_1toN x a) -> do + let d = a A.! i + d' <- modifyFormat f d + return $ DS_1toN x $ a A.// [(i,d')] + (DS_1to1 a) -> do + let (x,d) = a A.! i + d' <- modifyFormat f d + return $ DS_1to1 $ a A.// [(i,(x,d'))] + put ds' + +-- | format the plot elements of all series +-- | the operation to modify the formats is passed the series index +-- | this allows, for example, colours to be selected from a list +-- | that gets indexed by the argument +-- | @setColour i = setLineColour $ [black,blue,red,green,yellow] !! i@ +withAllSeriesFormats :: PlotFormats m => (Int -> m ()) -> Data () +withAllSeriesFormats f = do + ds <- get + let ln = dataSeriesNum ds + mapM_ (\i -> withSeriesFormat i (f i)) [1..ln] + +----------------------------------------------------------------------------- + +class Abscissa a where + toAbscissa :: a -> Abscissae + +toAbscissae :: Abscissa a => [a] -> [Abscissae] +toAbscissae = map toAbscissa + +instance Abscissa Series where toAbscissa s = AbsPoints s + +class Ordinate a where + toOrdinate :: a -> Ordinates + +toOrdinates :: Ordinate a => [a] -> [Ordinates] +toOrdinates = map toOrdinate + +instance Ordinate Function where toOrdinate f = OrdFunction f +instance Ordinate Series where toOrdinate s = OrdPoints (Plain s) +instance Ordinate (Series,ErrorSeries) where toOrdinate (s,e) = OrdPoints (Error s (e,e)) +instance Ordinate (Series,(ErrorSeries,ErrorSeries)) where toOrdinate (s,(l,u)) = OrdPoints (Error s (l,u)) + +class Decorations a where + toDecoration :: a -> Decoration + +toDecorations :: Decorations a => [a] -> [Decoration] +toDecorations = map toDecoration + +instance Decorations LineType where toDecoration l = DecLine l +instance Decorations PointType where toDecoration p = DecPoint p +instance Decorations (LineType,PointType) where toDecoration (l,p) = DecLinPt l p +instance Decorations (PointType,LineType) where toDecoration (p,l) = DecLinPt l p +instance Decorations Decoration where toDecoration = id + +format :: (Ordinate a, Decorations b) => a -> b -> DecoratedSeries +format o f = DecSeries (toOrdinate o) (toDecoration f) + +line :: (Ordinate a, LineFormat b) => a -> b -> FormattedSeries +line o f = do + f' <- toLine f + return $ format o f' + +point :: (Ordinate a, PointFormat b) => a -> b -> FormattedSeries +point o f = do + f' <- toPoint f + return $ format o f' + +linepoint :: (Ordinate a, LineFormat b, PointFormat c) => a -> b -> c -> FormattedSeries +linepoint o l p = do + l' <- toLine l + p' <- toPoint p + return $ format o (l',p') + +----------------------------------------------------------------------------- + +getType :: SeriesType -> Data Decoration +getType Line = do + c <- supply + lt <- toLine (c :: Color) + return $ toDecoration lt +getType Point = do + g <- supply + pt <- toPoint (g :: Glyph) + return $ toDecoration pt +getType LinePoint = do + c <- supply + g <- supply + lt <- toLine (c :: Color) + pt <- toPoint (g :: Glyph) + return $ toDecoration (lt,pt) + +getNTypes :: Int -> SeriesType -> Data [Decoration] +getNTypes n st = mapM getType (replicate n st) + +----------------------------------------------------------------------------- + +class Dataset a where + toDataSeries :: a -> Data DataSeries + +instance (Ordinate a) => Dataset (SeriesType,[a]) where + toDataSeries (Line,os) = do + let ln = length os + cs <- supplyN ln + ls <- mapM toLine (cs :: [Color]) + return $ DS_Y $ A.listArray (1,ln) $ zipWith format os ls + toDataSeries (Point,os) = do + let ln = length os + cs <- supplyN ln + gs <- supplyN ln + ps <- mapM toPoint (zip (gs :: [Glyph]) (cs :: [Color])) + return $ DS_Y $ A.listArray (1,ln) $ zipWith format os ps + toDataSeries (LinePoint,os) = do + let ln = length os + cs <- supplyN ln + gs <- supplyN ln + ls <- mapM toLine cs + ps <- mapM toPoint (zip (gs :: [Glyph]) (cs :: [Color])) + let ds = toDecorations (zip ls ps) + return $ DS_Y $ A.listArray (1,ln) $ zipWith format os ds + +instance (Abscissa a, Ordinate b) => Dataset (SeriesType,a,[b]) where + toDataSeries (Line,t,os) = do + let ln = length os + cs <- supplyN ln + ls <- mapM toLine (cs :: [Color]) + return $ DS_1toN (toAbscissa t) $ A.listArray (1,ln) + $ zipWith format os ls + toDataSeries (Point,t,os) = do + let ln = length os + cs <- supplyN ln + gs <- supplyN ln + ps <- mapM toPoint (zip (gs :: [Glyph]) (cs :: [Color])) + return $ DS_1toN (toAbscissa t) $ A.listArray (1,ln) + $ zipWith format os ps + toDataSeries (LinePoint,t,os) = do + let ln = length os + cs <- supplyN ln + gs <- supplyN ln + ls <- mapM toLine cs + ps <- mapM toPoint (zip (gs :: [Glyph]) (cs :: [Color])) + let ds = toDecorations (zip ls ps) + return $ DS_1toN (toAbscissa t) $ A.listArray (1,ln) + $ zipWith format os ds + +instance (Abscissa a, Ordinate b) => Dataset (SeriesType,[(a,b)]) where + toDataSeries (Line,prs) = do + let ln = length prs + cs <- supplyN ln + ls <- mapM toLine (cs :: [Color]) + let (xs,ys') = unzip prs + ys = zipWith format ys' ls + return $ DS_1to1 $ A.listArray (1,ln) $ zip (toAbscissae xs) ys + toDataSeries (Point,prs) = do + let ln = length prs + cs <- supplyN ln + gs <- supplyN ln + ps <- mapM toPoint (zip (gs :: [Glyph]) (cs :: [Color])) + let (xs,ys') = unzip prs + ys = zipWith format ys' ps + return $ DS_1to1 $ A.listArray (1,ln) $ zip (toAbscissae xs) ys + toDataSeries (LinePoint,prs) = do + let ln = length prs + cs <- supplyN ln + gs <- supplyN ln + ps <- mapM toPoint (zip (gs :: [Glyph]) (cs :: [Color])) + ls <- mapM toLine (cs :: [Color]) + let ds = toDecorations (zip ls ps) + let (xs,ys') = unzip prs + ys = zipWith format ys' ds + return $ DS_1to1 $ A.listArray (1,ln) $ zip (toAbscissae xs) ys + +instance Dataset [FormattedSeries] where + toDataSeries ds = do + let ln = length ds + ds' <- sequence ds + return $ DS_Y $ A.listArray (1,ln) ds' + +instance (Abscissa a) => Dataset (a,[FormattedSeries]) where + toDataSeries (t,prs) = do + let ln = length prs + prs' <- sequence prs + return $ DS_1toN (toAbscissa t) $ A.listArray (1,ln) prs' + +instance (Abscissa a) => Dataset [(a,FormattedSeries)] where + toDataSeries prs = do + let ln = length prs + (xs,ys) = unzip prs + ys' <- sequence ys + return $ DS_1to1 $ A.listArray (1,ln) (zip (toAbscissae xs) ys') + +{- +instance (Ordinate a, LineFormat b) => Dataset [(a,LineFormat,b)] where + toDataSeries os = do + let ln = length os + (ys,_,ds) = unzip3 os + ds' <- mapM toLine ds + return $ DS_Y $ A.listArray (1,ln) $ zipWith format (toOrdinates ys) (toDecorations ds') + +instance (Ordinate a, PointFormat b) => Dataset [(a,PointFormat,b)] where + toDataSeries os = do + let ln = length os + (ys,_,ds) = unzip3 os + ds' <- mapM toPoint ds + return $ DS_Y $ A.listArray (1,ln) $ zipWith format (toOrdinates ys) (toDecorations ds') + +instance (Abscissa a, Ordinate b, Decorations c) => Dataset (a,[(b,c)]) where + toDataSeries Line (t,os) = do + let ln = length os + (ys,ds) = unzip os + ds' <- mapM toLine ds + return $ DS_1toN (toAbscissa t) $ A.listArray (1,ln) + $ zipWith format (toOrdinates ys) (toDecorations ds') + toDataSeries Point (t,os) = do + let ln = length os + (ys,ds) = unzip os + ds' <- mapM toPoint ds + return $ DS_1toN (toAbscissa t) $ A.listArray (1,ln) + $ zipWith format (toOrdinates ys) (toDecorations ds') + +instance (Abscissa a, Ordinate b, Decorations c) => Dataset [(a,b,c)] where + toDataSeries Line prs = do + let ln = length prs + (ts,ys,ds) = unzip3 prs + ds' <- mapM toLine ds + let ys' = zipWith format (toOrdinates ys) (toDecorations ds') + return $ DS_1to1 $ A.listArray (1,ln) $ zip (toAbscissae ts) ys' + toDataSeries Point prs = do + let ln = length prs + (ts,ys,ds) = unzip3 prs + ds' <- mapM toPoint ds + let ys' = zipWith format (toOrdinates ys) (toDecorations ds') + return $ DS_1to1 $ A.listArray (1,ln) $ zip (toAbscissae ts) ys' +-} + +-- | set the data set +setDataSeries :: Dataset a => a -> Data () +setDataSeries d = do + ds <- toDataSeries d + put ds + +----------------------------------------------------------------------------- + diff --git a/lib/Graphics/Rendering/Plot/Figure/Point.hs b/lib/Graphics/Rendering/Plot/Figure/Point.hs new file mode 100644 index 0000000..8ca894e --- /dev/null +++ b/lib/Graphics/Rendering/Plot/Figure/Point.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Plot.Figure.Point +-- Copyright : (c) A. V. H. McPhail 2010 +-- License : BSD3 +-- +-- Maintainer : haskell.vivian.mcphail gmail com +-- Stability : provisional +-- Portability : portable +-- +-- 'Point' operations +-- +----------------------------------------------------------------------------- + +module Graphics.Rendering.Plot.Figure.Point ( + Point, PointFormat(..) + , PointSize +-- , clearPointFormat + , setGlyph + , setPointSize + , setPointColour + , getPointColour + ) where + +----------------------------------------------------------------------------- + +--import Data.Word +import Data.Colour +--import Data.Colour.SRGB +--import Data.Colour.Names + +--import qualified Graphics.Rendering.Cairo as C +--import qualified Graphics.Rendering.Pango as P + +import Control.Monad.State +import Control.Monad.Reader +import Control.Monad.Supply + +import Graphics.Rendering.Plot.Types + +----------------------------------------------------------------------------- + +changePointSize :: PointSize -> PointOptions -> PointOptions +changePointSize sz (PointOptions _ c) = PointOptions sz c + +changePointColour :: Color -> PointOptions -> PointOptions +changePointColour c (PointOptions sz _) = PointOptions sz c + +getPointColour :: PointType -> Color +getPointColour (FullPoint (PointOptions _ c) _) = c + +changePointGlyph :: Glyph -> PointType -> PointType +--changePointGlyph gt s (BarePoint _) = BarePoint (Glyph gt s) +changePointGlyph g (FullPoint po _) = FullPoint po g + +----------------------------------------------------------------------------- +{- +-- | clear the formatting of a point +clearPointFormat :: Point () +clearPointFormat = do + pt <- get + case pt of + g@(BarePoint _) -> put g + (FullPoint _ g) -> put $ BarePoint g +-} + +changePointOptions :: (PointOptions -> PointOptions) -> PointType -> Point () +--changePointOptions o (BarePoint g) = do +-- po <- ask +-- put $ FullPoint (o po) g +changePointOptions o (FullPoint po g) = put $ FullPoint (o po) g + +-- | change the glyph of a point +setGlyph :: Glyph -> Point () +setGlyph g = modify $ \s -> changePointGlyph g s + +-- | change the size of a point +setPointSize :: PointSize -> Point () +setPointSize sz = get >>= changePointOptions (changePointSize sz) + +-- | change the colour of a point +setPointColour :: Color -> Point () +setPointColour c = get >>= changePointOptions (changePointColour c) + +----------------------------------------------------------------------------- + +class PointFormat a where + toPoint :: (MonadReader Options m, MonadSupply SupplyData m) => a -> m PointType + +instance PointFormat Glyph where toPoint g = do + po <- asks _pointoptions + c <- supply + return $ FullPoint (changePointColour c po) g +--instance PointFormat GlyphType where toPoint g = return $ BarePoint g +instance Real a => PointFormat (Colour a) where toPoint c = do + po <- asks _pointoptions + g <- supply + return $ FullPoint (changePointColour (colourConvert c) po) g +instance PointFormat (Glyph,PointSize) where toPoint (g,s) = do + po <- asks _pointoptions + c <- supply + return $ FullPoint (changePointSize s $ changePointColour c po) g +instance Real a => PointFormat (Glyph,Colour a) where toPoint (g,c) = do + po <- asks _pointoptions + return $ FullPoint (changePointColour (colourConvert c) po) g +instance Real a => PointFormat (Glyph,PointSize,Colour a) where toPoint (g,s,c) = return $ FullPoint (PointOptions s (colourConvert c)) g + +----------------------------------------------------------------------------- + +{- TODO + + fix Glyph/GlyphType differences + NoPoint option? +-} + + diff --git a/lib/Graphics/Rendering/Plot/Figure/Text.hs b/lib/Graphics/Rendering/Plot/Figure/Text.hs new file mode 100644 index 0000000..456049c --- /dev/null +++ b/lib/Graphics/Rendering/Plot/Figure/Text.hs @@ -0,0 +1,181 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Plot.Figure.Text +-- Copyright : (c) A. V. H. McPhail 2010 +-- License : BSD3 +-- +-- Maintainer : haskell.vivian.mcphail gmail com +-- Stability : provisional +-- Portability : portable +-- +-- 'Text' operations +-- +----------------------------------------------------------------------------- + +module Graphics.Rendering.Plot.Figure.Text ( + Text + , FontFamily,FontSize,Color + -- | A text element must exist for formatting to work + , clearText + , clearTextFormat + , setText + , setFontFamily + , setFontStyle + , setFontVariant + , setFontWeight + , setFontStretch + , setFontSize + , setFontColour + -- + , changeFontSize + , changeFontColour + -- + , scaleFontSize + ) where + +----------------------------------------------------------------------------- + +import Control.Monad.State +import Control.Monad.Reader + +import qualified Graphics.Rendering.Pango as P + +import Graphics.Rendering.Plot.Types + +----------------------------------------------------------------------------- + +changeFontFamilyFont :: FontFamily -> FontOptions -> FontOptions +changeFontFamilyFont ff (FontOptions _ fs fv fw fc) = FontOptions ff fs fv fw fc + +changeFontStyleFont :: P.FontStyle -> FontOptions -> FontOptions +changeFontStyleFont fs (FontOptions ff _ fv fw fc) = FontOptions ff fs fv fw fc + +changeFontVariantFont :: P.Variant -> FontOptions -> FontOptions +changeFontVariantFont fv (FontOptions ff fs _ fw fc) = FontOptions ff fs fv fw fc + +changeFontWeightFont :: P.Weight -> FontOptions -> FontOptions +changeFontWeightFont fw (FontOptions ff fs fv _ fc) = FontOptions ff fs fv fw fc + +changeFontStretchFont :: P.Stretch -> FontOptions -> FontOptions +changeFontStretchFont fc (FontOptions ff fs fv fw _) = FontOptions ff fs fv fw fc + +changeFontOptionsFont :: (FontOptions -> FontOptions) -> TextOptions -> TextOptions +changeFontOptionsFont f (TextOptions fo fz c) = TextOptions (f fo) fz c + +changeFontFamily :: FontFamily -> TextOptions -> TextOptions +changeFontFamily ff = changeFontOptionsFont $ changeFontFamilyFont ff + +changeFontStyle :: P.FontStyle -> TextOptions -> TextOptions +changeFontStyle fs = changeFontOptionsFont $ changeFontStyleFont fs + +changeFontVariant :: P.Variant -> TextOptions -> TextOptions +changeFontVariant fv = changeFontOptionsFont $ changeFontVariantFont fv + +changeFontWeight :: P.Weight -> TextOptions -> TextOptions +changeFontWeight fw = changeFontOptionsFont $ changeFontWeightFont fw + +changeFontStretch :: P.Stretch -> TextOptions -> TextOptions +changeFontStretch fc = changeFontOptionsFont $ changeFontStretchFont fc + +changeFontSize :: FontSize -> TextOptions -> TextOptions +changeFontSize fz (TextOptions fo _ c) = TextOptions fo fz c + +scaleFontSize :: Double -> TextOptions -> TextOptions +scaleFontSize sc (TextOptions fo fz c) = TextOptions fo (sc*fz) c + +changeFontColour :: Color -> TextOptions -> TextOptions +changeFontColour c (TextOptions fo fz _) = TextOptions fo fz c + +changeFontTextSize :: FontSize -> TextEntry -> TextEntry +changeFontTextSize fz (FontText to s) = FontText (changeFontSize fz to) s +changeFontTextSize _ _ = error "changeFontTextSize" + +changeFontTextColour :: Color -> TextEntry -> TextEntry +changeFontTextColour c (FontText to s) = FontText (changeFontColour c to) s +changeFontTextColour _ _ = error "changeFontTextColour" + +changeText :: String -> TextEntry -> TextEntry +changeText s NoText = BareText s +changeText s (BareText _) = BareText s +changeText s (SizeText fz c _) = SizeText fz c s +changeText s (FontText to _) = FontText to s + +clearTextEntryFormat :: TextEntry -> TextEntry +clearTextEntryFormat NoText = NoText +clearTextEntryFormat t@(BareText _) = t +clearTextEntryFormat (SizeText _ _ s) = BareText s +clearTextEntryFormat (FontText _ s) = BareText s + +----------------------------------------------------------------------------- + +-- | clear the text entry +clearText :: Text () +clearText = put NoText + +-- | set the text formatting to the default +clearTextFormat :: Text () +clearTextFormat = modify clearTextEntryFormat + +-- | set the value of a text entry +setText :: String -> Text () +setText l = modify (changeText l) + +changeFontOptions :: (TextOptions -> TextOptions) -> TextEntry -> Text () +changeFontOptions _ NoText = return () +changeFontOptions o (BareText s) = do + to <- ask + put $ FontText (o to) s +changeFontOptions o (SizeText fz c s) = do + to <- ask + let (TextOptions fo _ _) = o to + put $ FontText (TextOptions fo fz c) s +changeFontOptions o (FontText to s) = put $ FontText (o to) s + + +-- | set the font style of a text entry +setFontFamily :: FontFamily -> Text () +setFontFamily ff = get >>= changeFontOptions (changeFontFamily ff) + +-- | set the font style of a text entry +setFontStyle :: P.FontStyle -> Text () +setFontStyle fs = get >>= changeFontOptions (changeFontStyle fs) + +-- | set the font variant of a text entry +setFontVariant :: P.Variant -> Text () +setFontVariant fv = get >>= changeFontOptions (changeFontVariant fv) + +-- | set the font weight of a text entry +setFontWeight :: P.Weight -> Text () +setFontWeight fw = get >>= changeFontOptions (changeFontWeight fw) + +-- | set the font stretch of a text entry +setFontStretch :: P.Stretch -> Text () +setFontStretch fc = get >>= changeFontOptions (changeFontStretch fc) + +-- | set the font size of a text entry +setFontSize :: FontSize -> Text () +setFontSize fz = do + t <- get + case t of + NoText -> return () + (BareText s) -> do + (TextOptions _ _ c) <- ask + put $ SizeText fz c s + (SizeText _ c s) -> put $ SizeText fz c s + (FontText to s) -> put $ FontText (changeFontSize fz to) s + +-- | set the colour of a text entry +setFontColour :: Color -> Text () +setFontColour c = do + t <- get + case t of + NoText -> return () + (BareText s) -> do + (TextOptions _ fz _) <- ask + put $ SizeText fz c s + (SizeText fz _ s) -> put $ SizeText fz c s + (FontText to s) -> put $ FontText (changeFontColour c to) s + +----------------------------------------------------------------------------- + + diff --git a/lib/Graphics/Rendering/Plot/Render.hs b/lib/Graphics/Rendering/Plot/Render.hs new file mode 100644 index 0000000..3336c18 --- /dev/null +++ b/lib/Graphics/Rendering/Plot/Render.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Plot.Render +-- Copyright : (c) A. V. H. McPhail 2010 +-- License : BSD3 +-- +-- Maintainer : haskell.vivian.mcphail gmail com +-- Stability : provisional +-- Portability : portable +-- +-- Rendering 'Figure's +-- +----------------------------------------------------------------------------- + +module Graphics.Rendering.Plot.Render ( + -- * Rendering + render + -- ** Outputting to file + , OutputType(..) + , writeFigure + -- * Notes + -- $notes + ) where + +----------------------------------------------------------------------------- +{- TODO + + store 'next colour' list in state +-} +----------------------------------------------------------------------------- + +--import Data.Either + +--import Data.Packed.Vector +--import Numeric.LinearAlgebra.Linear + +--import Data.Word + +--import Data.Maybe + +--import Data.Colour.SRGB +--import Data.Colour.Names + +--import qualified Data.Array.IArray as A + +import qualified Graphics.Rendering.Cairo as C +import qualified Graphics.Rendering.Pango as P + +--import Control.Monad.Reader +--import Control.Monad.State +--import Control.Monad.Trans + +import Graphics.Rendering.Plot.Types +import Graphics.Rendering.Plot.Defaults + +--import Graphics.Rendering.Plot.Figure.Text + +import Graphics.Rendering.Plot.Render.Types +import Graphics.Rendering.Plot.Render.Text +import Graphics.Rendering.Plot.Render.Plot + +--import qualified Text.Printf as Printf + +--import Prelude hiding(min,max) +--import qualified Prelude(max) + +----------------------------------------------------------------------------- + +-- | render a 'Figure' +render :: Figure () -- ^ the figure to be rendered + -> (Int,Int) -- ^ (width,height) + -> C.Render () -- ^ a Cairo operation +render g = (\(w,h) -> do + pc <- pango $ P.cairoCreateContext Nothing + to <- getDefaultTextOptions pc + let options' = Options defaultLineOptions defaultPointOptions to + let (FigureState options _ figure) = execFigure g (FigureState options' defaultSupply emptyFigure) + evalRender (renderFigure figure) (RenderEnv pc options) (BoundingBox 0 0 (fromIntegral w) (fromIntegral h))) + +----------------------------------------------------------------------------- + +-- | output the 'Figure' +writeFigure :: OutputType -- ^ output file type + -> FilePath -- ^ file path + -> (Int,Int) -- ^ (width,height) + -> Figure () -- ^ the 'Figure' rendering operation + -> IO () +writeFigure PNG fn wh f = withImageSurface wh (writeSurfaceToPNG fn (render f wh)) +writeFigure PS fn wh f = writeSurface C.withPSSurface fn wh f +writeFigure PDF fn wh f = writeSurface C.withPDFSurface fn wh f +writeFigure SVG fn wh f = writeSurface C.withSVGSurface fn wh f + +withImageSurface :: (Int,Int) -> (C.Surface -> IO ()) -> IO () +withImageSurface (w,h) = C.withImageSurface C.FormatARGB32 w h + +writeSurfaceToPNG :: FilePath -> C.Render () -> C.Surface -> IO () +writeSurfaceToPNG fn r s = do + C.renderWith s r + C.surfaceWriteToPNG s fn + +writeSurface :: (FilePath -> Double -> Double -> (C.Surface -> IO ()) -> IO ()) + -> FilePath -> (Int,Int) -> Figure () -> IO () +writeSurface rw fn (w,h) f = rw fn (fromIntegral w) (fromIntegral h) (flip C.renderWith (render f (w,h))) + +----------------------------------------------------------------------------- + +renderFigure :: FigureData -> Render () +renderFigure (Figure p t s d) = do + cairo $ do + C.save + C.setSourceRGBA 1 1 1 1 + C.paint + C.restore + + tx <- bbCentreWidth + ty <- bbTopHeight + (_,th) <- renderText t Centre TTop tx ty + bbLowerTop (th+textPad) + + sx <- bbCentreWidth + sy <- bbTopHeight + (_,sh) <- renderText s Centre TTop sx sy + bbLowerTop (sh+textPad) + + applyPads p + + renderPlots d + diff --git a/lib/Graphics/Rendering/Plot/Render/Plot.hs b/lib/Graphics/Rendering/Plot/Render/Plot.hs new file mode 100644 index 0000000..7458737 --- /dev/null +++ b/lib/Graphics/Rendering/Plot/Render/Plot.hs @@ -0,0 +1,127 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Plot.Render.Plot +-- Copyright : (c) A. V. H. McPhail 2010 +-- License : BSD3 +-- +-- Maintainer : haskell.vivian.mcphail gmail com +-- Stability : provisional +-- Portability : portable +-- +-- Rendering 'Figure's +-- +----------------------------------------------------------------------------- + +module Graphics.Rendering.Plot.Render.Plot ( + -- * Rendering + renderPlots + ) where + +----------------------------------------------------------------------------- + +--import Data.Either + +--import Data.Packed.Vector +--import Numeric.LinearAlgebra.Linear + +--import Data.Word + +--import Data.Maybe + +--import Data.Colour.SRGB +--import Data.Colour.Names + +import qualified Data.Array.IArray as A + +import qualified Graphics.Rendering.Cairo as C +--import qualified Graphics.Rendering.Pango as P + +--import Control.Monad.Reader +import Control.Monad.State +--import Control.Monad.Trans + +import Graphics.Rendering.Plot.Types +--import Graphics.Rendering.Plot.Defaults + +--import Graphics.Rendering.Plot.Figure.Text + +import Graphics.Rendering.Plot.Render.Types + +import Graphics.Rendering.Plot.Render.Text +import Graphics.Rendering.Plot.Render.Plot.Axis +import Graphics.Rendering.Plot.Render.Plot.Data + +--import qualified Text.Printf as Printf + +--import Prelude hiding(min,max) +--import qualified Prelude(max) + +----------------------------------------------------------------------------- + +bbPlot :: Int -> Int -> (Int,Int) -> Render () +bbPlot r c (px,py) = modify (\(BoundingBox x y w h) -> let rs = w/(fromIntegral r) + cs = h/(fromIntegral c) + in (BoundingBox + (x+rs*((fromIntegral px)-1)) + (y+cs*((fromIntegral py)-1)) + rs cs)) + +renderPlots :: Plots -> Render () +renderPlots d = do + let ((x,y),(x',y')) = A.bounds d + rows = x'-x+1 + cols = y'-y+1 + bb <- get + mapM_ (\(i,e) -> do + case e of + Nothing -> return () + Just e' -> do + bbPlot rows cols i + renderPlot e' + put bb) (A.assocs d) + +renderPlot :: PlotData -> Render () +renderPlot (Plot b p hd r a t d l an) = do + tx <- bbCentreWidth + ty <- bbTopHeight + (_,th) <- renderText hd Centre TTop tx ty + bbLowerTop (th+textPad) +{- attempt to have different colour plot area + (BoundingBox x y w h) <- get + cairo $ do + setColour white + C.moveTo x y + C.lineTo (x+w) y + C.lineTo (x+w) (y+h) + C.lineTo x (y+h) + C.stroke + C.clip + C.fill + C.paint +-} + renderAxes p r a + renderBorder b + cairo C.save + clipBoundary + renderData r t d an + renderLegend l + cairo C.restore + +renderBorder :: Border -> Render () +renderBorder False = return () +renderBorder True = do + (BoundingBox x y w h) <- get + cairo $ do + C.setLineWidth 0.5 + C.moveTo x y + C.lineTo x (y+h) + C.lineTo (x+w) (y+h) + C.lineTo (x+w) y + C.closePath + C.stroke + +renderLegend :: Maybe Legend -> Render () +renderLegend _ = return () + +----------------------------------------------------------------------------- + diff --git a/lib/Graphics/Rendering/Plot/Render/Plot/Axis.hs b/lib/Graphics/Rendering/Plot/Render/Plot/Axis.hs new file mode 100644 index 0000000..614b84f --- /dev/null +++ b/lib/Graphics/Rendering/Plot/Render/Plot/Axis.hs @@ -0,0 +1,398 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Plot.Render.Plot.Axis +-- Copyright : (c) A. V. H. McPhail 2010 +-- License : BSD3 +-- +-- Maintainer : haskell.vivian.mcphail gmail com +-- Stability : provisional +-- Portability : portable +-- +-- Rendering 'Figure's +-- +----------------------------------------------------------------------------- + +module Graphics.Rendering.Plot.Render.Plot.Axis ( + -- * Rendering + renderAxes + ) where + +----------------------------------------------------------------------------- + +import Data.Either + +--import Data.Maybe + +--import Data.Colour.SRGB +--import Data.Colour.Names + +--import qualified Data.Array.IArray as A + +import qualified Graphics.Rendering.Cairo as C +import qualified Graphics.Rendering.Pango as P + +import Control.Monad.Reader +import Control.Monad.State +--import Control.Monad.Trans + +import Graphics.Rendering.Plot.Types +import Graphics.Rendering.Plot.Defaults + +import Graphics.Rendering.Plot.Figure.Text + +import Graphics.Rendering.Plot.Render.Types +import Graphics.Rendering.Plot.Render.Text + +import qualified Text.Printf as Printf + +import Prelude hiding(min,max) +import qualified Prelude(max) + +----------------------------------------------------------------------------- + +addPadding :: Padding -> Padding -> Padding +addPadding (Padding l0 r0 b0 t0) (Padding l1 r1 b1 t1) = Padding (l0+l1) (r0+r1) (b0+b1) (t0+t1) + +maxPadding :: Padding -> Padding -> Padding +maxPadding (Padding l0 r0 b0 t0) (Padding l1 r1 b1 t1) = Padding (Prelude.max l0 l1) (Prelude.max r0 r1) (Prelude.max b0 b1) (Prelude.max t0 t1) + +-- first is plot padding, second is calculated padding +isZeroPadding :: Padding -> Padding -> Render Padding +isZeroPadding (Padding l0 r0 b0 t0) (Padding l1 r1 b1 t1) = do + l <- if l1 == 0 then do + bbShiftLeft l0 + return l0 + else if l0 > l1 then do + bbShiftLeft (l0 - l1) + return l0 + else return l1 + r <- if r1 == 0 then do + bbShiftRight r0 + return r0 + else if r0 > r1 then do + bbShiftRight (r0 - r1) + return r0 + else return r1 + b <- if b1 == 0 then do + bbRaiseBottom b0 + return b0 + else if b0 > b1 then do + bbRaiseBottom (b0 - b1) + return b0 + else return b1 + t <- if t1 == 0 then do + bbLowerTop t0 + return t0 + else if t0 > t1 then do + bbLowerTop (t0 - t1) + return t0 + else return t1 + return $ Padding l r b t + + +renderAxes :: Padding -> Ranges -> [AxisData] -> Render () +renderAxes p r axes = do + lp <- foldM shiftForAxisLabel (Padding 0 0 0 0) axes + tp <- foldM (shiftForTicks r) (Padding 0 0 0 0) axes + let apd = addPadding lp tp + p' <- isZeroPadding p apd + mapM_ (renderAxisLabel p') axes + mapM_ (renderAxis r) axes + return () + +shiftForAxisLabel :: Padding -> AxisData -> Render Padding +shiftForAxisLabel p (Axis _ _ _ _ _ _ NoText) = return p +shiftForAxisLabel p (Axis ax sd _ _ _ _ lb) = do + (FontText to s) <- formatText lb + pc <- asks _pangocontext + (w,h) <- cairo $ do + lo <- pango $ P.layoutText pc s + setTextOptions to lo + case ax of + XAxis -> do + (_,(twh)) <- textSize lo Centre Middle 0 0 + return twh + YAxis -> do + (_,((w',h'))) <- textSizeVertical lo Centre Middle 0 0 + return (h',w') + shiftForAxisLabel' p ax sd w h + where shiftForAxisLabel' (Padding l r b t) XAxis (Side Lower) _ h' = do + bbRaiseBottom (h'+2*textPad) + return $ Padding l r (b+h'+2*textPad) t + shiftForAxisLabel' (Padding l r b t) XAxis (Side Upper) _ h' = do + bbLowerTop (h'+2*textPad) + return $ Padding l r b (t+h'+2*textPad) + shiftForAxisLabel' (Padding l r b t) YAxis (Side Lower) w' _ = do + bbShiftLeft (w'+2*textPad) + return $ Padding (l+w'+2*textPad) r b t + shiftForAxisLabel' (Padding l r b t) YAxis (Side Upper) w' _ = do + bbShiftRight (w'+2*textPad) + return $ Padding l (r+w'+2*textPad) b t + shiftForAxisLabel' p' _ (Value _) _ _ = return p' + +-- the padding is the tick padding that has been applied +renderAxisLabel :: Padding -> AxisData -> Render () +renderAxisLabel _ (Axis _ _ _ _ _ _ NoText) = return () +renderAxisLabel (Padding _ _ b _) (Axis XAxis (Side Lower) _ _ _ _ la) = do + lx <- bbCentreWidth + ly <- bbBottomHeight + _ <- renderText la Centre TBottom lx (ly+b-textPad) + return () +renderAxisLabel (Padding _ _ _ t) (Axis XAxis (Side Upper) _ _ _ _ la) = do + lx <- bbCentreWidth + ly <- bbTopHeight + _ <- renderText la Centre TTop lx (ly-t+textPad) + return () +renderAxisLabel (Padding l _ _ _) (Axis YAxis (Side Lower) _ _ _ _ la) = do + lx <- bbLeftWidth + ly <- bbCentreHeight + _ <- renderTextVertical la TLeft Middle (lx-l+textPad) ly + return () +renderAxisLabel (Padding _ r _ _) (Axis YAxis (Side Upper) _ _ _ _ la) = do + lx <- bbRightWidth + ly <- bbCentreHeight + _ <- renderTextVertical la TRight Middle (lx+r-textPad) ly + return () +renderAxisLabel _ (Axis _ (Value _) _ _ _ _ _) = return () + +shiftForTicks :: Ranges -> Padding -> AxisData -> Render Padding +shiftForTicks (Ranges (Left (Range xmin xmax)) _) + p (Axis XAxis (Side Lower) _ min maj tf _) + = shiftForTicks' p min maj XAxis (Side Lower) tf (negate $ Prelude.max (abs xmin) (abs xmax)) +shiftForTicks (Ranges (Left (Range xmin xmax)) _) + p (Axis XAxis (Side Upper) _ min maj tf _) + = shiftForTicks' p min maj XAxis (Side Upper) tf (negate $ Prelude.max (abs xmin) (abs xmax)) +shiftForTicks (Ranges (Right ((Range xmin xmax),_)) _) + p (Axis XAxis (Side Lower) _ min maj tf _) + = shiftForTicks' p min maj XAxis (Side Lower) tf (negate $ Prelude.max (abs xmin) (abs xmax)) +shiftForTicks (Ranges (Right (_,(Range xmin xmax))) _) + p (Axis XAxis (Side Upper) _ min maj tf _) + = shiftForTicks' p min maj XAxis (Side Upper) tf (negate $ Prelude.max (abs xmin) (abs xmax)) +shiftForTicks (Ranges _ (Left (Range ymin ymax))) + p (Axis YAxis (Side Lower) _ min maj tf _) + = shiftForTicks' p min maj YAxis (Side Lower) tf (negate $ Prelude.max (abs ymin) (abs ymax)) +shiftForTicks (Ranges _ (Left (Range ymin ymax))) + p (Axis YAxis (Side Upper) _ min maj tf _) + = shiftForTicks' p min maj YAxis (Side Upper) tf (negate $ Prelude.max (abs ymin) (abs ymax)) +shiftForTicks (Ranges _ (Right ((Range ymin ymax),_))) + p (Axis YAxis (Side Lower) _ min maj tf _) + = shiftForTicks' p min maj YAxis (Side Lower) tf (negate $ Prelude.max (abs ymin) (abs ymax)) +shiftForTicks (Ranges _ (Right (_,(Range ymin ymax)))) + p (Axis YAxis (Side Upper) _ min maj tf _) + = shiftForTicks' p min maj YAxis (Side Upper) tf (negate $ Prelude.max (abs ymin) (abs ymax)) +shiftForTicks _ p (Axis _ (Value _) _ _ _ _ _) + = return p + +shiftForTicks' :: Padding -> Ticks -> Ticks -> AxisType -> AxisPosn -> TickFormat -> Double -> Render Padding +shiftForTicks' p (Ticks _ (Left 0)) (Ticks _ (Left 0)) _ _ _ _ = return p +shiftForTicks' (Padding l r b t) (Ticks _ (Left _)) (Ticks _ (Left 0)) XAxis (Side Lower) _ _ = do + bbRaiseBottom minorTickLength + return $ Padding l r (b+minorTickLength) t +shiftForTicks' (Padding l r b t) (Ticks _ (Left _)) (Ticks _ (Left 0)) YAxis (Side Lower) _ _ = do + bbShiftLeft minorTickLength + return $ Padding (l+minorTickLength) r b t +shiftForTicks' (Padding l r b t) (Ticks _ (Left _)) (Ticks _ (Left 0)) XAxis (Side Upper) _ _ = do + bbLowerTop minorTickLength + return $ Padding l r b (t+minorTickLength) +shiftForTicks' (Padding l r b t) (Ticks _ (Left _)) (Ticks _ (Left 0)) YAxis (Side Upper) _ _ = do + bbShiftRight minorTickLength + return $ Padding l (r+minorTickLength) b t +shiftForTicks' p (Ticks _ _) (Ticks _ _) ax sd tf v = do + to <- asks (_textoptions . _renderoptions) + pc <- asks _pangocontext + (tw,th) <- cairo $ do + let s = Printf.printf tf v + lt <- pango $ P.layoutText pc s + setTextOptions (scaleFontSize tickLabelScale to) lt + (_,twh) <- textSize lt Centre Middle 0 0 + return twh + shiftForTicks'' p (tw,th) ax sd + where shiftForTicks'' (Padding l r b t) (_,th) XAxis (Side Lower) = do + bbRaiseBottom (majorTickLength+th+2*textPad) + return $ Padding l r (b+majorTickLength+th+2*textPad) t + shiftForTicks'' (Padding l r b t) (tw,_) YAxis (Side Lower) = do + bbShiftLeft (majorTickLength+tw+2*textPad) + return $ Padding (l+majorTickLength+tw+2*textPad) r b t + shiftForTicks'' (Padding l r b t) (_,th) XAxis (Side Upper) = do + bbLowerTop (majorTickLength+th+2*textPad) + return $ Padding l r b (t+majorTickLength+th+2*textPad) + shiftForTicks'' (Padding l r b t) (tw,_) YAxis (Side Upper) = do + bbShiftRight (majorTickLength+tw+2*textPad) + return $ Padding l (r+majorTickLength+tw+2*textPad) b t + shiftForTicks'' p' (_,_) _ (Value _) = return p' + +renderAxis :: Ranges -> AxisData -> Render () +renderAxis _ (Axis _ _ NoLine _ _ _ _) = return () +renderAxis r (Axis ax sd + (ColourLine c) + min maj tf l) = do + lo <- asks (_lineoptions . _renderoptions) + renderAxis r (Axis ax sd (TypeLine lo c) min maj tf l) +renderAxis r (Axis ax sd + (TypeLine (LineOptions ds lw) c) + min maj tf _) = do + cairo $ do + setColour c + setDashes ds + C.setLineWidth lw + renderAxisLine r ax sd + cairo $ do + lw' <- C.getLineWidth + C.setLineWidth (lw'/2) + renderAxisTicks r ax sd min maj tf + return () + +lowerRange :: Either Range (Range,Range) -> Range +lowerRange (Left r@(Range _ _)) = r +lowerRange (Right (r@(Range _ _),_)) = r + +renderAxisLine :: Ranges -> AxisType -> AxisPosn -> Render () +renderAxisLine (Ranges _ yr) XAxis (Value v) = do + let (Range min max) = lowerRange yr + (BoundingBox x y w h) <- get + cairo $ do + C.moveTo x (y+h*((v-min)/(max-min))) + C.lineTo (x+w) (y+h*((v-min)/(max-min))) + C.stroke +renderAxisLine (Ranges xr _) YAxis (Value v) = do + let (Range min max) = lowerRange xr + (BoundingBox x y w h) <- get + cairo $ do + C.moveTo (x+w*((v-min)/(max-min))) y + C.lineTo (x+w*((v-min)/(max-min))) (y+h) + C.stroke +renderAxisLine _ XAxis (Side Lower) = do + (BoundingBox x y _ h) <- get + cairo $ do + C.moveTo x y + C.lineTo x (y+h) + C.stroke +renderAxisLine _ XAxis (Side Upper) = do + (BoundingBox x y w h) <- get + cairo $ do + C.moveTo (x+w) y + C.lineTo (x+w) (y+h) + C.stroke +renderAxisLine _ YAxis (Side Lower) = do + (BoundingBox x y w h) <- get + cairo $ do + C.moveTo x (y+h) + C.lineTo (x+w) (y+h) + C.stroke +renderAxisLine _ YAxis (Side Upper) = do + (BoundingBox x y w _) <- get + cairo $ do + C.moveTo x (y) + C.lineTo (x+w) (y) + C.stroke + +tickPosition :: Double -> Double -> Int -> [Double] +tickPosition min max n = map (\x -> min + (max-min)*(fromIntegral x)/(fromIntegral (n-1))) (take n [(0 :: Int)..]) +{- +tickPosition min max n = let diff = max - min + (sc,sd) = scaleDiff 1.0 diff n + start = (round (min*sc)) `div` (fromIntegral sd) + in map (\x -> (fromIntegral (x*sd+start))/sc) (take n [0..]) + where scaleDiff :: Double -> Double -> Int -> (Double,Int) + scaleDiff s diff n + | (round (s*diff)) < n = scaleDiff (10*s) (10*diff) n + | otherwise = (s,(round diff) `div` n) +-} +renderAxisTicks :: Ranges -> AxisType -> AxisPosn -> Ticks -> Ticks -> TickFormat -> Render () +renderAxisTicks (Ranges xrange yrange) ax sd + (Ticks gmin (Left tmin)) (Ticks gmaj (Left tmaj)) tf = do + (BoundingBox x y w h) <- get + to <- asks (_textoptions . _renderoptions) + pc <- asks _pangocontext + cairo $ do + let (min,max) = case ax of + XAxis -> case sd of + (Side Lower) -> case xrange of + (Left (Range xmin xmax)) -> (xmin,xmax) + (Right (Range xmin xmax,_)) -> (xmin,xmax) + (Side Upper) -> case xrange of + (Left (Range xmin xmax)) -> (xmin,xmax) + (Right (_,Range xmin xmax)) -> (xmin,xmax) + (Value _) -> case xrange of + (Left (Range xmin xmax)) -> (xmin,xmax) + (Right (Range xmin xmax,_)) -> (xmin,xmax) + YAxis -> case sd of + (Side Lower) -> case yrange of + (Left (Range ymin ymax)) -> (ymin,ymax) + (Right (Range ymin ymax,_)) -> (ymin,ymax) + (Side Upper) -> case yrange of + (Left (Range ymin ymax)) -> (ymin,ymax) + (Right (_,Range ymin ymax)) -> (ymin,ymax) + (Value _) -> case yrange of + (Left (Range ymin ymax)) -> (ymin,ymax) + (Right (Range ymin ymax,_)) -> (ymin,ymax) + -- convert axis position to non-data coordinates + let sd' = case sd of + (Side _) -> sd + (Value v) -> case ax of + XAxis -> let (Range b t) = lowerRange yrange + in Value (y+h*(t-v)/(t-b)) + YAxis -> let (Range b t) = lowerRange xrange + in Value (x+w*(v-b)/(t-b)) + let pos = (tickPosition min max tmaj) + let majpos = let ones = 1.0 : ones + ln = length pos + in zip pos (take ln ones) + minpos' = zip (tickPosition min max tmin) (minorTickLengths tmin tmaj) + minpos = filter (not . (\(p,_) -> elem p pos)) minpos' + let renderAxisTick' = renderAxisTick pc to x y w h min max ax sd' tf + mapM_ (renderAxisTick' Minor gmin) minpos + mapM_ (renderAxisTick' Major gmaj) majpos + return () + return () + +minorTickLengths :: Int -> Int -> [Double] +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..]) + --map ((/) 2 . (+) 1 . (/) (fromIntegral tmaj) . fromIntegral . (mod tmaj)) (take (tmin+1) [0..]) + +renderAxisTick :: P.PangoContext -> TextOptions + -> Double -> Double -> Double -> Double -> Double -> Double + -> AxisType -> AxisPosn -> TickFormat -> Tick -> GridLines + -> (Double,Double) -> C.Render () +renderAxisTick pc to x y w h min max xa sd tf t gl (p,l) = do + let tl' = case t of + Minor -> minorTickLength + Major -> majorTickLength + tl = tl' * l + (x1,y1,x2,y2) = case xa of + XAxis -> case sd of + (Side _) -> let xt x' = x + x'*w/(max-min) + ys = if gl then y else y + h + in (xt p,ys,xt p,y+h+tl) + (Value v) -> let xt x' = x + x'*w/(max-min) + yb = if gl then y else v-tl + yt = if gl then y+h else v+tl + in (xt p,yb,xt p,yt) + YAxis -> case sd of + (Side _) -> let xf = if gl then x + w else x + yt y' = (y + h) - (y'-min)*h/(max-min) + in (x-tl,yt p,xf,yt p) + (Value v) -> let xb = if gl then x else v-tl + xt = if gl then x+h else v+tl + yt y' = (y + h) - (y'-min)*h/(max-min) + in (xb,yt p,xt,yt p) + C.moveTo x1 y1 + C.lineTo x2 y2 + C.stroke + let majlab = case sd of + (Side _) -> True + (Value _) -> False + when (t == Major && majlab) $ do + let s = Printf.printf tf p + lo <- pango $ P.layoutText pc s + setTextOptions (scaleFontSize tickLabelScale to) lo + case xa of + XAxis -> do + ((x',y'),_) <- textSize lo Centre TTop x1 (y2+textPad) + showText lo x' y' + YAxis -> do + ((x',y'),_) <- textSize lo TLeft Middle (x1-textPad) y1 + showText lo x' y' + return () + diff --git a/lib/Graphics/Rendering/Plot/Render/Plot/Data.hs b/lib/Graphics/Rendering/Plot/Render/Plot/Data.hs new file mode 100644 index 0000000..f968549 --- /dev/null +++ b/lib/Graphics/Rendering/Plot/Render/Plot/Data.hs @@ -0,0 +1,327 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Plot.Render.Plot.Data +-- Copyright : (c) A. V. H. McPhail 2010 +-- License : BSD3 +-- +-- Maintainer : haskell.vivian.mcphail gmail com +-- Stability : provisional +-- Portability : portable +-- +-- Rendering 'Figure's +-- +----------------------------------------------------------------------------- + +module Graphics.Rendering.Plot.Render.Plot.Data ( + -- * Rendering + renderData + ) where + +----------------------------------------------------------------------------- + +--import Data.Either + +import Data.Packed.Vector +import Data.Packed() +import Numeric.LinearAlgebra.Linear + +--import Data.Word + +--import Data.Maybe + +--import Data.Colour.SRGB +--import Data.Colour.Names + +import qualified Data.Array.IArray as A + +import qualified Graphics.Rendering.Cairo as C +import qualified Graphics.Rendering.Cairo.Matrix as CM +--import qualified Graphics.Rendering.Pango as P + +import Control.Monad.Reader +import Control.Monad.State +--import Control.Monad.Trans +import Control.Monad.Maybe + +import Graphics.Rendering.Plot.Types +--import Graphics.Rendering.Plot.Defaults + +--import Graphics.Rendering.Plot.Figure.Text + +import Graphics.Rendering.Plot.Render.Types + +--import qualified Text.Printf as Printf + +import Prelude hiding(min,max,abs) +--import qualified Prelude(max) + +----------------------------------------------------------------------------- + +findMinIdx, findMaxIdx :: Vector Double -> Double -> Int -> Int -> Int +findMinIdx v x n max + | n >= max = error "data not in range" + | v @> n >= x = n + | otherwise = findMinIdx v x (n+1) max + +findMaxIdx v x n min + | n < 0 = error "data not in range" + | v @> n <= x = n + | otherwise = findMaxIdx v x (n-1) min + +flipVerticalMatrix :: CM.Matrix +flipVerticalMatrix = CM.Matrix 1 0 0 (-1) 0 0 + +flipVertical :: C.Render () +flipVertical = C.transform flipVerticalMatrix + +----------------------------------------------------------------------------- + +renderData :: Ranges -> PlotType -> DataSeries -> Annotations -> Render () +renderData r@(Ranges (Left (Range xmin xmax)) (Left (Range ymin ymax))) + Linear + (DS_1toN abs ys) + an = do + (BoundingBox x y w h) <- get + let xscale = w/(xmax-xmin) + yscale = h/(ymax-ymin) + -- transform to data coordinates + cairo $ do + C.translate x (y+h) + C.scale xscale yscale + C.translate xmin ymin + flipVertical + mapM_ (renderSeries r xscale yscale) (zip (repeat abs) (A.elems ys)) + renderAnnotations an + +renderSeries :: Ranges -> Double -> Double -> (Abscissae, DecoratedSeries) -> Render () +renderSeries (Ranges (Left (Range xmin xmax)) _) + xscale yscale ((AbsPoints t),(DecSeries o d)) = do + dat <- case o of + (OrdFunction f) -> do + (BoundingBox _ _ w _) <- get + let ts = linspace (round w) (xmin,xmax) + return $ [(ts,mapVector f ts)] + (OrdPoints (Plain o')) -> return $ [(t,o')] + (OrdPoints (Error o' (l,h))) -> return $ [(t,o'),(t,o'-l),(t,o'+h)] + case d of + (DecLine lt) -> do + formatLineSeries lt xscale yscale + mapM_ (\(t',y') -> renderSamples xmin xmax renderLineSample endLineSample t' y') dat + (DecPoint pt) -> do + g <- formatPointSeries pt xscale yscale + let gs = g : Bot : Top : [] + mapM_ (\(g',(t',y')) -> renderSamples xmin xmax (renderPointSample xscale yscale g') endPointSample t' y') (zip gs dat) + (DecLinPt lt pt) -> do + formatLineSeries lt xscale yscale + mapM_ (\(t',y') -> renderSamples xmin xmax renderLineSample endLineSample t' y') dat + g <- formatPointSeries pt xscale yscale + let gs = g : Bot : Top : [] + mapM_ (\(g',(t',y')) -> renderSamples xmin xmax (renderPointSample xscale yscale g') endPointSample t' y') (zip gs dat) + return () + +----------------------------------------------------------------------------- + +formatLineSeries' :: [Dash] -> LineWidth -> Color -> C.Render () +formatLineSeries' ds lw c = do + setDashes ds + C.setLineWidth lw + setColour c + +formatLineSeries :: LineType -> Double -> Double -> Render () +formatLineSeries NoLine _ _ = error "line format of NoLine in a line series" +formatLineSeries (ColourLine c) xscale yscale = do + (LineOptions ds lw) <- asks (_lineoptions . _renderoptions) + cairo $ formatLineSeries' ds ((lw)/(xscale+yscale)) c +formatLineSeries (TypeLine (LineOptions ds lw) c) xscale yscale = cairo $ formatLineSeries' ds ((lw)/(xscale+yscale)) c + +formatPointSeries' :: LineWidth -> Color -> C.Render () +formatPointSeries' lw c = do + C.setLineWidth lw + setColour c + +formatPointSeries :: PointType -> Double -> Double -> Render Glyph +formatPointSeries (FullPoint (PointOptions pz c) g) xscale yscale = do + cairo $ formatPointSeries' ((pz)/((xscale+yscale)/2)) c + return g + + +----------------------------------------------------------------------------- + +renderSamples :: Double -> Double + -> (Double -> Double -> C.Render ()) -> C.Render () + -> Vector Double -> Vector Double -> Render () +renderSamples xmin xmax f e t y = do + (BoundingBox _ _ w _) <- get + let ln = dim t + xmin_ix = findMinIdx t xmin 0 (ln-1) + xmax_ix = findMaxIdx t xmax (ln-1) 0 + num_pts = xmax_ix - xmin_ix + 1 + diff' = (fromIntegral num_pts)/w + diff = round $ if diff' <= 1 then 1 else diff' + cairo $ do + C.moveTo (t @> xmin_ix) (y @> xmin_ix) + _ <- runMaybeT $ mapVectorWithIndexM_ (\i y' -> do + when (i >= xmin_ix && i `mod` diff == 0) + (do + renderSample i xmax_ix t f e y') + return ()) y + return () + +----------------------------------------------------------------------------- + +renderSample :: Int -> Int -> Vector Double + -> (Double -> Double -> C.Render ()) -> C.Render () + -> Double -> MaybeT C.Render () +renderSample ix xmax_ix t f e y + | ix >= xmax_ix = do + lift $ do + f (t @> ix) y + e + fail "end of bounded area" + | otherwise = do + lift $ f (t @> ix) y + +----------------------------------------------------------------------------- + +renderLineSample :: Double -> Double -> C.Render () +renderLineSample = C.lineTo + +endLineSample :: C.Render () +endLineSample = C.stroke + +renderPointSample :: Double -> Double -> Glyph -> Double -> Double -> C.Render () +renderPointSample xscale yscale g x y = do + C.moveTo x y + renderGlyph xscale yscale g + +endPointSample :: C.Render () +endPointSample = return () + +----------------------------------------------------------------------------- + +renderAnnotations :: [Annotation] -> Render () +renderAnnotations _ = return () + +----------------------------------------------------------------------------- + +glyphWidth :: Double +glyphWidth = 2*pi + +renderGlyph :: Double -> Double -> Glyph -> C.Render () +renderGlyph xscale yscale Box = renderGlyphBox xscale yscale +renderGlyph xscale yscale Cross = renderGlyphCross xscale yscale +renderGlyph xscale yscale Diamond = renderGlyphDiamond xscale yscale +renderGlyph xscale yscale Asterisk = renderGlyphAsterisk xscale yscale +renderGlyph xscale yscale Triangle = renderGlyphTriangle xscale yscale +renderGlyph xscale yscale Circle = renderGlyphCircle xscale yscale +renderGlyph xscale yscale Top = renderGlyphTop xscale yscale +renderGlyph xscale yscale Bot = renderGlyphBot xscale yscale +--renderGlyph _ _ _ = return () + +difference :: Num a => [a] -> [a] +difference [] = [] +difference [_] = [] +difference (x0:x1:xs) = (x1-x0):(difference (x1:xs)) + +renderGlyphBox :: Double -> Double -> C.Render () +renderGlyphBox xscale yscale = do + let x = glyphWidth/xscale + y = glyphWidth/yscale + C.relMoveTo (-x/2) (-y/2) + C.relLineTo 0 y + C.relLineTo x 0 + C.relLineTo 0 (-y) + C.closePath + C.stroke + +renderGlyphCross :: Double -> Double -> C.Render () +renderGlyphCross xscale yscale = do + let x = glyphWidth/xscale + y = glyphWidth/yscale + C.relMoveTo (-x/2) 0 + C.relLineTo x 0 + C.relMoveTo (-x/2) (-y/2) + C.relLineTo 0 y + C.closePath + C.stroke + +renderGlyphDiamond :: Double -> Double -> C.Render () +renderGlyphDiamond xscale yscale = do + let x = glyphWidth/xscale + y = glyphWidth/yscale + C.relMoveTo (-x/2) 0 + C.relLineTo (x/2) y + C.relLineTo (x/2) (-y) + C.relLineTo (-x/2) (-y) + C.closePath + C.stroke + +renderGlyphAsterisk :: Double -> Double -> C.Render () +renderGlyphAsterisk xscale yscale = do + let radius = glyphWidth/2 + angles' = map ((+ 90) . (* (360 `div` 5))) [0..4] + angles = map ((* (2*pi/360)) . fromInteger . (`mod` 360)) angles' + xs = map ((* (radius/xscale)) . cos) angles + ys = map ((* (radius/yscale)) . sin) angles + mapM_ (\(x,y) -> do + C.relLineTo x y + C.relMoveTo (-x) (-y)) (zip xs ys) + C.stroke + +renderGlyphTriangle :: Double -> Double -> C.Render () +renderGlyphTriangle xscale yscale = do + let radius = glyphWidth/2 + angles' = [90,210,330] + --angles' = map ((flip (+) 90) . (* (360 `div` 3))) [0..2] + angles = map ((* (2*pi/360)) . fromInteger . (`mod` 360)) angles' + x@(sx:_) = map ((* (radius/xscale)) . cos) angles + y@(sy:_) = map ((* (radius/yscale)) . sin) angles + xs = difference x + ys = difference y + C.relMoveTo sx sy + mapM_ (uncurry C.relLineTo) (zip xs ys) + C.closePath + C.stroke + +renderGlyphCircle :: Double -> Double -> C.Render () +renderGlyphCircle xscale yscale = do + let radius = glyphWidth/2 + angles = map (*(2*pi/36)) [0..35] + x@(sx:_) = map ((* (radius/xscale)) . cos) angles + y@(sy:_) = map ((* (radius/yscale)) . sin) angles + xs = difference x + ys = difference y + C.relMoveTo sx sy + mapM_ (uncurry C.relLineTo) (zip xs ys) + C.closePath + C.stroke + +renderGlyphTop :: Double -> Double -> C.Render () +renderGlyphTop xscale yscale = do + let x = glyphWidth/xscale + y = glyphWidth/yscale + C.relMoveTo (-x/2) 0 + C.relLineTo x 0 + C.relMoveTo (-x/2) 0 + C.relLineTo 0 (-y) + C.stroke + +renderGlyphBot :: Double -> Double -> C.Render () +renderGlyphBot xscale yscale = do + let x = glyphWidth/xscale + y = glyphWidth/yscale + C.relMoveTo (-x/2) 0 + C.relLineTo x 0 + C.relMoveTo (-x/2) 0 + C.relLineTo 0 (y) + C.stroke + + + + + + + +----------------------------------------------------------------------------- + + diff --git a/lib/Graphics/Rendering/Plot/Render/Text.hs b/lib/Graphics/Rendering/Plot/Render/Text.hs new file mode 100644 index 0000000..4f925d0 --- /dev/null +++ b/lib/Graphics/Rendering/Plot/Render/Text.hs @@ -0,0 +1,154 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Plot.Render.Text +-- Copyright : (c) A. V. H. McPhail 2010 +-- License : BSD3 +-- +-- Maintainer : haskell.vivian.mcphail gmail com +-- Stability : provisional +-- Portability : portable +-- +-- Rendering 'Figure's +-- +----------------------------------------------------------------------------- + +module Graphics.Rendering.Plot.Render.Text ( + -- * Rendering + renderText + , renderTextVertical + -- * Internal + , textSize + , textSizeVertical + , showText + , formatText + ) where + +----------------------------------------------------------------------------- + +--import Data.Either + +--import Data.Packed.Vector +--import Numeric.LinearAlgebra.Linear + +--import Data.Word + +--import Data.Maybe + +--import Data.Colour.SRGB +--import Data.Colour.Names + +---import qualified Data.Array.IArray as A + +import qualified Graphics.Rendering.Cairo as C +import qualified Graphics.Rendering.Pango as P + +import Control.Monad.Reader +--import Control.Monad.State +--import Control.Monad.Trans + +import Graphics.Rendering.Plot.Types +--import Graphics.Rendering.Plot.Defaults + +import Graphics.Rendering.Plot.Figure.Text + +import Graphics.Rendering.Plot.Render.Types + +--import qualified Text.Printf as Printf + +--import Prelude hiding(min,max) +--import qualified Prelude(max) + +----------------------------------------------------------------------------- + +textSize :: P.PangoLayout -> TextXAlign -> TextYAlign -> Double -> Double -> C.Render ((Double,Double),(Double,Double)) +textSize l xa ya x y = do + (_,P.PangoRectangle _ _ w h) <- pango $ P.layoutGetExtents l + return ((xStart xa x w h,yStart ya y h h),(w,h)) + where xStart TLeft x' w' _ = x' - w' + xStart Centre x' w' _ = x' - (w'/2) + xStart TRight x' _ _ = x' + yStart TBottom y' _ h' = y' - h' + yStart Middle y' _ h' = y' - (h'/2) + yStart TTop y' _ _ = y' + +textSizeVertical :: P.PangoLayout -> TextXAlign -> TextYAlign -> Double -> Double -> C.Render ((Double,Double),(Double,Double)) +textSizeVertical l xa ya x y = do + (_,P.PangoRectangle _ _ w h) <- pango $ P.layoutGetExtents l + return ((xStart xa x w h,yStart ya y w h),(w,h)) + where xStart TLeft x' _ w' = x' - w' + xStart Centre x' _ w' = x' - (w'/2) + xStart TRight x' _ _ = x' + yStart TBottom y' _ _ = y' + yStart Middle y' h' _ = y' + (h'/2) + yStart TTop y' h' _ = y' + (h') + +showText :: P.PangoLayout -> Double -> Double -> C.Render () +showText pl x y = do + C.moveTo x y + P.showLayout pl + +----------------------------------------------------------------------------- + +formatText :: TextEntry -> Render TextEntry +formatText te@NoText = return te +formatText (BareText s) = do + to <- asks (_textoptions . _renderoptions) + return (FontText to s) +formatText (SizeText fz c s) = do + to <- asks (_textoptions . _renderoptions) + return $ (FontText (changeFontSize fz $ changeFontColour c to) s) +formatText te@(FontText _ _) = return te + +{- +getTextSize :: Text -> Render (Double,Double) +getTextSize (Text Nothing s) = do + to <- asks _text + getTextSize (Text to s) +getTextSize (Text (Just (TextOptions (FontOptions ff fs fw) fz _)) s) = cairo $ do + C.selectFontFace ff fs fw + C.setFontSize fz + te <- C.textExtents s + return (C.textExtentsWidth te,C.textExtentsHeight te) +-} +renderText :: TextEntry -> TextXAlign -> TextYAlign -> Double -> Double -> Render (Double,Double) +renderText NoText _ _ _ _ = return (0,0) +renderText te@(BareText _) xa ya x y = do + te' <- formatText te + renderText te' xa ya x y +renderText te@(SizeText _ _ _) xa ya x y = do + te' <- formatText te + renderText te' xa ya x y +renderText (FontText to s) xa ya x y = do + pc <- asks _pangocontext + cairo $ do + lo <- pango $ P.layoutText pc s + setTextOptions to lo + ((x',y'),twh) <- textSize lo xa ya x y + showText lo x' y' + return twh + +renderTextVertical :: TextEntry -> TextXAlign -> TextYAlign -> Double -> Double -> Render (Double,Double) +renderTextVertical NoText _ _ _ _ = return (0,0) +renderTextVertical (BareText s) xa ya x y = do + to <- asks (_textoptions . _renderoptions) + renderTextVertical (FontText to s) xa ya x y +renderTextVertical (SizeText fz c s) xa ya x y = do + to <- asks (_textoptions . _renderoptions) + renderTextVertical (FontText (changeFontSize fz $ + changeFontColour c to) s) xa ya x y +renderTextVertical (FontText to s) xa ya x y = do + pc <- asks _pangocontext + cairo $ do + lo <- pango $ P.layoutText pc s + setTextOptions to lo + C.moveTo x y + C.save + C.rotate (-pi/2) + --P.updateContext pc + P.updateLayout lo + ((x',y'),twh) <- textSizeVertical lo xa ya x y + showText lo (-y') (-x') + C.restore + return twh + +----------------------------------------------------------------------------- diff --git a/lib/Graphics/Rendering/Plot/Render/Types.hs b/lib/Graphics/Rendering/Plot/Render/Types.hs new file mode 100644 index 0000000..4084723 --- /dev/null +++ b/lib/Graphics/Rendering/Plot/Render/Types.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Plot.Render.Types +-- Copyright : (c) A. V. H. McPhail 2010 +-- License : BSD3 +-- +-- Maintainer : haskell.vivian.mcphail gmail com +-- Stability : provisional +-- Portability : portable +-- +-- Rendering 'Figure's +-- +----------------------------------------------------------------------------- + +module Graphics.Rendering.Plot.Render.Types where + +----------------------------------------------------------------------------- + +--import Data.Either + +--import Data.Packed.Vector +--import Numeric.LinearAlgebra.Linear + +--import Data.Word + +import Data.Maybe + +import Data.Colour.SRGB +import Data.Colour.Names + +--import qualified Data.Array.IArray as A + +import qualified Graphics.Rendering.Cairo as C +import qualified Graphics.Rendering.Pango as P + +import Control.Monad.Reader +import Control.Monad.State +--import Control.Monad.Trans + +import Graphics.Rendering.Plot.Types +import Graphics.Rendering.Plot.Defaults + +--import Graphics.Rendering.Plot.Figure.Text + +--import qualified Text.Printf as Printf + +--import Prelude hiding(min,max) +--import qualified Prelude(max) + +----------------------------------------------------------------------------- +{- +newtype Render a = FR { runRender :: StateT BoundingBox C.Render a } + deriving(Monad, MonadState BoundingBox, MonadTrans (StateT BoundingBox)) +-} + +data RenderEnv = RenderEnv { + _pangocontext :: P.PangoContext + , _renderoptions :: Options + } + +newtype BoundedT m a = BT { runRender :: ReaderT RenderEnv (StateT BoundingBox m) a } + deriving(Monad, MonadState BoundingBox, MonadReader RenderEnv) + +instance MonadTrans BoundedT where + lift m = BT $ lift $ lift m + +type Render = BoundedT C.Render + +evalRender :: Render a -> RenderEnv -> BoundingBox -> C.Render a +evalRender m r = evalStateT (runReaderT (runRender m) r) + +----------------------------------------------------------------------------- + +cairo :: C.Render a -> Render a +cairo = lift + +pango :: IO a -> C.Render a +pango = liftIO + +----------------------------------------------------------------------------- + +bbX, bbY, bbW, bbH :: Render Double +bbX = gets _bbX +bbY = gets _bbY +bbW = gets _bbW +bbH = gets _bbH + +bbLeftWidth, bbCentreWidth, bbRightWidth, bbBottomHeight, bbCentreHeight, bbTopHeight :: Render Double +bbLeftWidth = gets $ \(BoundingBox x _ _ _) -> x +bbCentreWidth = gets $ \(BoundingBox x _ w _) -> x + w / 2 +bbRightWidth = gets $ \(BoundingBox x _ w _) -> x + w +bbBottomHeight = gets $ \(BoundingBox _ y _ h) -> y + h +bbCentreHeight = gets $ \(BoundingBox _ y _ h) -> y + h / 2 +bbTopHeight = gets $ \(BoundingBox _ y _ _) -> y + +bbShiftLeft, bbShiftRight, bbLowerTop, bbRaiseBottom :: Double -> Render () +bbShiftLeft n = modify $ \(BoundingBox x y w h) -> BoundingBox (x+n) y (w-n) h +bbShiftRight n = modify $ \(BoundingBox x y w h) -> BoundingBox x y (w-n) h +bbLowerTop n = modify $ \(BoundingBox x y w h) -> BoundingBox x (y+n) w (h-n) +bbRaiseBottom n = modify $ \(BoundingBox x y w h) -> BoundingBox x y w (h-n) + +applyPads :: Padding -> Render () +applyPads (Padding l r b t) = modify (\(BoundingBox x y w h) -> BoundingBox (x+l) (y+t) (w-l-r) (h-t-b)) + +----------------------------------------------------------------------------- + +clipBoundary :: Render () +clipBoundary = do + (BoundingBox x y w h) <- get + cairo $ do + C.moveTo x y + C.lineTo x (y+h) + C.lineTo (x+w) (y+h) + C.lineTo (x+w) y + C.closePath + C.clip + +----------------------------------------------------------------------------- + +-- | output file type +data OutputType = PNG | PS | PDF | SVG + +----------------------------------------------------------------------------- + +setColour :: Color -> C.Render () +setColour c = let (RGB r g b) = toSRGB c + in C.setSourceRGB r g b + + +setDashes :: [Dash] -> C.Render () +setDashes [] = C.setDash [] 0 +setDashes xs = do + let xs' = concat $ map (\d -> case d of { Dot -> [0.2,0.3] ; Dash -> [0.6,0.3] }) xs + C.setDash xs' 0 + +----------------------------------------------------------------------------- + +getDefaultTextOptions :: P.PangoContext -> C.Render TextOptions +getDefaultTextOptions pc = do + fd <- pango $ P.contextGetFontDescription pc + getTextOptionsFD fd + +getTextOptionsFD :: P.FontDescription -> C.Render TextOptions +getTextOptionsFD fd = do + ff' <- pango $ P.fontDescriptionGetFamily fd + fs' <- pango $ P.fontDescriptionGetStyle fd + fv' <- pango $ P.fontDescriptionGetVariant fd + fw' <- pango $ P.fontDescriptionGetWeight fd + fc' <- pango $ P.fontDescriptionGetStretch fd + fz' <- pango $ P.fontDescriptionGetSize fd + let ff = fromMaybe defaultFontFamily ff' + fs = fromMaybe defaultFontStyle fs' + fv = fromMaybe defaultFontVariant fv' + fw = fromMaybe defaultFontWeight fw' + fc = fromMaybe defaultFontStretch fc' + fz = fromMaybe defaultFontSize fz' + return $ TextOptions (FontOptions ff fs fv fw fc) fz black + +setTextOptions :: TextOptions -> P.PangoLayout -> C.Render () +setTextOptions to lo = do + fd' <- pango $ P.layoutGetFontDescription lo + fd <- case fd' of + Nothing -> pango $ P.fontDescriptionNew + Just fd'' -> return fd'' + setTextOptionsFD to fd + pango $ P.layoutSetFontDescription lo (Just fd) + +setTextOptionsFD :: TextOptions -> P.FontDescription -> C.Render () +setTextOptionsFD (TextOptions (FontOptions ff fs fv fw fc) fz c) fd = do + pango $ do + P.fontDescriptionSetFamily fd ff + P.fontDescriptionSetStyle fd fs + P.fontDescriptionSetVariant fd fv + P.fontDescriptionSetWeight fd fw + P.fontDescriptionSetStretch fd fc + P.fontDescriptionSetSize fd fz + setColour c + +----------------------------------------------------------------------------- + +textPad :: Double +textPad = 2 + +data TextXAlign = TLeft | Centre | TRight +data TextYAlign = TBottom | Middle | TTop + +----------------------------------------------------------------------------- + + diff --git a/lib/Graphics/Rendering/Plot/Types.hs b/lib/Graphics/Rendering/Plot/Types.hs new file mode 100644 index 0000000..84b5c0a --- /dev/null +++ b/lib/Graphics/Rendering/Plot/Types.hs @@ -0,0 +1,367 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Plot.Types +-- Copyright : (c) A. V. H. McPhail 2010 +-- License : BSD3 +-- +-- Maintainer : haskell.vivian.mcphail gmail com +-- Stability : provisional +-- Portability : portable +-- +-- Types +-- +----------------------------------------------------------------------------- + +module Graphics.Rendering.Plot.Types where + +----------------------------------------------------------------------------- + +import Data.Packed.Vector + +import Data.Colour.SRGB +import Data.Colour() + +import qualified Data.Array.IArray as A + +import qualified Graphics.Rendering.Pango as P + +import Control.Monad.State +import Control.Monad.Reader + +import Control.Monad.Supply + +----------------------------------------------------------------------------- +----------------------------------------------------------------------------- +----------------------------------------------------------------------------- + +type Color = Colour Double + +----------------------------------------------------------------------------- + +-- x,y,w,h +data BoundingBox = BoundingBox { _bbX :: Double, _bbY :: Double + , _bbW :: Double, _bbH :: Double } + +----------------------------------------------------------------------------- + +type FontFamily = String +type FontSize = Double +data FontOptions = FontOptions FontFamily P.FontStyle P.Variant P.Weight P.Stretch +data TextOptions = TextOptions FontOptions FontSize Color +data TextEntry = NoText + | BareText String + | SizeText FontSize Color String + | FontText TextOptions String + +----------------------------------------------------------------------------- + +newtype Text a = FT { runText :: ReaderT TextOptions (State TextEntry) a} + deriving(Monad, MonadReader TextOptions, MonadState TextEntry) + +execText :: Text a -> TextOptions -> TextEntry -> TextEntry +execText m r = execState (runReaderT (runText m) r) + +----------------------------------------------------------------------------- + +type Solid = Bool + +type PointSize = Double +data Glyph = Box | Cross | Diamond | Asterisk | Triangle | Circle | Top | Bot + deriving(Show) +--data GlyphType = Glyph Glyph Solid +data PointOptions = PointOptions PointSize Color + deriving(Show) +data PointType = FullPoint PointOptions Glyph + deriving(Show) + +----------------------------------------------------------------------------- + +newtype Point a = FG { runPoint :: ReaderT PointOptions (State PointType) a} + deriving(Monad, MonadReader PointOptions, MonadState PointType) + +execPoint :: Point a -> PointOptions -> PointType -> PointType +execPoint m r = execState (runReaderT (runPoint m) r) + +----------------------------------------------------------------------------- + +data Dash = Dot | Dash + deriving(Show) +type DashStyle = [Dash] +type LineWidth = Double +-- not using line join +-- not using line cap +-- do we want arrows? +data LineOptions = LineOptions DashStyle LineWidth + deriving(Show) + +data LineType = NoLine + | ColourLine Color + | TypeLine LineOptions Color + deriving(Show) + +----------------------------------------------------------------------------- + +newtype Line a = FL { runLine :: ReaderT LineOptions (State LineType) a} + deriving(Monad, MonadReader LineOptions, MonadState LineType) + +execLine :: Line a -> LineOptions -> LineType -> LineType +execLine m r = execState (runReaderT (runLine m) r) + +----------------------------------------------------------------------------- + +type Length = Double +type Location = (Double,Double) +type Orientation = Double -- angle +type Arrow = Bool + +-- extra glyphs and so on that can be put in a chart +data AnnoteType = AT_Text TextEntry + | AT_Glyph Glyph + | AT_Arrow Arrow LineOptions Length + +data Annotation = Annotation AnnoteType Location Orientation Color +type Annotations = [Annotation] + +----------------------------------------------------------------------------- + +data Range = Range { _range_min :: Double, _range_max :: Double } + +data Ranges = Ranges (Either Range (Range,Range)) (Either Range (Range,Range)) + +defaultRanges :: Double -> Double -> Double -> Double -> Ranges +defaultRanges xmin xmax ymin ymax = Ranges (Left (Range xmin xmax)) (Left (Range ymin ymax)) + +----------------------------------------------------------------------------- + +data AxisType = XAxis | YAxis deriving(Eq) +data AxisSide = Lower | Upper deriving(Eq) +data AxisPosn = Side AxisSide + | Value Double + deriving(Eq) + +data Tick = Minor | Major deriving(Eq) + +type GridLines = Bool +type TickValues = Either Int (Vector Double) -- ^ Either (number of ticks) (tick values) +data Ticks = Ticks GridLines TickValues + +type TickFormat = String + +data AxisData = Axis { + _axis_type :: AxisType + , _position :: AxisPosn + , _line_type :: LineType + , _minor_ticks :: Ticks + , _major_ticks :: Ticks + , _tick_format :: TickFormat + , _label :: TextEntry + } +-- want line styles, so that, e.g., axes in centre of chart are grey or dashed etc. + +----------------------------------------------------------------------------- + +newtype Axis a = FA { runAxis :: ReaderT Options (State AxisData) a} + deriving(Monad, MonadReader Options, MonadState AxisData) + +execAxis :: Axis a -> Options -> AxisData -> AxisData +execAxis m r = execState (runReaderT (runAxis m) r) + +----------------------------------------------------------------------------- + +-- need to have same number of entries as data series +data Legend = Legend { + _bounded :: Bool -- is there a box around the legend? + , _location :: Location + , _labels :: (A.Array Int TextEntry) + } +-- do we want a toggle for legends so the labels don't get destroyed? + +----------------------------------------------------------------------------- + +-- simply padding for left, right, bottom, and top +data Padding = Padding Double Double Double Double + +----------------------------------------------------------------------------- + +data Options = Options { + _lineoptions :: LineOptions + , _pointoptions :: PointOptions + , _textoptions :: TextOptions + } + +----------------------------------------------------------------------------- +{- +data LineFormat = LineFormat +data PointFormat = PointFormat +-} +data SeriesType = Line | Point | LinePoint -- Impulse + +----------------------------------------------------------------------------- + +type Series = Vector Double +type ErrorSeries = Series +type Function = (Double -> Double) + +instance Show Function where show _ = "<>" + +data OrdSeries = Plain Series + | Error Series (ErrorSeries,ErrorSeries) + deriving(Show) + +getOrdData :: OrdSeries -> Series +getOrdData (Plain o) = o +getOrdData (Error o _) = o + +data Abscissae = AbsFunction + | AbsPoints Series + deriving(Show) + +data Ordinates = OrdFunction Function + | OrdPoints OrdSeries + deriving(Show) + +data Decoration = DecLine LineType + | DecPoint PointType + | DecLinPt LineType PointType + deriving(Show) + +data DecoratedSeries = DecSeries Ordinates Decoration + deriving(Show) +-- BarSeries Abscissae Ordinates BarType + +data DataSeries = DS_Y (A.Array Int DecoratedSeries) + | DS_1toN Abscissae (A.Array Int DecoratedSeries) + | DS_1to1 (A.Array Int (Abscissae,DecoratedSeries)) + deriving(Show) + +----------------------------------------------------------------------------- + +newtype Data a = FD { runData :: SupplyT SupplyData (ReaderT Options (State DataSeries)) a } + deriving(Monad, MonadSupply SupplyData, MonadReader Options, MonadState DataSeries) + +execData :: Data a -> SupplyData -> Options -> DataSeries -> DataSeries +execData m r s = execState (runReaderT (runSupplyT (runData m) r) s) + + +type FormattedSeries = Data DecoratedSeries + +----------------------------------------------------------------------------- + +data PlotType = Linear -- LogLinear | LinearLog | Log + +--data PlotType = PT_Line + +----------------------------------------------------------------------------- + +type Border = Bool + +----------------------------------------------------------------------------- + +data SupplyData = SupplyData { + _colours :: [Color] + , _glyphs :: [Glyph] + } + +instance Supply SupplyData Color where + nextSupply (SupplyData [] _ ) = error "Empty supply" + nextSupply (SupplyData (c:cs) gs) = (c,SupplyData cs gs) +instance Supply SupplyData Glyph where + nextSupply (SupplyData _ []) = error "Empty supply" + nextSupply (SupplyData cs (g:gs)) = (g,SupplyData cs gs) + +----------------------------------------------------------------------------- + +-- | a plot +data PlotData = Plot { + _border :: Border + , _plot_pads :: Padding + , _heading :: TextEntry + , _ranges :: Ranges + , _axes :: [AxisData] + , _type :: PlotType + , _data :: DataSeries + , _legend :: Maybe Legend + , _annote :: Annotations + } + +----------------------------------------------------------------------------- + +type Plots = A.Array (Int,Int) (Maybe PlotData) + +----------------------------------------------------------------------------- + +newtype Plot a = FP { runPlot :: SupplyT SupplyData (ReaderT Options (State PlotData)) a } + deriving(Monad, MonadReader Options, MonadSupply SupplyData, MonadState PlotData) + +execPlot :: Plot a -> SupplyData -> Options -> PlotData -> PlotData +execPlot m s r = execState (runReaderT (runSupplyT (runPlot m) s) r) + +----------------------------------------------------------------------------- + +dataInPlot' :: State DataSeries a -> State PlotData a +dataInPlot' m = State $ \s -> let (a,d') = runState m (_data s) + in (a,s { _data = d'}) + +dataInPlot :: Data a -> Plot a +dataInPlot m = FP $ mapSupplyT (mapReaderT dataInPlot') (runData m) + +----------------------------------------------------------------------------- + +-- | a chart has a title and contains one or more plots +data FigureData = Figure { + _fig_pads :: Padding + , _title :: TextEntry + , _subtitle :: TextEntry + , _plots :: Plots + } + +----------------------------------------------------------------------------- + +data FigureState = FigureState { + _defaults :: Options + , _supplies :: SupplyData + , _figure :: FigureData + } + +newtype Figure a = FC { runFigure :: State FigureState a } + deriving(Monad, MonadState FigureState) + +----------------------------------------------------------------------------- + +execFigure :: Figure a -> FigureState -> FigureState +execFigure g = execState (runFigure g) + +getFigure :: Figure FigureData +getFigure = gets _figure + +getDefaults :: Figure Options +getDefaults = gets _defaults + +getSupplies :: Figure SupplyData +getSupplies = gets _supplies + +putFigure :: FigureData -> Figure () +putFigure p = modify $ \s -> s { _figure = p } + +putDefaults :: Options -> Figure () +putDefaults p = modify $ \s -> s { _defaults = p } + +putSupplies :: SupplyData -> Figure () +putSupplies p = modify $ \s -> s { _supplies = p } + +modifyFigure :: (FigureData -> FigureData) -> Figure () +modifyFigure m = modify $ \s -> s { _figure = m (_figure s) } + +modifyDefaults :: (Options -> Options) -> Figure () +modifyDefaults m = modify $ \s -> s { _defaults = m (_defaults s) } + +----------------------------------------------------------------------------- +{-TODO + * eeglab-like data offset in channels up x-axis +-} +----------------------------------------------------------------------------- diff --git a/lib/Test.hs b/lib/Test.hs new file mode 100644 index 0000000..c401846 --- /dev/null +++ b/lib/Test.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE OverlappingInstances #-} +-- thanks to http://www.muitovar.com/gtk2hs/app1.html + +--module Test where + +import Control.Concurrent +import Control.Concurrent.MVar + +import Control.Monad.Trans + +import Graphics.UI.Gtk hiding(Circle,Cross) +import qualified Graphics.Rendering.Cairo as C +import qualified Graphics.Rendering.Pango as P + +import Data.Colour.Names + +import Data.Packed.Vector +--import Data.Packed.Random +import Data.Packed() + +import qualified Data.Array.IArray as A + +import Numeric.LinearAlgebra.Linear +--import Numeric.LinearAlgebra.Instances +--import Numeric.LinearAlgebra.Interface + +import Numeric.GSL.Statistics + +import Graphics.Rendering.Plot + +import Debug.Trace + +ln = 25 +ts = linspace ln (0,1) +rs = ln |> take ln [0.306399512330476,-0.4243863460546792,-0.20454667402138094,-0.42873761654774106,1.3054721019673694,0.6474765138733175,1.1942346875362946,-1.7404737823144103,0.2607101951530985,-0.26782584645524893,-0.31403631431884504,3.365508546473985e-2,0.6147856889630383,-1.191723225061435,-1.9933460981205509,0.6015225906539229,0.6394073044477114,-0.6030919788928317,0.1832742199706381,0.35532918011648473,0.1982646055874545,1.7928383756822786,-9.992760294442601e-2,-1.401166614128362,-1.1088031929569364,-0.827319908453775,1.0406363628775428,-0.3070345979284644,0.6781735212645198,-0.8431706723519456,-0.4245730055085966,-0.6503687925251668,-1.4775567962221399,0.5587634921497298,-0.6481020127107823,7.313441602898768e-2,0.573580543636529,-0.9036472376122673,2.650805059813826,9.329324044673039e-2,1.9133487025468563,-1.5366337588254542,-1.0159359710920388,7.95982933517428e-2,0.5813673663649735,-6.93329631989878e-2,1.1024137719307867,-0.6046286796589855,-0.8812842030098401,1.4612246471009083,0.9584060744500491,9.210899579679932e-2,-0.15850413664405813,-0.4754694827227343,0.8669922262489788,0.4593351854708853,-0.2015350278936992,0.8829710664887649,0.7195048491420026] + +ss = sin (15*2*pi*ts) +ds = 0.25*rs + ss +es = constant (0.25*(stddev rs)) ln + +fs :: Double -> Double +fs = sin . (15*2*pi*) + +figure = do + withTextDefaults $ setFontFamily "OpenSymbol" + withTitle $ setText "Testing plot package:" + withSubTitle $ do + setText "with 1 second of a 15Hz sine wave" + setFontSize 10 + setPlots 1 1 + withPlot (1,1) $ do + setDataset (ts,[point (ds,es) (Cross,red),line fs blue]) + addAxis XAxis (Side Lower) $ withAxisLabel $ setText "time (s)" + addAxis YAxis (Side Lower) $ withAxisLabel $ setText "amplitude" + addAxis XAxis (Value 0) $ return () + setRangeFromData XAxis Lower + setRange YAxis Lower (-1.25) 1.25 + +display :: ((Int,Int) -> C.Render ()) -> IO () +display r = do + initGUI -- is start + + window <- windowNew + set window [ windowTitle := "Cairo test window" + , windowDefaultWidth := 400 + , windowDefaultHeight := 300 + , containerBorderWidth := 1 + ] + +-- canvas <- pixbufNew ColorspaceRgb True 8 300 200 +-- containerAdd window canvas + frame <- frameNew + containerAdd window frame + canvas <- drawingAreaNew + containerAdd frame canvas + widgetModifyBg canvas StateNormal (Color 65535 65535 65535) + + widgetShowAll window + + on canvas exposeEvent $ tryEvent $ do s <- liftIO $ widgetGetSize canvas + drw <- liftIO $ widgetGetDrawWindow canvas + --dat <- liftIO $ takeMVar d + --liftIO $ renderWithDrawable drw (circle 50 10) + liftIO $ renderWithDrawable drw (r s) + + onDestroy window mainQuit + mainGUI + + +main = display $ render figure + +test = writeFigure PDF "test.pdf" (400,400) figure \ No newline at end of file diff --git a/plot.cabal b/plot.cabal new file mode 100644 index 0000000..de82fff --- /dev/null +++ b/plot.cabal @@ -0,0 +1,88 @@ +Name: plot +Version: 0.1 +License: BSD3 +License-file: LICENSE +Copyright: (c) A.V.H. McPhail 2010 +Author: Vivian McPhail +Maintainer: haskell.vivian.mcphail gmail com +Stability: experimental +Homepage: http://code.haskell.org/plot +Synopsis: A library for creating plots, exportable as eps/pdf/svg/png or renderable with gtk +Description: + A package for creating plots, built on top of the Cairo rendering engine. + . + An ambitious attempt to replace gnuplot. + . + Monadic actions are used to configure a figure, which is a (rxc) array of subplots. + Each plot displays a graph with optional heading, labels, legend, and annotations. + The annotations themselves may be used to draw diagrams. + . + A figure is preprocessed in preparation for rendering by the Cairo renderer. + The Cairo library can be used to output the figure to PS, PDF, SVG, and PNG file formats, + or to display the figure in a GTK Drawable context. (see package 'plot-gtk'). + . + The preprocessed figure can be embedded as an arbitrary Cairo render, including in a diagram + created with the diagram package. Conversely, arbitrary Cairo renders can be embedded in + the data region of a 'Figure'. + . + The data series are type "Data.Packed.Vector" from hmatrix, which, when hmatrix + is compiled with '-fvector', is a synonym for "Data.Vector.Storable" from the + vector package and are thus compatible with packages such as statistics. + . + The example in Graphics.Rendering.Plot can be viewed at + + + +Category: Graphics + +Tested-with: GHC==6.12.1 +Cabal-version: >= 1.8 +Build-type: Simple + +Extra-source-files: README, CHANGES, LICENSE, + examples/perturbed-sine.hs, + examples/perturbed-sine.png + +library + + Build-Depends: base >= 4 && < 5, + mtl, array, + MaybeT, + pango >= 0.11.2 && < 0.12, cairo >= 0.11.1 && < 0.12, + colour >= 2.2.1 && < 2.4, + hmatrix >= 0.10 + + Extensions: MultiParamTypeClasses + GeneralizedNewtypeDeriving + TypeSynonymInstances + FlexibleInstances + FlexibleContexts + UndecidableInstances + + hs-source-dirs: lib + Exposed-Modules: Graphics.Rendering.Plot + Graphics.Rendering.Plot.Figure + Graphics.Rendering.Plot.Render + + Other-modules: Graphics.Rendering.Plot.Types + Graphics.Rendering.Plot.Defaults + Graphics.Rendering.Plot.Figure.Line + Graphics.Rendering.Plot.Figure.Point + Graphics.Rendering.Plot.Figure.Text + Graphics.Rendering.Plot.Figure.Plot + Graphics.Rendering.Plot.Figure.Plot.Axis + Graphics.Rendering.Plot.Figure.Plot.Data + Graphics.Rendering.Plot.Render.Types + Graphics.Rendering.Plot.Render.Text + Graphics.Rendering.Plot.Render.Plot + Graphics.Rendering.Plot.Render.Plot.Axis + Graphics.Rendering.Plot.Render.Plot.Data + Control.Monad.Supply + + ghc-options: -Wall -fno-warn-unused-binds + + ghc-prof-options: -auto + + source-repository head + type: darcs + location: darcs get http://code.haskell.org/plot