diff --git a/Chart.cabal b/Chart.cabal --- a/Chart.cabal +++ b/Chart.cabal @@ -1,6 +1,6 @@ Name: Chart -Version: 0.5 -License: BSD4 +Version: 0.6 +License: BSD3 License-file: LICENSE Copyright: Tim Docker, 2006 Author: Tim Docker @@ -10,6 +10,7 @@ Description: A library for generating 2D Charts and Plots, based upon the cairo graphics library. Category: Graphics Cabal-Version: >= 1.2 +Build-Type: Simple Extra-Source-Files: tests/test.hs, tests/Prices.hs @@ -31,4 +32,5 @@ Graphics.Rendering.Chart.Axis, Graphics.Rendering.Chart.Layout, Graphics.Rendering.Chart.Plot + Graphics.Rendering.Chart.Simple diff --git a/Graphics/Rendering/Chart.hs b/Graphics/Rendering/Chart.hs --- a/Graphics/Rendering/Chart.hs +++ b/Graphics/Rendering/Chart.hs @@ -4,7 +4,7 @@ -- Copyright : (c) Tim Docker 2006 -- License : BSD-style (see chart/COPYRIGHT) -- --- A Simple framework for creating 2D charts in Haskell. +-- A framework for creating 2D charts in Haskell. -- -- The basic model is that you define a value of type 'Renderable', -- typically by applying 'toRenderable' to some other value. This @@ -14,6 +14,9 @@ -- Currently, the only useful 'Renderable' for displaying charts -- is created by applying 'toRenderable' to a value of type -- 'Graphics.Rendering.Chart.Layout.Layout1' +-- +-- For a simpler though less flexible API, see "Graphics.Rendering.Chart.Simple". +-- ----------------------------------------------------------------------------- module Graphics.Rendering.Chart( @@ -38,6 +41,10 @@ defaultPlotFillBetween, defaultLayout1, filledCircles, + hollowCircles, + exes, plusses, stars, + filledPolygon, + hollowPolygon, solidLine, dashedLine, solidFillStyle, diff --git a/Graphics/Rendering/Chart/Axis.hs b/Graphics/Rendering/Chart/Axis.hs --- a/Graphics/Rendering/Chart/Axis.hs +++ b/Graphics/Rendering/Chart/Axis.hs @@ -22,6 +22,10 @@ -- cordinates. axis_viewport :: Range -> Double -> Double, + -- | The title string to be displayed on the axis. An + -- empty string means no title. + axis_title :: String, + -- | The tick marks on the axis as pairs. -- The first element is the position on the axis -- (in viewport units) and the second element is the @@ -42,6 +46,7 @@ -- | How far the labels are to be drawn from the axis. axis_label_gap :: Double, + axis_title_style :: CairoFontStyle, axis_line_style :: CairoLineStyle, axis_label_style :: CairoFontStyle, axis_grid_style :: CairoLineStyle @@ -153,8 +158,8 @@ mapy :: Range -> Double -> Double -> Point mapy (yr0,yr1) x y = Point x (axis_viewport a (yr1,yr0) y) -renderAxisGrid :: AxisT -> Rect -> C.Render () -renderAxisGrid at@(AxisT re a) rect@(Rect p1 p2) = do +renderAxisGrid :: Rect -> AxisT -> C.Render () +renderAxisGrid rect@(Rect p1 p2) at@(AxisT re a) = do C.save setLineStyle (axis_grid_style a) mapM_ (drawGridLine re) (axis_grid a) @@ -330,7 +335,7 @@ linkedAxes' af pts1 pts2 = (a,removeLabels a) where a = af (pts1++pts2) - removeLabels = liftM (\a -> a{axis_labels = []}) + removeLabels = liftM (\a -> a{axis_title="",axis_labels = []}) ---------------------------------------------------------------------- @@ -339,10 +344,12 @@ defaultAxis = Axis { axis_viewport = vmap (0,1), + axis_title = "", axis_ticks = [(0,10),(1,10)], axis_labels = [], axis_grid = [0.0,0.5,1.0], - axis_label_gap =10, + axis_label_gap = 10, + axis_title_style = defaultFontStyle, axis_line_style = defaultAxisLineStyle, axis_label_style = defaultFontStyle, axis_grid_style = defaultGridLineStyle diff --git a/Graphics/Rendering/Chart/Gtk.hs b/Graphics/Rendering/Chart/Gtk.hs --- a/Graphics/Rendering/Chart/Gtk.hs +++ b/Graphics/Rendering/Chart/Gtk.hs @@ -15,7 +15,8 @@ renderableToWindow :: Renderable -> Int -> Int -> IO () renderableToWindow chart windowWidth windowHeight = do - G.initGUI + G.unsafeInitGUIForThreadedRTS + -- G.initGUI window <- G.windowNew canvas <- G.drawingAreaNew -- fix size diff --git a/Graphics/Rendering/Chart/Layout.hs b/Graphics/Rendering/Chart/Layout.hs --- a/Graphics/Rendering/Chart/Layout.hs +++ b/Graphics/Rendering/Chart/Layout.hs @@ -12,6 +12,7 @@ import Graphics.Rendering.Chart.Types import Graphics.Rendering.Chart.Plot import Graphics.Rendering.Chart.Renderable +import Control.Monad data HAxis = HA_Top | HA_Bottom deriving (Eq) data VAxis = VA_Left | VA_Right deriving (Eq) @@ -33,72 +34,72 @@ toRenderable = layout1ToRenderable layout1ToRenderable l = - fillBackground (layout1_background l) ( - vertical [ - (0, addMargins (lm/2,0,0,0) (mkTitle l)), - (1, addMargins (lm/2,lm,lm,lm) (plotArea l)), - (0, horizontal [ (0, mkLegend VA_Left l), (1,emptyRenderable), (0, mkLegend VA_Right l) ] ) - ] - ) + fillBackground (layout1_background l) ( + vertical [ + (0, addMargins (lm/2,0,0,0) title), + (1, addMargins (lm,lm,lm,lm) plotArea), + (0, horizontal [ (0,mkLegend VA_Left),(1,emptyRenderable),(0, mkLegend VA_Right) ] ) + ] + ) where lm = layout1_margin l - mkTitle l = label (layout1_title_style l) HTA_Centre VTA_Centre (layout1_title l) + title = label (layout1_title_style l) HTA_Centre VTA_Centre (layout1_title l) - mkLegend va l = case (layout1_legend l) of + mkLegend va = case (layout1_legend l) of Nothing -> emptyRenderable (Just ls) -> case [(s,p) | (s,_,va',p) <- layout1_plots l, va' == va, not (null s)] of [] -> emptyRenderable ps -> addMargins (0,lm,lm,0) (toRenderable (Legend True ls ps)) - - plotArea l = Renderable { - minsize=minsizePlotArea l, - render=renderPlotArea l - } -minsizePlotArea l = do - (w1,h1,w2,h2) <- axisSizes l - return (w1+w2,h1+h2) + plotArea = grid [0,0,1,0,0] [0,0,1,0,0] + [ [er, er, (1,atitle ta), er, er ], + [er, (1,tl), (1,taxis), (1,tr), er ], + [(1,atitle la), (1,laxis), (0,plots), (1,raxis), (1,atitle ra)], + [er, (1,bl), (1,baxis), (1,br), er ], + [er, er, (1,atitle ba), er, er ] ] -renderPlotArea l (Rect p1 p5) = do - let margin = (layout1_margin l) + atitle Nothing = emptyRenderable + atitle (Just (AxisT e a)) = rlabel (axis_title_style a) ha va rot (axis_title a) + where (ha,va,rot) = case e of E_Top -> (HTA_Centre,VTA_Bottom,0) + E_Bottom -> (HTA_Centre,VTA_Top,0) + E_Left -> (HTA_Right,VTA_Centre,90) + E_Right -> (HTA_Left,VTA_Centre,90) - (w1,h1,w2,h2) <- axisSizes l + plots = Renderable { + minsize=return (0,0), + render=renderPlots l + } - let p2 = p1 `pvadd` (Vector w1 h1) - let p4 = p5 - let p3 = p4 `pvsub` (Vector w2 h2) - let plotRect = (Rect p2 p3) + (ba,la,ta,ra) = getAxes l + baxis = maybe emptyRenderable toRenderable ba + taxis = maybe emptyRenderable toRenderable ta + laxis = maybe emptyRenderable toRenderable la + raxis = maybe emptyRenderable toRenderable ra + tl = axesSpacer fst ta fst la + bl = axesSpacer fst ba snd la + tr = axesSpacer snd ta fst ra + br = axesSpacer snd ba snd ra + + er = (0,emptyRenderable) + +renderPlots l r@(Rect p1 p2) = do -- render the plots C.save - setClipRegion p2 p3 - mapM_ (rPlot plotRect) (layout1_plots l) + setClipRegion p1 p2 + mapM_ (rPlot r) (layout1_plots l) C.restore -- render the axes grids - rMAxisG tAxis plotRect - rMAxisG bAxis plotRect - rMAxisG lAxis plotRect - rMAxisG rAxis plotRect - - -- render the axes - rMAxis tAxis (mkrect p2 p1 p3 p2) - rMAxis bAxis (mkrect p2 p3 p3 p4) - rMAxis lAxis (mkrect p1 p2 p2 p3) - rMAxis rAxis (mkrect p3 p2 p4 p3) + maybeM () (renderAxisGrid r) tAxis + maybeM () (renderAxisGrid r) bAxis + maybeM () (renderAxisGrid r) lAxis + maybeM () (renderAxisGrid r) rAxis where (bAxis,lAxis,tAxis,rAxis) = getAxes l - rMAxisG :: Maybe AxisT -> Rect -> C.Render () - rMAxisG (Just at) rect = renderAxisGrid at rect - rMAxisG Nothing _ = return () - - rMAxis :: Maybe AxisT -> Rect -> C.Render () - rMAxis (Just at) rect = render (toRenderable at) rect - rMAxis Nothing _ = return () - rPlot :: Rect -> (String,HAxis,VAxis,Plot) -> C.Render () rPlot rect (_,ha,va,p) = let mxaxis = case ha of HA_Bottom -> bAxis @@ -115,31 +116,12 @@ in plot_render p pmfn rPlot1 _ _ _ _ = return () -axisSizes l = do - w1a <- asize fst lAxis - h1a <- asize snd tAxis - w2a <- asize fst rAxis - h2a <- asize snd bAxis - (h1b,h2b) <- aohang lAxis - (w1b,w2b) <- aohang tAxis - (h1c,h2c) <- aohang rAxis - (w1c,w2c) <- aohang bAxis - - return (maximum [w1a,w1b,w1c], - maximum [h1a,h1b,h1c], - maximum [w2a,w2b,w2c], - maximum [h2a,h2b,h2c] ) - where - (bAxis,lAxis,tAxis,rAxis) = getAxes l - - asize xyfn Nothing = return 0 - asize xyfn (Just at) = do - sz <- minsize (toRenderable at) - return (xyfn sz) - - aohang Nothing = return (0,0) - aohang (Just a) = axisOverhang a +axesSpacer f1 a1 f2 a2 = embedRenderable $ do + oh1 <- maybeM (0,0) axisOverhang a1 + oh2 <- maybeM (0,0) axisOverhang a2 + return (spacer (f1 oh1, f2 oh2)) +maybeM v = maybe (return v) getAxes :: Layout1 -> (Maybe AxisT, Maybe AxisT, Maybe AxisT, Maybe AxisT) getAxes l = (mk E_Bottom bAxis, mk E_Left lAxis, diff --git a/Graphics/Rendering/Chart/Renderable.hs b/Graphics/Rendering/Chart/Renderable.hs --- a/Graphics/Rendering/Chart/Renderable.hs +++ b/Graphics/Rendering/Chart/Renderable.hs @@ -8,6 +8,7 @@ import qualified Graphics.Rendering.Cairo as C import Control.Monad +import Data.List ( nub, partition, transpose, sort ) import Graphics.Rendering.Chart.Types import Graphics.Rendering.Chart.Plot @@ -29,8 +30,10 @@ class ToRenderable a where toRenderable :: a -> Renderable -emptyRenderable = Renderable { - minsize = return (0,0), +emptyRenderable = spacer (0,0) + +spacer sz = Renderable { + minsize = return sz, render = \_ -> return () } @@ -56,57 +59,48 @@ render r rect vertical, horizontal :: [(Double,Renderable)] -> Renderable -vertical rs = Renderable { minsize = mf, render = rf } +vertical rs = grid [1] (map fst rs) [[(0,snd r)] | r <- rs] +horizontal rs = grid (map fst rs) [1] [[(0,snd r) | r <- rs]] + +-- | Layout multiple Renderables into a grid. +-- Arg 1 is the weights for the allocation of extra horizontal space +-- to columns, Arg 2 is the weights for the allocation of extra +-- vertical space to rows, and Arg 3 is the grid of renderables to be +-- layed out. Each element of the grid is a tuple - the first item of +-- the tuple is the drawing priority. Lower priorities get drawn +-- first. Drawing order is significant when Renderables draw outside +-- their edges. +grid :: [Double] -> [Double] -> [[(Int,Renderable)]] -> Renderable +grid we he rss = Renderable { minsize = mf, render = rf } where mf = do - (_,wmin,hmin) <- calcSizes - return (wmin, hmin) + msizes <- getSizes + let widths = (map.map) fst msizes + let heights = (map.map) snd msizes + return ((sum.map maximum.transpose) widths,(sum.map maximum) heights) rf (Rect p1 p2) = do - (sizes,wmin,hmin) <- calcSizes - let wactual = p_x p2 - p_x p1 - let hextra = p_y p2 - p_y p1 - hmin - let etotal = sum (map fst rs) - let rs' = [ (wactual,h + hextra * e / etotal,r) - | ((e,r),(w,h)) <- zip rs sizes ] - foldM_ render1 p1 rs' + msizes <- getSizes + let widths = (map maximum.(map.map) fst.transpose) msizes + let heights = (map maximum.(map.map) snd) msizes + let widths1 = allocate (p_x p2 - p_x p1 - sum widths) we widths + let heights1 = allocate (p_y p2 - p_y p1 - sum heights) he heights + let xs = scanl (+) (p_x p1) widths1 + let ys = scanl (+) (p_y p1) heights1 + + forM_ priorities $ \pr-> + forM_ (zip3 rss ys (tail ys)) $ \(rs,y0,y1) -> + forM_ (zip3 rs xs (tail xs)) $ \((n,r),x0,x1) -> + when (n==pr) $ render r (Rect (Point x0 y0) (Point x1 y1)) - calcSizes = do - sizes <- mapM minsize [ r | (_,r) <- rs] - let wmin = maximum [ w | (w,h) <- sizes ] - let hmin = sum [ h | (w,h) <- sizes ] - return (sizes,wmin,hmin) - - render1 :: Point -> (Double,Double,Renderable) -> C.Render Point - render1 p (w,h,r) = do - render r (Rect p (p `pvadd` Vector w h)) - return (p `pvadd` Vector 0 h) + getSizes = (mapM.mapM) (\(n,r)-> minsize r) rss + priorities = sort (nub ((concatMap.map) fst rss)) -horizontal rs = Renderable { minsize = mf, render = rf } +allocate :: Double -> [Double] -> [Double] -> [Double] +allocate extra ws vs = zipWith (+) vs (extras++[0,0..]) where - mf = do - (_,wmin,hmin) <- calcSizes - return (wmin, hmin) - - rf (Rect p1 p2) = do - (sizes,wmin,hmin) <- calcSizes - let hactual = p_y p2 - p_y p1 - let wextra = p_x p2 - p_x p1 - wmin - let etotal = sum (map fst rs) - let rs' = [ (w + wextra * e / etotal,hactual,r) - | ((e,r),(w,h)) <- zip rs sizes ] - foldM_ render1 p1 rs' - - calcSizes = do - sizes <- mapM minsize [ r | (_,r) <- rs] - let hmin = maximum [ h | (w,h) <- sizes ] - let wmin = sum [ w | (w,h) <- sizes ] - return (sizes,wmin,hmin) - - render1 :: Point -> (Double,Double,Renderable) -> C.Render Point - render1 p (w,h,r) = do - render r (Rect p (p `pvadd` Vector w h)) - return (p `pvadd` Vector w 0) + total = sum ws + extras = [ extra * v / total | v <- ws ] renderableToPNGFile :: Renderable -> Int -> Int -> FilePath -> IO () renderableToPNGFile chart width height path = @@ -150,6 +144,13 @@ -- exactly one pixel C.translate 0.5 0.5 +embedRenderable :: C.Render Renderable -> Renderable +embedRenderable ca = Renderable { + minsize = do { a <- ca; minsize a }, + render = \ r -> do { a <- ca; render a r } +} + + ---------------------------------------------------------------------- -- Legend @@ -169,7 +170,7 @@ minsizeLegend :: Legend -> C.Render RectSize minsizeLegend (Legend _ ls plots) = do - let labels = map fst plots + let labels = nub $ map fst plots lsizes <- mapM textSize labels lgap <- legendSpacer let lm = legend_margin ls @@ -181,20 +182,24 @@ renderLegend :: Legend -> Rect -> C.Render () renderLegend (Legend _ ls plots) (Rect rp1 rp2) = do - foldM_ rf rp1 plots + foldM_ rf rp1 $ join_nub plots where lm = legend_margin ls lps = legend_plot_size ls - rf :: Point -> (String,Plot) -> C.Render Point - rf p1 (label,plot) = do + rf :: Point -> (String,[Plot]) -> C.Render Point + rf p1 (label,theseplots) = do (w,h) <- textSize label lgap <- legendSpacer let p2 = (p1 `pvadd` Vector lps 0) - plot_render_legend plot (mkrect p1 rp1 p2 rp2) + mapM_ (\p -> plot_render_legend p (mkrect p1 rp1 p2 rp2)) theseplots let p3 = Point (p_x p2 + lgap) (p_y rp1) drawText HTA_Left VTA_Top p3 label return (p3 `pvadd` Vector (w+lm) 0) + join_nub :: [(String, a)] -> [(String, [a])] + join_nub ((x,a1):ys) = case partition ((==x) . fst) ys of + (xs, rest) -> (x, a1:map snd xs) : join_nub rest + join_nub [] = [] legendSpacer = do (lgap,_) <- textSize "X" @@ -211,24 +216,57 @@ -- Labels label :: CairoFontStyle -> HTextAnchor -> VTextAnchor -> String -> Renderable -label fs hta vta s = Renderable { minsize = mf, render = rf } +label fs hta vta = rlabel fs hta vta 0 + +rlabel :: CairoFontStyle -> HTextAnchor -> VTextAnchor -> Double -> String -> Renderable +rlabel fs hta vta rot s = Renderable { minsize = mf, render = rf } where mf = do C.save setFontStyle fs - sz <- textSize s + (w,h) <- textSize s C.restore - return sz + let sz' = (w*acr+h*asr,w*asr+h*acr) + return sz' rf (Rect p1 p2) = do C.save setFontStyle fs - let p = Point (xp hta (p_x p1) (p_x p2)) (yp vta (p_y p1) (p_y p2)) - drawText hta vta p s + sz@(w,h) <- textSize s + C.translate (xadj sz hta (p_x p1) (p_x p2)) (yadj sz vta (p_y p1) (p_y p2)) + C.rotate rot' + C.moveTo (-w/2) (h/2) + C.showText s C.restore - xp HTA_Left x1 x2 = x1 - xp HTA_Centre x1 x2 = (x1+x2)/2 - xp HTA_Right x1 x2 = x2 - yp VTA_Top y1 y2 = y2 - yp VTA_Centre y1 y2 = (y1+y2)/2 - yp VTA_Bottom y1 y2 = y1 + xadj (w,h) HTA_Left x1 x2 = x1 +(w*acr+h*asr)/2 + xadj (w,h) HTA_Centre x1 x2 = (x1 + x2)/2 + xadj (w,h) HTA_Right x1 x2 = x2 -(w*acr+h*asr)/2 + yadj (w,h) VTA_Top y1 y2 = y1 +(w*asr+h*acr)/2 + yadj (w,h) VTA_Centre y1 y2 = (y1+y2)/2 + yadj (w,h) VTA_Bottom y1 y2 = y2 - (w*asr+h*acr)/2 + rot' = rot / 180 * pi + (cr,sr) = (cos rot', sin rot') + (acr,asr) = (abs cr, abs sr) + +-- a quick test to display labels with all combinations +-- of anchors +labelTest rot = renderableToPNGFile r 800 800 "labels.png" + where + r = fillBackground white $ grid [1,1,1] [1,1,1] ls + ls = [ [(0,addMargins (20,20,20,20) $ fillBackground blue $ crossHairs $ rlabel fs h v rot s) | h <- hs] | v <- vs ] + s = "Labels" + hs = [HTA_Left, HTA_Centre, HTA_Right] + vs = [VTA_Top, VTA_Centre, VTA_Bottom] + white = solidFillStyle 1 1 1 + blue = solidFillStyle 0.8 0.8 1 + fs = fontStyle "sans" 30 C.FontSlantNormal C.FontWeightBold + crossHairs r =Renderable { + minsize = minsize r, + render = \rect@(Rect (Point x1 y1) (Point x2 y2)) -> do + let xa = (x1 + x2) / 2 + let ya = (y1 + y2) / 2 + strokeLines [Point x1 ya,Point x2 ya] + strokeLines [Point xa y1,Point xa y2] + render r rect + } + diff --git a/Graphics/Rendering/Chart/Simple.hs b/Graphics/Rendering/Chart/Simple.hs new file mode 100644 --- /dev/null +++ b/Graphics/Rendering/Chart/Simple.hs @@ -0,0 +1,265 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Chart.Simple +-- Copyright : (c) David Roundy 2007 +-- License : BSD-style (see chart/COPYRIGHT) +-- +-- An even simpler framework for creating 2D charts in Haskell. +-- +-- The basic idea is to make it as easy to plot as octave, which means that +-- you provide no more information than you wish to provide. We provide +-- four plotting functions, which differ only in their output. One +-- produces a "Layout1" that you can customize using other +-- Graphics.Rendering.Chart functions. The other three produce their +-- output directly. All three accept the same input (except for the +-- filename required by plotPDF and plotPS), and produce the same plots. +-- +-- The plot functions accept a variable number of arguments. You must +-- provide a [Double] which defines the points on the x axis, which must +-- precede any of the "y" values. The y values may either be [Double] or +-- functions. After any given y value, you can give either Strings or +-- PlotKinds describing how you'd like that y printed. +-- +-- Examples: +-- +-- renderableToWindow (toRenderable $ plot [0,0.1..10] sin "sin(x)") 640 480 +-- +-- plotWindow [0,1,3,4,8]] [12,15,1,5,8] "o" "points" +-- +-- plotPDF "foo.pdf" [0,0.1..10] sin "- " cos ". " cos "o" +-- +-- plotPS "foo.ps" [0,0.1..10] (sin.exp) "- " (sin.exp) "o-" +----------------------------------------------------------------------------- +module Graphics.Rendering.Chart.Simple( plot, PlotKind(..), xcoords, + plotWindow, plotPDF, plotPS + ) where + +import Data.Maybe ( catMaybes ) + +import Graphics.Rendering.Chart +import Graphics.Rendering.Chart.Gtk + +styleColor :: (Double -> Double -> Double -> a) -> Int -> a +styleColor f ind = case colorSequence !! ind of (r,g,b) -> f r g b + where colorSequence = cycle [(0,0,1),(1,0,0),(0,1,0),(1,1,0),(0,1,1),(1,0,1),(0,0,0)] + +styleSymbol :: Int -> PlotKind +styleSymbol ind = symbolSequence !! ind + where symbolSequence = cycle [ Ex, HollowCircle, Triangle, DownTriangle, Square, + Diamond, Plus, Star, FilledCircle ] + +iplot :: [InternalPlot] -> Layout1 +iplot foobar = defaultLayout1 { + layout1_plots = concat $ zipWith toplot (ip foobar) [0..] + } + where ip (xs@(IPX _ _):xyss) = map (\ys -> (xs,ys)) yss ++ ip rest + where yss = takeWhile isIPY xyss + rest = dropWhile isIPY xyss + ip (_:xyss) = ip xyss + ip [] = [] + isIPY (IPY _ _) = True + isIPY _ = False + toplot (IPX xs _, IPY ys yks) ind = map (\z -> (name yks, HA_Bottom, VA_Left, z)) plots + where vs = map (\(x,y) -> Point x y) $ filter isOkay $ zip xs ys + plots = case catMaybes $ map plotas yks of + [] -> [toPlot $ defaultPlotLines + { plot_lines_values = [vs], + plot_lines_style = solidLine 1 `styleColor` ind }] + xs -> xs + plotas Solid = Just $ toPlot $ defaultPlotLines + { plot_lines_values = [vs], + plot_lines_style = solidLine 1 `styleColor` ind } + plotas Dashed = Just $ toPlot $ defaultPlotLines + { plot_lines_values = [vs], + plot_lines_style = dashedLine 1 [10,10] `styleColor` ind } + plotas Dotted = Just $ toPlot $ defaultPlotLines + { plot_lines_values = [vs], + plot_lines_style = dashedLine 1 [1,11] `styleColor` ind } + plotas FilledCircle = Just $ toPlot $ defaultPlotPoints + { plot_points_values = vs, + plot_points_style=filledCircles 4 `styleColor` ind } + plotas HollowCircle = Just $ toPlot $ defaultPlotPoints + { plot_points_values = vs, + plot_points_style=hollowCircles 5 1 `styleColor` ind } + plotas Triangle = Just $ toPlot $ defaultPlotPoints + { plot_points_values = vs, + plot_points_style=hollowPolygon 7 1 3 False `styleColor` ind } + plotas DownTriangle = Just $ toPlot $ defaultPlotPoints + { plot_points_values = vs, + plot_points_style=hollowPolygon 7 1 3 True `styleColor` ind } + plotas Square = Just $ toPlot $ defaultPlotPoints + { plot_points_values = vs, + plot_points_style=hollowPolygon 7 1 4 False `styleColor` ind } + plotas Diamond = Just $ toPlot $ defaultPlotPoints + { plot_points_values = vs, + plot_points_style=hollowPolygon 7 1 4 True `styleColor` ind } + plotas Plus = Just $ toPlot $ defaultPlotPoints + { plot_points_values = vs, + plot_points_style=plusses 7 1 `styleColor` ind } + plotas Ex = Just $ toPlot $ defaultPlotPoints + { plot_points_values = vs, + plot_points_style=exes 7 1 `styleColor` ind } + plotas Star = Just $ toPlot $ defaultPlotPoints + { plot_points_values = vs, + plot_points_style=stars 7 1 `styleColor` ind } + plotas Symbols = plotas (styleSymbol ind) + plotas _ = Nothing + isOkay (_,n) = not (isNaN n || isInfinite n) + +name :: [PlotKind] -> String +name (Name s:_) = s +name (_:ks) = name ks +name [] = "" + +str2k :: String -> [PlotKind] +str2k "" = [] +str2k ". " = [Dotted] +str2k s@('?':_) = str2khelper s Symbols +str2k s@('@':_) = str2khelper s FilledCircle +str2k s@('#':_) = str2khelper s Square +str2k s@('v':_) = str2khelper s DownTriangle +str2k s@('^':_) = str2khelper s Triangle +str2k s@('o':_) = str2khelper s HollowCircle +str2k s@('+':_) = str2khelper s Plus +str2k s@('x':_) = str2khelper s Ex +str2k s@('*':_) = str2khelper s Star +str2k s@('.':_) = str2khelper s LittleDot +str2k "- " = [Dashed] +str2k "-" = [Solid] +str2k n = [Name n] + +str2khelper :: String -> PlotKind -> [PlotKind] +str2khelper s@(_:r) x = case str2k r of + [] -> [x] + [Name _] -> [Name s] + xs -> x:xs + +-- | Type to define a few simple properties of each plot. +data PlotKind = Name String | FilledCircle | HollowCircle + | Triangle | DownTriangle | Square | Diamond | Plus | Ex | Star | Symbols + | LittleDot | Dashed | Dotted | Solid + deriving ( Eq, Show, Ord ) +data InternalPlot = IPY [Double] [PlotKind] | IPX [Double] [PlotKind] + +uplot :: [UPlot] -> Layout1 +uplot us = iplot $ nameDoubles $ evalfuncs us + where nameDoubles :: [UPlot] -> [InternalPlot] + nameDoubles (X xs:uus) = case grabName uus of + (ks,uus') -> IPX xs ks : nameDoubles uus' + nameDoubles (UDoubles xs:uus) = case grabName uus of + (ks,uus') -> IPY xs ks : nameDoubles uus' + nameDoubles (_:uus) = nameDoubles uus + nameDoubles [] = [] + evalfuncs :: [UPlot] -> [UPlot] + evalfuncs (UDoubles xs:uus) = X xs : map ef (takeWhile (not.isX) uus) + ++ evalfuncs (dropWhile (not.isX) uus) + where ef (UFunction f) = UDoubles (map f xs) + ef u = u + evalfuncs (X xs:uus) = X xs : map ef (takeWhile (not.isX) uus) + ++ evalfuncs (dropWhile (not.isX) uus) + where ef (UFunction f) = UDoubles (map f xs) + ef u = u + evalfuncs (u:uus) = u : evalfuncs uus + evalfuncs [] = [] + grabName :: [UPlot] -> ([PlotKind],[UPlot]) + grabName (UString n:uus) = case grabName uus of + (ks,uus') -> (str2k n++ks,uus') + grabName (UKind ks:uus) = case grabName uus of + (ks',uus') -> (ks++ks',uus') + grabName uus = ([],uus) + isX (X _) = True + isX _ = False + +-- | The main plotting function. The idea behind PlotType is shamelessly +-- copied from Text.Printf (and is not exported). All you need to know is +-- that your arguments need to be in class PlotArg. And PlotArg consists +-- of functions and [Double] and String and PlotKind or [PlotKind]. + +plot :: PlotType a => a +plot = pl [] +class PlotType t where + pl :: [UPlot] -> t +instance (PlotArg a, PlotType r) => PlotType (a -> r) where + pl args = \ a -> pl (toUPlot a ++ args) +instance PlotType Layout1 where + pl args = uplot (reverse args) + +-- | Display a plot on the screen. + +plotWindow :: PlotWindowType a => a +plotWindow = plw [] +class PlotWindowType t where + plw :: [UPlot] -> t +instance (PlotArg a, PlotWindowType r) => PlotWindowType (a -> r) where + plw args = \ a -> plw (toUPlot a ++ args) +instance PlotWindowType (IO a) where + plw args = do renderableToWindow (toRenderable $ uplot (reverse args)) 640 480 + return undefined + +-- | Save a plot as a PDF file. + +plotPDF :: PlotPDFType a => String -> a +plotPDF fn = pld fn [] +class PlotPDFType t where + pld :: FilePath -> [UPlot] -> t +instance (PlotArg a, PlotPDFType r) => PlotPDFType (a -> r) where + pld fn args = \ a -> pld fn (toUPlot a ++ args) +instance PlotPDFType (IO a) where + pld fn args = do renderableToPDFFile (toRenderable $ uplot (reverse args)) 640 480 fn + return undefined + +-- | Save a plot as a postscript file. + +plotPS :: PlotPSType a => String -> a +plotPS fn = pls fn [] +class PlotPSType t where + pls :: FilePath -> [UPlot] -> t +instance (PlotArg a, PlotPSType r) => PlotPSType (a -> r) where + pls fn args = \ a -> pls fn (toUPlot a ++ args) +instance PlotPSType (IO a) where + pls fn args = do renderableToPSFile (toRenderable $ uplot (reverse args)) 640 480 fn + return undefined + +data UPlot = UString String | UDoubles [Double] | UFunction (Double -> Double) + | UKind [PlotKind] | X [Double] + +xcoords :: [Double] -> UPlot +xcoords = X + +class PlotArg a where + toUPlot :: a -> [UPlot] + +instance IsPlot p => PlotArg [p] where + toUPlot = toUPlot' + +instance (Real a, Real b, Fractional a, Fractional b) => PlotArg (a -> b) where + toUPlot f = [UFunction (realToFrac . f . realToFrac)] + +instance PlotArg UPlot where + toUPlot = (:[]) + +instance PlotArg PlotKind where + toUPlot = (:[]) . UKind . (:[]) + +class IsPlot c where + toUPlot' :: [c] -> [UPlot] + +instance IsPlot PlotKind where + toUPlot' = (:[]) . UKind + +instance IsPlot Double where + toUPlot' = (:[]) . UDoubles + +instance IsPlot Char where + toUPlot' = (:[]) . UString + +instance IsPlot p => IsPlot [p] where + toUPlot' = reverse . concatMap toUPlot' + +instance (IsPlot p, IsPlot q, IsPlot r) => IsPlot (p,q,r) where + toUPlot' = reverse . concatMap f + where f (p,q,r) = toUPlot' [p] ++ toUPlot' [q] ++ toUPlot' [r] + +instance (IsPlot p, IsPlot q) => IsPlot (p,q) where + toUPlot' = reverse . concatMap f + where f (p,q) = toUPlot' [p] ++ toUPlot' [q] diff --git a/Graphics/Rendering/Chart/Types.hs b/Graphics/Rendering/Chart/Types.hs --- a/Graphics/Rendering/Chart/Types.hs +++ b/Graphics/Rendering/Chart/Types.hs @@ -160,6 +160,123 @@ C.arc x y radius 0 360 C.fill +hollowCircles :: + Double -- ^ radius of circle + -> Double -- ^ thickness of line + -> Double -- ^ red component of colour + -> Double -- ^ green component of colour + -> Double -- ^ blue component of colour + -> CairoPointStyle +hollowCircles radius w r g b = CairoPointStyle rf + where + rf (Point x y) = do + C.setLineWidth w + C.setSourceRGB r g b + C.newPath + C.arc x y radius 0 360 + C.stroke + +hollowPolygon :: + Double -- ^ radius of circle + -> Double -- ^ thickness of line + -> Int -- ^ Number of vertices + -> Bool -- ^ Is right-side-up? + -> Double -- ^ red component of colour + -> Double -- ^ green component of colour + -> Double -- ^ blue component of colour + -> CairoPointStyle +hollowPolygon radius w sides isrot r g b = CairoPointStyle rf + where rf (Point x y) = + do C.setLineWidth w + C.setSourceRGB r g b + C.newPath + let intToAngle n = if isrot + then fromIntegral n * 2*pi / fromIntegral sides + else (0.5 + fromIntegral n)*2*pi/fromIntegral sides + angles = map intToAngle [0 .. sides-1] + (p:ps) = map (\a -> Point (x + radius * sin a) (y + radius * cos a)) angles + moveTo p + mapM_ lineTo (ps++[p]) + C.stroke + +filledPolygon :: + Double -- ^ radius of circle + -> Int -- ^ Number of vertices + -> Bool -- ^ Is right-side-up? + -> Double -- ^ red component of colour + -> Double -- ^ green component of colour + -> Double -- ^ blue component of colour + -> CairoPointStyle +filledPolygon radius sides isrot r g b = CairoPointStyle rf + where rf (Point x y) = + do C.setSourceRGB r g b + C.newPath + let intToAngle n = if isrot + then fromIntegral n * 2*pi / fromIntegral sides + else (0.5 + fromIntegral n)*2*pi/fromIntegral sides + angles = map intToAngle [0 .. sides-1] + (p:ps) = map (\a -> Point (x + radius * sin a) (y + radius * cos a)) angles + moveTo p + mapM_ lineTo (ps++[p]) + C.fill + +plusses :: + Double -- ^ radius of circle + -> Double -- ^ thickness of line + -> Double -- ^ red component of colour + -> Double -- ^ green component of colour + -> Double -- ^ blue component of colour + -> CairoPointStyle +plusses radius w r g b = CairoPointStyle rf + where rf (Point x y) = do C.setLineWidth w + C.setSourceRGB r g b + C.newPath + C.moveTo (x+radius) y + C.lineTo (x-radius) y + C.moveTo x (y-radius) + C.lineTo x (y+radius) + C.stroke + +exes :: + Double -- ^ radius of circle + -> Double -- ^ thickness of line + -> Double -- ^ red component of colour + -> Double -- ^ green component of colour + -> Double -- ^ blue component of colour + -> CairoPointStyle +exes radius w r g b = CairoPointStyle rf + where rad = radius / sqrt 2 + rf (Point x y) = do C.setLineWidth w + C.setSourceRGB r g b + C.newPath + C.moveTo (x+rad) (y+rad) + C.lineTo (x-rad) (y-rad) + C.moveTo (x+rad) (y-rad) + C.lineTo (x-rad) (y+rad) + C.stroke + +stars :: + Double -- ^ radius of circle + -> Double -- ^ thickness of line + -> Double -- ^ red component of colour + -> Double -- ^ green component of colour + -> Double -- ^ blue component of colour + -> CairoPointStyle +stars radius w r g b = CairoPointStyle rf + where rad = radius / sqrt 2 + rf (Point x y) = do C.setLineWidth w + C.setSourceRGB r g b + C.newPath + C.moveTo (x+radius) y + C.lineTo (x-radius) y + C.moveTo x (y-radius) + C.lineTo x (y+radius) + C.moveTo (x+rad) (y+rad) + C.lineTo (x-rad) (y-rad) + C.moveTo (x+rad) (y-rad) + C.lineTo (x-rad) (y+rad) + C.stroke + solidLine :: Double -- ^ width of line -> Double -- ^ red component of colour diff --git a/tests/test.hs b/tests/test.hs --- a/tests/test.hs +++ b/tests/test.hs @@ -1,5 +1,6 @@ import qualified Graphics.Rendering.Cairo as C import Graphics.Rendering.Chart +import Graphics.Rendering.Chart.Simple import Graphics.Rendering.Chart.Gtk import System.Environment(getArgs) import System.Time @@ -124,8 +125,8 @@ layout = defaultLayout1 { layout1_title="Log/Linear Example", - layout1_horizontal_axes=linkedAxes (autoScaledAxis defaultAxis), - layout1_vertical_axes=linkedAxes (autoScaledLogAxis defaultAxis), + layout1_horizontal_axes=linkedAxes' (autoScaledAxis defaultAxis{axis_title="horizontal"}), + layout1_vertical_axes=linkedAxes' (autoScaledLogAxis defaultAxis{axis_title="vertical"}), layout1_plots = [("values",HA_Bottom,VA_Left,(toPlot points)), ("values",HA_Bottom,VA_Left,(toPlot lines)) ] } @@ -167,13 +168,28 @@ lineWidth = chooseLineWidth otype + ---------------------------------------------------------------------- +-- Test the Simple interface + +test6 :: OutputType -> IO Layout1 +test6 otype = return pp{layout1_title="Graphics.Rendering.Chart.Simple example"} + where + pp = plot xs sin "sin" + cos "cos" "o" + (sin.sin.cos) "sin.sin.cos" "." + (/3) "- " + (const 0.5) + [0.1,0.7,0.5::Double] "+" + xs = [0,0.3..3] :: [Double] +---------------------------------------------------------------------- allTests = [ ("test1",test1) , ("test2",test2) , ("test3",test3) , ("test4",test4) , ("test5",test5) + , ("test6",test6) ] main = do @@ -192,5 +208,5 @@ renderToWindow (n,t) = t Window >>= \l -> renderableToWindow (toRenderable l) 640 480 renderToPNG (n,t) = t PNG >>= \l -> renderableToPNGFile (toRenderable l) 640 480 (n ++ ".png") -renderToPS (n,t) = t PS >>= \l -> renderableToPSFile (toRenderable l) 640 480 (n ++ ".png") +renderToPS (n,t) = t PS >>= \l -> renderableToPSFile (toRenderable l) 640 480 (n ++ ".ps") renderToPDF (n,t) = t PDF >>= \l -> renderableToPDFFile (toRenderable l) 640 480 (n ++ ".pdf")