mirror of
https://github.com/codedownio/haskell-plot.git
synced 2025-04-14 10:26:10 +00:00
initial repository
darcs-hash:20100901145450-af16d-11f5ac7750d938d81276e005e7b4a63d27620fb0.gz
This commit is contained in:
Vivian McPhail
commit
45a55dbc5e
27
LICENSE
Normal file
27
LICENSE
Normal file
@ -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.
|
||||
65
README
Normal file
65
README
Normal file
@ -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.
|
||||
3
Setup.lhs
Executable file
3
Setup.lhs
Executable file
@ -0,0 +1,3 @@
|
||||
#!/usr/bin/env runhaskell
|
||||
> import Distribution.Simple
|
||||
> main = defaultMain
|
||||
12
TODO
Normal file
12
TODO
Normal file
@ -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
|
||||
92
examples/perturbed-sine.hs
Normal file
92
examples/perturbed-sine.hs
Normal file
@ -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
|
||||
BIN
examples/perturbed-sine.png
Normal file
BIN
examples/perturbed-sine.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 37 KiB |
116
lib/Control/Monad/Supply.hs
Normal file
116
lib/Control/Monad/Supply.hs
Normal file
@ -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 <at> gmail <dot> 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)
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
73
lib/Graphics/Rendering/Plot.hs
Normal file
73
lib/Graphics/Rendering/Plot.hs
Normal file
@ -0,0 +1,73 @@
|
||||
-----------------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Graphics.Rendering.Plot
|
||||
-- Copyright : (c) A. V. H. McPhail 2010
|
||||
-- License : BSD3
|
||||
--
|
||||
-- Maintainer : haskell.vivian.mcphail <at> gmail <dot> 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
|
||||
|
||||
-}
|
||||
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
177
lib/Graphics/Rendering/Plot/Defaults.hs
Normal file
177
lib/Graphics/Rendering/Plot/Defaults.hs
Normal file
@ -0,0 +1,177 @@
|
||||
-----------------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Graphics.Rendering.Plot.Defaults
|
||||
-- Copyright : (c) A. V. H. McPhail 2010
|
||||
-- License : BSD3
|
||||
--
|
||||
-- Maintainer : haskell.vivian.mcphail <at> gmail <dot> 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
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
231
lib/Graphics/Rendering/Plot/Figure.hs
Normal file
231
lib/Graphics/Rendering/Plot/Figure.hs
Normal file
@ -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 <at> gmail <dot> com
|
||||
-- Stability : provisional
|
||||
-- Portability : portable
|
||||
--
|
||||
-- Creation and manipulation of 'Figure's
|
||||
--
|
||||
-- The same problem of leaked instances as at <http://hackage.haskell.org/packages/archive/graphviz/2999.10.0.1/doc/html/Data-GraphViz-Commands.html#t%3AGraphvizCanvas> 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) }
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
136
lib/Graphics/Rendering/Plot/Figure/Line.hs
Normal file
136
lib/Graphics/Rendering/Plot/Figure/Line.hs
Normal file
@ -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 <at> gmail <dot> 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
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
215
lib/Graphics/Rendering/Plot/Figure/Plot.hs
Normal file
215
lib/Graphics/Rendering/Plot/Figure/Plot.hs
Normal file
@ -0,0 +1,215 @@
|
||||
-----------------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Graphics.Rendering.Plot.Figure.Plot
|
||||
-- Copyright : (c) A. V. H. McPhail 2010
|
||||
-- License : BSD3
|
||||
--
|
||||
-- Maintainer : haskell.vivian.mcphail <at> gmail <dot> 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)
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
76
lib/Graphics/Rendering/Plot/Figure/Plot/Axis.hs
Normal file
76
lib/Graphics/Rendering/Plot/Figure/Plot/Axis.hs
Normal file
@ -0,0 +1,76 @@
|
||||
-----------------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Graphics.Rendering.Plot.Figure.Plot.Axis
|
||||
-- Copyright : (c) A. V. H. McPhail 2010
|
||||
-- License : BSD3
|
||||
--
|
||||
-- Maintainer : haskell.vivian.mcphail <at> gmail <dot> 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) }
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
397
lib/Graphics/Rendering/Plot/Figure/Plot/Data.hs
Normal file
397
lib/Graphics/Rendering/Plot/Figure/Plot/Data.hs
Normal file
@ -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 <at> gmail <dot> 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
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
119
lib/Graphics/Rendering/Plot/Figure/Point.hs
Normal file
119
lib/Graphics/Rendering/Plot/Figure/Point.hs
Normal file
@ -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 <at> gmail <dot> 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?
|
||||
-}
|
||||
|
||||
|
||||
181
lib/Graphics/Rendering/Plot/Figure/Text.hs
Normal file
181
lib/Graphics/Rendering/Plot/Figure/Text.hs
Normal file
@ -0,0 +1,181 @@
|
||||
-----------------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Graphics.Rendering.Plot.Figure.Text
|
||||
-- Copyright : (c) A. V. H. McPhail 2010
|
||||
-- License : BSD3
|
||||
--
|
||||
-- Maintainer : haskell.vivian.mcphail <at> gmail <dot> 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
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
|
||||
129
lib/Graphics/Rendering/Plot/Render.hs
Normal file
129
lib/Graphics/Rendering/Plot/Render.hs
Normal file
@ -0,0 +1,129 @@
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
-----------------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Graphics.Rendering.Plot.Render
|
||||
-- Copyright : (c) A. V. H. McPhail 2010
|
||||
-- License : BSD3
|
||||
--
|
||||
-- Maintainer : haskell.vivian.mcphail <at> gmail <dot> 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
|
||||
|
||||
127
lib/Graphics/Rendering/Plot/Render/Plot.hs
Normal file
127
lib/Graphics/Rendering/Plot/Render/Plot.hs
Normal file
@ -0,0 +1,127 @@
|
||||
-----------------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Graphics.Rendering.Plot.Render.Plot
|
||||
-- Copyright : (c) A. V. H. McPhail 2010
|
||||
-- License : BSD3
|
||||
--
|
||||
-- Maintainer : haskell.vivian.mcphail <at> gmail <dot> 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 ()
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
398
lib/Graphics/Rendering/Plot/Render/Plot/Axis.hs
Normal file
398
lib/Graphics/Rendering/Plot/Render/Plot/Axis.hs
Normal file
@ -0,0 +1,398 @@
|
||||
-----------------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Graphics.Rendering.Plot.Render.Plot.Axis
|
||||
-- Copyright : (c) A. V. H. McPhail 2010
|
||||
-- License : BSD3
|
||||
--
|
||||
-- Maintainer : haskell.vivian.mcphail <at> gmail <dot> 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 ()
|
||||
|
||||
327
lib/Graphics/Rendering/Plot/Render/Plot/Data.hs
Normal file
327
lib/Graphics/Rendering/Plot/Render/Plot/Data.hs
Normal file
@ -0,0 +1,327 @@
|
||||
-----------------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Graphics.Rendering.Plot.Render.Plot.Data
|
||||
-- Copyright : (c) A. V. H. McPhail 2010
|
||||
-- License : BSD3
|
||||
--
|
||||
-- Maintainer : haskell.vivian.mcphail <at> gmail <dot> 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
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
|
||||
154
lib/Graphics/Rendering/Plot/Render/Text.hs
Normal file
154
lib/Graphics/Rendering/Plot/Render/Text.hs
Normal file
@ -0,0 +1,154 @@
|
||||
-----------------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Graphics.Rendering.Plot.Render.Text
|
||||
-- Copyright : (c) A. V. H. McPhail 2010
|
||||
-- License : BSD3
|
||||
--
|
||||
-- Maintainer : haskell.vivian.mcphail <at> gmail <dot> 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
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
190
lib/Graphics/Rendering/Plot/Render/Types.hs
Normal file
190
lib/Graphics/Rendering/Plot/Render/Types.hs
Normal file
@ -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 <at> gmail <dot> 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
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
|
||||
367
lib/Graphics/Rendering/Plot/Types.hs
Normal file
367
lib/Graphics/Rendering/Plot/Types.hs
Normal file
@ -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 <at> gmail <dot> 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 _ = "<<function>>"
|
||||
|
||||
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
|
||||
-}
|
||||
-----------------------------------------------------------------------------
|
||||
92
lib/Test.hs
Normal file
92
lib/Test.hs
Normal file
@ -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
|
||||
88
plot.cabal
Normal file
88
plot.cabal
Normal file
@ -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 <at> gmail <dot> 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
|
||||
<http://code.haskell.org/plot/examples/perturbed-sine.png>
|
||||
|
||||
|
||||
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
|
||||
Loading…
x
Reference in New Issue
Block a user