diff --git a/Chart-tests.cabal b/Chart-tests.cabal new file mode 100644 --- /dev/null +++ b/Chart-tests.cabal @@ -0,0 +1,85 @@ +Name: Chart-tests +Version: 1.9.3 +License: BSD3 +License-file: LICENSE +Copyright: Tim Docker, 2006-2014 +Author: Tim Docker +Maintainer: Tim Docker +Homepage: https://github.com/timbod7/haskell-chart/wiki +Synopsis: Tests of the Charts library. +Description: Tests of the Charts library. +Category: Graphics +Cabal-Version: >= 1.10 +Build-Type: Simple + + +source-repository head + type: git + location: https://github.com/timbod7/haskell-chart + +Executable chart-harness + Build-Depends: + base >= 3 && < 5, + old-locale, + array, + time, + mtl, + colour >= 2.2.1 && < 2.4, + lens >= 3.9 && < 4.19, + data-default-class < 0.2, + bytestring >= 0.9 && < 1.0, + svg-builder >= 0.1 && < 0.2, + random >= 1.0, + containers >= 0.4 && <0.7, + old-time >= 1.0, + Chart >= 1.9 && < 1.10, + Chart-cairo >= 1.9 && < 1.10, + Chart-gtk >= 1.9 && < 1.10, + Chart-diagrams >= 1.9 && < 1.10, + gtk >= 0.9.11, + cairo >= 0.9.11, + diagrams-cairo >= 1.3 && < 1.5, + diagrams-svg >= 1.4 && < 1.5, + diagrams-postscript >= 0.7 && < 1.6, + diagrams-lib >= 1.2 && < 1.5, + diagrams-core >= 1.3 && < 1.5 + Main-is: Main.hs + Hs-Source-Dirs: tests + Ghc-Options: -threaded + default-language: Haskell2010 + other-modules: + CompareFonts + DiagramsCairo + DiagramsEPS + DiagramsSVG + Drawing.Cairo + Drawing.DiagramsCairo + Drawing.Tests + ExampleStocks + GtkTestPicking + Prices + Test1 + Test2 + Test3 + Test4 + Test5 + Test7 + Test8 + Test9 + Test14a + Test14 + Test15 + Test17 + Test19 + TestParametric + Tests + TestSparkLines + Utils + +test-suite doctests + type: exitcode-stdio-1.0 + main-is: Doctests.hs + build-depends: base >= 4.7 && < 5 + , doctest >= 0.8 + default-language: Haskell2010 + Hs-Source-Dirs: tests diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ +Copyright (c) 2006, Tim Docker + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * The names of contributors may not be used to endorse or promote + products derived from this software without specific prior + written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,8 @@ +#!/usr/bin/env runghc + +module Main where + +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/tests/CompareFonts.hs b/tests/CompareFonts.hs new file mode 100644 --- /dev/null +++ b/tests/CompareFonts.hs @@ -0,0 +1,98 @@ +module CompareFonts where + +import Data.Colour +import Data.Colour.Names +import Data.Monoid +import Data.Default.Class + +import Graphics.Rendering.Chart.Backend +import Graphics.Rendering.Chart.Geometry +import Graphics.Rendering.Chart.Drawing +import qualified Graphics.Rendering.Chart.Backend.Diagrams as BD +import qualified Graphics.Rendering.Chart.Backend.Cairo as BC + +import Diagrams.Core ( renderDia ) +import Diagrams.Prelude ( dims, V2(..) ) +import Diagrams.Backend.Cairo hiding ( renderCairo ) +import Diagrams.Backend.Cairo.Internal + +import qualified Graphics.Rendering.Cairo as C +import qualified Graphics.Rendering.Cairo.Matrix as CM + +markLineStyle :: LineStyle +markLineStyle = def + { _line_color = opaque red + , _line_width = 1 + } + +-- Render a few lines and mark them appropriatly. +main :: IO () +main = render ("test.png") 1000 500 $ do + withTranslation (Point 10 10) $ do + (flip mapM_) [0 .. 5] $ \i -> do + let d = fromIntegral i + withTranslation (Point 0 (d * 70)) $ testDrawText (i * 10 + 10) + return () + +testDrawText :: Int -> BackendProgram () +testDrawText fontSize = + withFontStyle (def { _font_size = fromIntegral fontSize, _font_name = "Source Sans Pro" }) $ do + let text = "ÄÖÜ Testing " ++ show fontSize ++ "px" + -- Text metrics + ts <- textSize text + let a = textSizeAscent ts + d = textSizeDescent ts + -- Baseline and descent line: Red + withLineStyle markLineStyle $ do + p <- alignStrokePath $ moveTo' 0 a + <> lineTo' 500 a + <> moveTo' 0 (a + d) + <> lineTo' 500 (a + d) + strokePath p + -- Bounding lines: Green + withLineStyle (markLineStyle { _line_color = opaque green }) $ do + p <- alignStrokePath $ moveTo' 0 0 + <> lineTo' 500 0 + <> moveTo' 0 (fromIntegral fontSize) + <> lineTo' 500 (fromIntegral fontSize) + <> moveTo' 0 0 + <> lineTo' 0 (fromIntegral fontSize) + + strokePath p + drawText (Point 0 a) text + +-- Render it side by side using cairo and diagrams cairo with SVGFonts. +render :: FilePath -> Int -> Int -> BackendProgram () -> IO () +render f w h m = do + rc <- renderCairo (w,h) m + rd <- renderDiagramsCairo (w,h) m + s <- C.createImageSurface C.FormatARGB32 w h + C.renderWith s $ do + C.setSourceRGB 1 1 1 + C.paint + C.setSourceRGB 0 0 0 + C.newPath + C.moveTo (fromIntegral w / 2) 0 + C.lineTo (fromIntegral w / 2) (fromIntegral h) + C.stroke + C.renderWith s $ do + C.rectangle 0 0 500 500 + C.clip + rc + C.renderWith s $ do + C.setMatrix (CM.translate (fromIntegral w/2) 0 CM.identity) + C.rectangle 0 0 500 500 + C.clip + C.scale 1 (-1) + rd + C.surfaceWriteToPNG s f + +renderCairo :: (Int, Int) -> BackendProgram () -> IO (C.Render ()) +renderCairo (w,h) m = do + return $ BC.runBackend (BC.defaultEnv bitmapAlignmentFns) m + +renderDiagramsCairo :: (Int, Int) -> BackendProgram () -> IO (C.Render ()) +renderDiagramsCairo (w,h) m = do + env <- BD.defaultEnv bitmapAlignmentFns (fromIntegral w) (fromIntegral h) + let (d, _) = BD.runBackend env m + return $ snd $ renderDia Cairo (CairoOptions "" (dims $ V2 (fromIntegral w) (fromIntegral h)) PNG True) d diff --git a/tests/DiagramsCairo.hs b/tests/DiagramsCairo.hs new file mode 100644 --- /dev/null +++ b/tests/DiagramsCairo.hs @@ -0,0 +1,30 @@ +module DiagramsCairo where + +import Graphics.Rendering.Chart.Backend +import Graphics.Rendering.Chart.Backend.Diagrams + +import Diagrams.Core ( renderDia ) +import Diagrams.Prelude ( dims, V2(..) ) +import Diagrams.Backend.Cairo +import Diagrams.Backend.Cairo.Internal +import Graphics.Rendering.Chart.Renderable ( render, Renderable ) + +import System.Environment ( getArgs ) + +import Tests ( allTests, showTests ) +import qualified Tests as T + +main = do + args <- getArgs + main1 args + +main1 :: [String] -> IO () +main1 args = do + -- Only load the environment once, to speed things up. + env <- defaultEnv bitmapAlignmentFns 500 500 + let renderDiagram :: (String, (Int, Int), T.LineWidth -> Renderable ()) -> IO () + renderDiagram (n,(w,h),ir) = do + let env' = env { envOutputSize = (fromIntegral w, fromIntegral h) } + (d, _) = runBackendR env' (ir 1.0) + fst $ renderDia Cairo (CairoOptions (n ++ ".png") (dims $ V2 (fromIntegral w) (fromIntegral h)) PNG False) d + showTests (fmap (\(x,_,_) -> x) allTests) renderDiagram diff --git a/tests/DiagramsEPS.hs b/tests/DiagramsEPS.hs new file mode 100644 --- /dev/null +++ b/tests/DiagramsEPS.hs @@ -0,0 +1,32 @@ +module DiagramsEPS where + +import Graphics.Rendering.Chart.Backend +import Graphics.Rendering.Chart.Backend.Diagrams + +import Diagrams.Core ( renderDia ) +import Graphics.Rendering.Chart.Renderable ( render, Renderable ) +import qualified Diagrams.Backend.Postscript as DEPS + +import System.Environment ( getArgs ) + +import Tests ( allTests, showTests ) +import qualified Tests as T + +main = do + args <- getArgs + main1 args + +main1 :: [String] -> IO () +main1 args = do + -- We don't use the renderableToFile function as we want to construct the + -- environment once for speed + env0 <- defaultEnv bitmapAlignmentFns 0 0 + showTests (fmap (\(x,_,_) -> x) allTests) (renderDiagram env0) + where + renderDiagram :: DEnv Double -> (String, (Int, Int), T.LineWidth -> Renderable ()) -> IO () + renderDiagram env0 (n,(w,h),ir) = do + let cr = render (ir 0.25) (fromIntegral w, fromIntegral h) + path = n ++ ".eps" + fo = FileOptions (fromIntegral w, fromIntegral h) EPS loadSansSerifFonts + cBackendToFile fo cr path + putStrLn (path ++ "...") diff --git a/tests/DiagramsSVG.hs b/tests/DiagramsSVG.hs new file mode 100644 --- /dev/null +++ b/tests/DiagramsSVG.hs @@ -0,0 +1,36 @@ +module DiagramsSVG where + +import Control.Monad (void) +import Graphics.Rendering.Chart.Backend +import Graphics.Rendering.Chart.Backend.Diagrams + +import qualified Data.ByteString.Lazy as BS + +import Diagrams.Core ( renderDia ) +import Diagrams.Backend.SVG +import Graphics.Rendering.Chart.Renderable ( render, Renderable ) +import qualified Graphics.Svg as Svg + +import System.Environment ( getArgs ) + +import Tests ( allTests, showTests ) +import qualified Tests as T + +main = do + args <- getArgs + main1 args + +main1 :: [String] -> IO () +main1 args = do + -- We don't use the renderableToFile function as we want to construct the + -- environment once for speed + env0 <- defaultEnv bitmapAlignmentFns 0 0 + showTests (fmap (\(x,_,_) -> x) allTests) (renderDiagram env0) + where + renderDiagram :: DEnv Double -> (String, (Int, Int), T.LineWidth -> Renderable ()) -> IO () + renderDiagram env0 (n,(w,h),ir) = do + let cr = render (ir 0.25) (fromIntegral w, fromIntegral h) + path = n ++ ".svg" + fo = FileOptions (fromIntegral w, fromIntegral h) Graphics.Rendering.Chart.Backend.Diagrams.SVG loadSansSerifFonts + putStrLn (path ++ "...") + void $ cBackendToFile fo cr path diff --git a/tests/Doctests.hs b/tests/Doctests.hs new file mode 100644 --- /dev/null +++ b/tests/Doctests.hs @@ -0,0 +1,12 @@ +{-# OPTIONS_GHC -Wall #-} + +module Main ( main ) where + +import Test.DocTest + +main :: IO () +main = + doctest + [ "../chart/Graphics/Rendering/Chart/Axis/Floating.hs" + , "../chart/Numeric/Histogram.hs" + ] diff --git a/tests/Drawing/Cairo.hs b/tests/Drawing/Cairo.hs new file mode 100644 --- /dev/null +++ b/tests/Drawing/Cairo.hs @@ -0,0 +1,15 @@ +module Drawing.Cairo where + +import Control.Monad + +import Graphics.Rendering.Chart.Backend +import Graphics.Rendering.Chart.Backend.Cairo + +import Drawing.Tests + +main :: IO () +main = (flip mapM_) tests $ \(name, w, h, draw) -> do + render (name ++ ".png") w h draw + +render :: FilePath -> Int -> Int -> BackendProgram a -> IO () +render f w h m = void $ cBackendToFile (FileOptions (w,h) PNG) m f diff --git a/tests/Drawing/DiagramsCairo.hs b/tests/Drawing/DiagramsCairo.hs new file mode 100644 --- /dev/null +++ b/tests/Drawing/DiagramsCairo.hs @@ -0,0 +1,26 @@ +module Drawing.DiagramsCairo where + +import Control.Monad(forM_) + +import Graphics.Rendering.Chart.Backend +import Graphics.Rendering.Chart.Backend.Diagrams + +import Diagrams.Core ( renderDia ) +import Diagrams.Prelude ( dims, V2(..) ) +import Diagrams.Backend.Cairo +import Diagrams.Backend.Cairo.Internal + +import Drawing.Tests (tests) + +main :: IO () +main = do + fonts <- loadCommonFonts + forM_ tests $ \(name, w, h, draw) -> do + render fonts (name ++ ".png") w h draw + + +render :: FontSelector Double -> FilePath -> Int -> Int -> BackendProgram a -> IO () +render fonts f w h m = do + let env = createEnv bitmapAlignmentFns (fromIntegral w) (fromIntegral h) fonts + let (d, _) = runBackend env m + fst $ renderDia Cairo (CairoOptions f (dims $ V2 (fromIntegral w) (fromIntegral h)) PNG False) d diff --git a/tests/Drawing/Tests.hs b/tests/Drawing/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Drawing/Tests.hs @@ -0,0 +1,280 @@ + +module Drawing.Tests where + +import Data.Monoid +import Data.Default.Class +import Data.Colour +import Data.Colour.Names +import Data.List + +import Graphics.Rendering.Chart.Geometry +import Graphics.Rendering.Chart.Drawing +import Graphics.Rendering.Chart.Backend + +supportLineStyle :: LineStyle +supportLineStyle = def + { _line_color = withOpacity red 0.15 + , _line_width = 2 + , _line_dashes = [] + , _line_cap = LineCapButt + , _line_join = LineJoinBevel + } + +withTestEnv :: BackendProgram a -> BackendProgram a +withTestEnv m = do + let p = rectPath $ Rect (Point 0 0) (Point 500 500) + withFillStyle (solidFillStyle $ opaque white) $ fillPath p >> m + +withCenterRot :: Double -> Int -> Int -> BackendProgram a -> BackendProgram a +withCenterRot a x y m = + withTranslation (Point (fromIntegral x) + (fromIntegral y)) $ withRotation a $ m + +tests :: [(String, Int, Int, BackendProgram ())] +tests = [ ("lines", 500, 500, testLines) + , ("arcs" , 500, 500, testArcs) + , ("text" , 500, 500, testText) + , ("fill" , 500, 500, testFill) + , ("clip" , 500, 500, testClip) + , ("paths" , 500, 500, testPaths) + , ("text-metrics" , 500, 500, testTextMetrics) + ] ++ ( (flip map) testEnvironments + $ \(name, env) -> ("environment-" ++ name, 500, 500, env) + ) + +testPaths :: BackendProgram () +testPaths = withTestEnv + $ withLineStyle (def { _line_width = 10, _line_join = LineJoinMiter }) + $ withFillStyle (solidFillStyle $ opaque red) + $ do + let distantArc = moveTo' 10 10 + <> lineTo' 10 50 + <> arcNeg' 50 30 20 (pi / 2) (-(pi / 2)) + strokePath $ distantArc + withTranslation (Point 90 0) $ strokePath $ distantArc <> close + withTranslation (Point 180 0) $ fillPath $ distantArc + + let multiArc = arcNeg' 30 150 20 pi 0 + <> arc' 90 150 40 pi (2*pi) + <> arcNeg' 190 150 60 pi (0) + strokePath $ multiArc + withTranslation (Point 0 100) $ strokePath $ multiArc <> close + withTranslation (Point 0 200) $ fillPath $ multiArc <> close + + let multiDistArc = arc' 380 150 60 pi (2*pi) + <> arc' 350 130 60 0 pi + strokePath $ multiDistArc + withTranslation (Point 0 140) $ strokePath $ multiDistArc <> close + withTranslation (Point 0 280) $ fillPath $ multiDistArc <> close + +testTextMetrics :: BackendProgram () +testTextMetrics = withTestEnv $ do + + withFontStyle (def { _font_size = 20 }) $ do + let text = "Text Example" + tm <- textSize text + drawText (Point 100 125) text + -- Support Lines + withLineStyle supportLineStyle $ do + -- Baseline + strokePath $ moveTo' 0 125 <> lineTo' 500 125 + -- Above the text + strokePath $ moveTo' 0 (125 - textSizeAscent tm) <> lineTo' 500 (125 - textSizeAscent tm) + -- Beneath the text + strokePath $ moveTo' 0 (125 + textSizeDescent tm) <> lineTo' 500 (125 + textSizeDescent tm) + -- Right side of text + strokePath $ moveTo' (100 + textSizeWidth tm) 0 <> lineTo' (100 + textSizeWidth tm) 250 + -- Left side of text + strokePath $ moveTo' 100 0 <> lineTo' 100 250 + + withFontStyle (def { _font_size = 15 }) $ do + (flip mapM_) [ (VTA_Top, "Top", 10) + , (VTA_Centre, "Centre", 50) + , (VTA_BaseLine, "BaseLine", 110) + , (VTA_Bottom, "Bottom", 190) ] $ \(vta, name, offset) -> do + drawTextA HTA_Left vta (Point offset 375) name + + withFontStyle (def { _font_size = 15 }) $ do + (flip mapM_) [ (HTA_Left, "Left", 10) + , (HTA_Centre, "Centre", 40) + , (HTA_Right, "Right", 70) ] $ \(hta, name, offset) -> do + drawTextA hta VTA_Top (Point 375 $ 250 + offset) name + + withLineStyle supportLineStyle $ do + strokePath $ moveTo' 0 375 <> lineTo' 250 375 + strokePath $ moveTo' 375 250 <> lineTo' 375 500 + + +testClip :: BackendProgram () +testClip = withTestEnv $ do + let p = rectPath $ Rect (Point 0 0) (Point 500 500) + withFillStyle (solidFillStyle $ opaque blue) $ fillPath p + withClipRegion (Rect (Point 100 100) (Point 300 300)) $ do + withFillStyle (solidFillStyle $ opaque green) $ fillPath p + withClipRegion (Rect (Point 200 200) (Point 400 400)) $ do + withFillStyle (solidFillStyle $ withOpacity red 0.5) $ fillPath p + withClipRegion (Rect (Point 150 50) (Point 400 150)) $ do + withFillStyle (solidFillStyle $ opaque red) $ fillPath p + +testFill :: BackendProgram () +testFill = withTestEnv $ do + withFillStyle (solidFillStyle $ opaque green) $ do + fillPath $ arc' 100 100 75 0 (1.5 * pi) + withFillStyle (solidFillStyle $ opaque blue) $ do + fillPath $ moveTo' 475 475 + <> lineTo' 325 475 + <> lineTo' 325 325 + <> close + withFillStyle (solidFillStyle $ withOpacity teal 0.6) $ do + fillPath $ moveTo' 125 125 + <> lineTo' 400 125 + <> lineTo' 400 400 + <> lineTo' 125 400 + <> moveTo' 450 450 + <> lineTo' 500 450 + <> lineTo' 500 500 + <> lineTo' 450 500 + fillPath $ arcNeg' 125 400 75 0 (1.5 * pi) + <> lineTo' 125 400 + +testEnvironments :: [(String, BackendProgram ())] +testEnvironments = + let envs = [ ("fill", withFillStyle $ solidFillStyle $ opaque green) + , ("font", withFontStyle $ def { _font_color = opaque red }) + , ("line", withLineStyle $ def { _line_color = opaque blue, _line_width = 10 }) + ] + in (flip map) (permutations envs) $ \envPerm -> + let name = concatMap fst envPerm + in ( name + , withTestEnv $ foldr1 (.) (map snd envPerm) $ do + strokePath $ moveTo' 475 10 + <> lineTo' 475 250 + fillPath $ arc' 450 450 40 0 (2*pi) + drawText (Point 10 30) name + drawText (Point 10 50) "Green Fill, Red Font, Blue Line" + ) + + +testText :: BackendProgram () +testText = withTestEnv $ do + drawText (Point 10 50) "No Scale" + withTranslation (Point 10 70) $ do + withScale (Vector 2 1) $ drawText (Point 0 0) "Horz. Scale" + withTranslation (Point 10 100) $ do + withScale (Vector 1 3) $ drawText (Point 0 0) "Vert. Scale" + + drawText (Point 150 50) "Size * 1" + withFontStyle (def { _font_size = _font_size def * 2 }) $ drawText (Point 150 70) "Size * 2" + withFontStyle (def { _font_size = _font_size def * 3 }) $ drawText (Point 150 100) "Size * 3" + + (flip mapM_) ([ 10, 12, 14 ] `zip` [0..]) $ \(size, n) -> do + withFontStyle (def { _font_weight = FontWeightNormal, _font_size = size }) $ + drawText (Point 10 $ 120 + n * 20) "Normal Weight" + withFontStyle (def { _font_weight = FontWeightBold, _font_size = size }) $ + drawText (Point 150 $ 120 + n * 20) "Bold Weight" + + withFontStyle (def { _font_slant = FontSlantNormal, _font_size = size }) $ + drawText (Point 10 $ 180 + n * 20) "Normal Slant" + withFontStyle (def { _font_slant = FontSlantItalic, _font_size = size }) $ + drawText (Point 150 $ 180 + n * 20) "Italic Slant" + withFontStyle (def { _font_slant = FontSlantOblique, _font_size = size }) $ + drawText (Point 290 $ 180 + n * 20) "Oblique Slant" + + + (flip mapM_) ([ 10, 12, 14 ] `zip` [0..]) $ \(size, n) -> do + withFontStyle (def { _font_name = "sans-serif", _font_size = size }) $ + drawText (Point 10 $ 240 + n * 20) "Sans-Serif" + withFontStyle (def { _font_name = "serif", _font_size = size }) $ + drawText (Point 150 $ 240 + n * 20) "Serif" + withFontStyle (def { _font_name = "monospace", _font_size = size }) $ + drawText (Point 290 $ 240 + n * 20) "Monospace" + + (flip mapM_) ([ (opaque red, 12) + , (withOpacity blue 0.3, 14) + , (opaque green, 17) ] `zip` [0..] ) $ \((cl, size), n) -> do + withFontStyle (def { _font_color = cl, _font_size = size }) $ + drawText (Point (10 + (n * 140)) 300) "Colored" + + (flip mapM_) [0..7] $ \n -> do + withTranslation (Point 250 400) $ + withRotation (n * 0.125 * 2 * pi) $ + drawText (Point 30 0) $ show n + -- Support Lines + withLineStyle supportLineStyle $ do + strokePath $ moveTo' 0 400 <> lineTo' 500 400 + strokePath $ moveTo' 250 300 <> lineTo' 250 500 + +testArcs :: BackendProgram () +testArcs = withTestEnv $ do + (flip mapM_) ( [ def { _line_cap = LineCapButt , _line_join = LineJoinMiter, _line_width = 10 } + , def { _line_cap = LineCapRound , _line_join = LineJoinRound, _line_width = 10 } + , def { _line_cap = LineCapSquare, _line_join = LineJoinBevel, _line_width = 10 } + , def { _line_width = 10 } + ] `zip` [0..] ) + $ \(ls, n) -> do + withLineStyle ls $ do + strokePath $ arc' 250 250 (20 * (n + 1)) (n * 0.5 * pi) ((n+1) * 0.5 * pi) + strokePath $ arc' 250 250 (125 + 30 * (n + 1)) + (n * 0.5 * pi + 0.25 * pi) + ((n+1) * 0.5 * pi + 0.25 * pi) + <> close + -- Support Lines + withLineStyle supportLineStyle $ do + strokePath $ moveTo' 250 0 <> lineTo' 250 500 + strokePath $ moveTo' 0 250 <> lineTo' 500 250 + strokePath $ moveTo' 0 0 <> lineTo' 500 500 + strokePath $ moveTo' 500 0 <> lineTo' 0 500 + withCenterRot (0.0 * pi) 250 250 $ drawText (Point 100 0) $ "0" + withCenterRot (0.5 * pi) 250 250 $ drawText (Point 50 0) $ "1/2 * pi" + withCenterRot (1.0 * pi) 250 250 $ drawText (Point 75 0) $ "1 * pi" + withCenterRot (1.5 * pi) 250 250 $ drawText (Point 100 0) $ "3/2 * pi" + +testLines :: BackendProgram () +testLines = withTestEnv $ do + -- Test Line Caps + (flip mapM_) [ (def { _line_cap = LineCapButt , _line_width = 10 }, 0) + , (def { _line_cap = LineCapRound , _line_width = 10 }, 20) + , (def { _line_cap = LineCapSquare, _line_width = 10 }, 40) + ] $ \(ls, offset) -> do + withLineStyle ls $ do + strokePath $ moveTo' 125 (10 + offset) + <> lineTo' 375 (10 + offset) + -- Test Line Joins + (flip mapM_) [ (def { _line_join = LineJoinMiter, _line_width = 10 }, 0) + , (def { _line_join = LineJoinRound, _line_width = 10 }, 60) + , (def { _line_join = LineJoinBevel, _line_width = 10 }, 120) + ] $ \(ls, offset) -> do + withLineStyle ls $ do + strokePath $ moveTo' 125 (70 + offset) + <> lineTo' 375 (70 + offset) + <> lineTo' 250 (110 + offset) + <> close + -- Test Line Color & Width + (flip mapM_) [ (def { _line_color = opaque blue, _line_width = 1 }, 0) + , (def { _line_color = opaque green, _line_width = 5 }, 10) + , (def { _line_color = opaque magenta, _line_width = 20 }, 35) + , (def { _line_color = withOpacity cyan 0.2, _line_width = 10 }, 60) + , (def { _line_color = withOpacity cyan 0.4, _line_width = 10 }, 80) + , (def { _line_color = withOpacity cyan 0.6, _line_width = 10 }, 100) + , (def { _line_color = withOpacity cyan 0.8, _line_width = 10 }, 120) + , (def { _line_color = withOpacity cyan 1.0, _line_width = 10 }, 140) + ] $ \(ls, offset) -> do + withLineStyle ls $ do + strokePath $ moveTo' 10 (250 + offset) + <> lineTo' 490 (250 + offset) + -- Test Line Dashes + (flip mapM_) [ (def { _line_dashes = [] , _line_width = 10 }, 0) + , (def { _line_dashes = [10] , _line_width = 10 }, 20) + , (def { _line_dashes = [1,5,2], _line_width = 10 }, 40) + , (def { _line_dashes = [1,5,2,3,4,6,7], _line_width = 10 }, 60) + ] $ \(ls, offset) -> do + withLineStyle ls $ do + strokePath $ moveTo' 10 (410 + offset) + <> lineTo' 490 (410 + offset) + -- Support Lines + withLineStyle supportLineStyle $ do + strokePath $ moveTo' 10 0 <> lineTo' 10 500 + strokePath $ moveTo' 250 0 <> lineTo' 250 500 + strokePath $ moveTo' 490 0 <> lineTo' 490 500 + strokePath $ moveTo' 375 0 <> lineTo' 375 500 + strokePath $ moveTo' 125 0 <> lineTo' 125 500 diff --git a/tests/ExampleStocks.hs b/tests/ExampleStocks.hs new file mode 100644 --- /dev/null +++ b/tests/ExampleStocks.hs @@ -0,0 +1,219 @@ +module ExampleStocks where +import Data.Time.Calendar +import Data.Time.LocalTime + +mkDate :: Integer -> LocalTime +mkDate jday = + LocalTime (ModifiedJulianDay jday) midnight + +-- Price data imported from Yahoo: low, open, close, high + +pricesAAPL :: [(LocalTime,(Double,Double,Double,Double))] +pricesMSFT :: [(LocalTime,(Double,Double,Double,Double))] +pricesARMH :: [(LocalTime,(Double,Double,Double,Double))] + +pricesAAPL = + [ (mkDate 55105,(180.7,185.35,180.86,186.22)) + , (mkDate 55104,(182.61,186.13,185.35,186.45)) + , (mkDate 55103,(184.31,186.73,185.38,187.4)) + , (mkDate 55102,(183.33,183.87,186.15,186.68)) + , (mkDate 55099,(181.44,182.01,182.37,185.5)) + , (mkDate 55098,(182.77,187.2,183.82,187.7)) + , (mkDate 55097,(185.03,185.4,185.5,188.9)) + , (mkDate 55096,(182.85,185.19,184.48,185.38)) + , (mkDate 55095,(181.62,184.29,184.02,185.16)) + , (mkDate 55092,(184.76,185.83,185.02,186.55)) + , (mkDate 55091,(181.97,181.98,184.55,186.79)) + , (mkDate 55090,(177.88,177.99,181.87,182.75)) + , (mkDate 55089,(173.59,174.04,175.16,175.65)) + , (mkDate 55088,(170.25,170.83,173.72,173.9)) + , (mkDate 55085,(170.87,172.91,172.16,173.18)) + , (mkDate 55084,(170.81,172.06,172.56,173.25)) + , (mkDate 55083,(169.7,172.78,171.14,174.47)) + , (mkDate 55082,(172.0,172.98,172.93,173.14)) + , (mkDate 55078,(167.09,167.28,170.31,170.7)) + , (mkDate 55077,(165.0,166.44,166.55,167.1)) + , (mkDate 55076,(164.11,164.62,165.18,167.61)) + , (mkDate 55075,(164.94,167.99,165.3,170.0)) + , (mkDate 55074,(166.5,168.16,168.21,168.85)) + , (mkDate 55071,(168.53,172.27,170.05,172.49)) + , (mkDate 55070,(164.83,168.75,169.45,169.57)) + , (mkDate 55069,(166.76,168.92,167.41,169.55)) + , (mkDate 55068,(169.13,169.46,169.4,170.94)) + , (mkDate 55067,(168.27,170.12,169.06,170.71)) + , (mkDate 55064,(166.8,167.65,169.22,169.37)) + , (mkDate 55063,(164.61,164.98,166.33,166.72)) + , (mkDate 55062,(162.45,162.75,164.6,165.3)) + , (mkDate 55061,(161.41,161.63,164.0,164.24)) + , (mkDate 55060,(159.42,163.55,159.59,163.59)) + , (mkDate 55057,(165.53,167.94,166.78,168.23)) + , (mkDate 55056,(166.5,166.65,168.42,168.67)) + , (mkDate 55055,(162.46,162.55,165.31,166.71)) + , (mkDate 55054,(161.88,163.69,162.83,164.38)) + , (mkDate 55053,(163.66,165.66,164.72,166.6)) + , (mkDate 55050,(164.8,165.49,165.51,166.6)) + , (mkDate 55049,(163.09,165.58,163.91,166.51)) + , (mkDate 55048,(164.21,165.75,165.11,167.39)) + , (mkDate 55047,(164.21,164.93,165.55,165.57)) + , (mkDate 55046,(164.87,165.21,166.43,166.64)) + , (mkDate 55043,(162.91,162.99,163.39,165.0)) + , (mkDate 55042,(161.5,161.7,162.79,164.72)) + , (mkDate 55041,(158.25,158.9,160.03,160.45)) + , (mkDate 55040,(157.6,158.88,160.0,160.1)) + , (mkDate 55039,(157.26,160.17,160.1,160.88)) + , (mkDate 55036,(156.5,156.95,159.99,160.0)) + , (mkDate 55035,(155.56,156.63,157.82,158.44)) + , (mkDate 55034,(156.11,157.79,156.74,158.73)) + , (mkDate 55033,(149.75,153.29,151.51,153.43)) + , (mkDate 55032,(150.89,153.27,152.91,155.04)) + , (mkDate 55029,(148.63,149.08,151.75,152.02)) + , (mkDate 55028,(145.57,145.76,147.52,148.02)) + , (mkDate 55027,(144.32,145.04,146.88,147.0)) + , (mkDate 55026,(141.16,142.03,142.27,143.18)) + , (mkDate 55025,(137.53,139.54,142.34,142.34)) + , (mkDate 55022,(136.32,136.34,138.52,138.97)) + , (mkDate 55021,(135.93,137.76,136.36,137.99)) + , (mkDate 55020,(134.42,135.92,137.22,138.04)) + , (mkDate 55019,(135.18,138.48,135.4,139.68)) + , (mkDate 55018,(136.25,138.7,138.61,138.99)) + , (mkDate 55014,(139.79,141.25,140.02,142.83)) + , (mkDate 55013,(142.52,143.5,142.83,144.66)) + ] + +pricesMSFT = + [ (mkDate 55105,(24.8,25.41,24.88,25.47)) + , (mkDate 55104,(25.38,25.76,25.72,25.99)) + , (mkDate 55103,(25.69,25.91,25.75,25.96)) + , (mkDate 55102,(25.6,25.6,25.83,26.16)) + , (mkDate 55099,(25.52,25.69,25.55,25.82)) + , (mkDate 55098,(25.66,25.92,25.94,26.11)) + , (mkDate 55097,(25.64,25.92,25.71,26.25)) + , (mkDate 55096,(25.29,25.4,25.77,25.82)) + , (mkDate 55095,(25.1,25.11,25.3,25.37)) + , (mkDate 55092,(25.1,25.46,25.26,25.48)) + , (mkDate 55091,(25.06,25.06,25.3,25.38)) + , (mkDate 55090,(24.95,25.25,25.2,25.35)) + , (mkDate 55089,(24.86,24.97,25.2,25.27)) + , (mkDate 55088,(24.64,24.65,25.0,25.09)) + , (mkDate 55085,(24.81,24.93,24.86,25.17)) + , (mkDate 55084,(24.65,24.8,25.0,25.05)) + , (mkDate 55083,(24.67,24.74,24.78,24.95)) + , (mkDate 55082,(24.41,24.62,24.82,24.84)) + , (mkDate 55078,(24.08,24.09,24.62,24.8)) + , (mkDate 55077,(23.76,23.91,24.11,24.14)) + , (mkDate 55076,(23.78,23.82,23.86,24.14)) + , (mkDate 55075,(23.9,24.35,24.0,24.74)) + , (mkDate 55074,(24.29,24.57,24.65,24.85)) + , (mkDate 55071,(24.61,25.07,24.68,25.49)) + , (mkDate 55070,(24.3,24.41,24.69,24.78)) + , (mkDate 55069,(24.42,24.59,24.55,24.75)) + , (mkDate 55068,(24.46,24.6,24.64,24.82)) + , (mkDate 55067,(24.28,24.41,24.64,24.73)) + , (mkDate 55064,(23.77,23.93,24.41,24.42)) + , (mkDate 55063,(23.54,23.6,23.67,23.87)) + , (mkDate 55062,(23.25,23.25,23.65,23.72)) + , (mkDate 55061,(23.27,23.29,23.58,23.65)) + , (mkDate 55060,(23.23,23.32,23.25,23.6)) + , (mkDate 55057,(23.51,23.62,23.69,23.8)) + , (mkDate 55056,(23.4,23.63,23.62,23.85)) + , (mkDate 55055,(23.03,23.13,23.53,23.9)) + , (mkDate 55054,(23.05,23.32,23.13,23.4)) + , (mkDate 55053,(23.3,23.46,23.42,23.55)) + , (mkDate 55050,(23.5,23.75,23.56,23.82)) + , (mkDate 55049,(23.27,23.93,23.46,23.98)) + , (mkDate 55048,(23.79,23.84,23.81,24.25)) + , (mkDate 55047,(23.53,23.68,23.77,23.79)) + , (mkDate 55046,(23.5,23.82,23.83,23.86)) + , (mkDate 55043,(23.5,23.77,23.52,24.07)) + , (mkDate 55042,(23.71,24.2,23.81,24.43)) + , (mkDate 55041,(23.34,23.73,23.8,23.91)) + , (mkDate 55040,(22.9,22.99,23.47,23.55)) + , (mkDate 55039,(22.9,23.44,23.11,23.45)) + , (mkDate 55036,(22.81,23.61,23.45,23.89)) + , (mkDate 55035,(24.84,24.93,25.56,25.72)) + , (mkDate 55034,(24.51,24.7,24.8,24.9)) + , (mkDate 55033,(24.37,24.69,24.83,24.83)) + , (mkDate 55032,(24.15,24.44,24.53,24.53)) + , (mkDate 55029,(24.1,24.4,24.29,24.45)) + , (mkDate 55028,(23.86,23.93,24.44,24.44)) + , (mkDate 55027,(23.56,23.75,24.12,24.12)) + , (mkDate 55026,(22.86,23.2,23.11,23.22)) + , (mkDate 55025,(22.14,22.42,23.23,23.29)) + , (mkDate 55022,(22.15,22.19,22.39,22.54)) + , (mkDate 55021,(22.37,22.65,22.44,22.81)) + , (mkDate 55020,(22.0,22.31,22.56,22.69)) + , (mkDate 55019,(22.46,23.08,22.53,23.14)) + , (mkDate 55018,(22.87,23.21,23.2,23.28)) + , (mkDate 55014,(23.21,23.76,23.37,24.04)) + , (mkDate 55013,(23.96,24.05,24.04,24.3)) + ] + +pricesARMH = + [ (mkDate 55105,(6.65,6.83,6.65,6.86)) + , (mkDate 55104,(6.87,7.0,7.0,7.02)) + , (mkDate 55103,(6.88,6.92,6.95,6.97)) + , (mkDate 55102,(6.62,6.63,6.81,6.82)) + , (mkDate 55099,(6.69,6.88,6.72,6.88)) + , (mkDate 55098,(6.55,6.69,6.64,6.88)) + , (mkDate 55097,(6.8,6.87,6.8,6.94)) + , (mkDate 55096,(6.67,6.68,6.74,6.78)) + , (mkDate 55095,(6.62,6.67,6.7,6.77)) + , (mkDate 55092,(6.63,6.71,6.7,6.76)) + , (mkDate 55091,(6.64,6.7,6.67,6.76)) + , (mkDate 55090,(6.76,6.84,6.77,6.85)) + , (mkDate 55089,(6.69,6.73,6.84,6.9)) + , (mkDate 55088,(6.73,6.74,6.8,6.81)) + , (mkDate 55085,(6.84,7.05,6.87,7.07)) + , (mkDate 55084,(6.65,6.7,6.94,6.97)) + , (mkDate 55083,(6.65,6.71,6.7,6.75)) + , (mkDate 55082,(6.56,6.58,6.65,6.68)) + , (mkDate 55078,(6.16,6.18,6.39,6.41)) + , (mkDate 55077,(6.11,6.19,6.21,6.24)) + , (mkDate 55076,(6.03,6.07,6.09,6.14)) + , (mkDate 55075,(6.14,6.22,6.24,6.31)) + , (mkDate 55074,(6.3,6.45,6.35,6.45)) + , (mkDate 55071,(6.4,6.5,6.47,6.56)) + , (mkDate 55070,(6.13,6.18,6.35,6.39)) + , (mkDate 55069,(6.1,6.12,6.16,6.2)) + , (mkDate 55068,(6.14,6.3,6.17,6.3)) + , (mkDate 55067,(6.19,6.29,6.21,6.34)) + , (mkDate 55064,(6.25,6.32,6.3,6.38)) + , (mkDate 55063,(6.18,6.2,6.25,6.27)) + , (mkDate 55062,(6.09,6.11,6.19,6.22)) + , (mkDate 55061,(6.14,6.14,6.23,6.28)) + , (mkDate 55060,(5.91,6.02,5.98,6.04)) + , (mkDate 55057,(6.04,6.15,6.2,6.21)) + , (mkDate 55056,(6.1,6.18,6.22,6.26)) + , (mkDate 55055,(6.07,6.07,6.22,6.3)) + , (mkDate 55054,(6.09,6.23,6.14,6.23)) + , (mkDate 55053,(6.19,6.39,6.23,6.4)) + , (mkDate 55050,(6.25,6.31,6.32,6.41)) + , (mkDate 55049,(6.2,6.42,6.24,6.42)) + , (mkDate 55048,(6.4,6.55,6.46,6.55)) + , (mkDate 55047,(6.5,6.52,6.67,6.7)) + , (mkDate 55046,(6.5,6.51,6.58,6.6)) + , (mkDate 55043,(6.3,6.34,6.39,6.43)) + , (mkDate 55042,(6.42,6.47,6.46,6.64)) + , (mkDate 55041,(6.14,6.37,6.22,6.49)) + , (mkDate 55040,(6.28,6.32,6.52,6.56)) + , (mkDate 55039,(6.41,6.47,6.49,6.63)) + , (mkDate 55036,(6.27,6.36,6.44,6.44)) + , (mkDate 55035,(6.47,6.48,6.52,6.55)) + , (mkDate 55034,(6.38,6.41,6.47,6.51)) + , (mkDate 55033,(6.27,6.45,6.41,6.46)) + , (mkDate 55032,(6.32,6.44,6.45,6.48)) + , (mkDate 55029,(6.23,6.25,6.37,6.45)) + , (mkDate 55028,(6.24,6.29,6.35,6.39)) + , (mkDate 55027,(6.37,6.53,6.45,6.6)) + , (mkDate 55026,(6.12,6.13,6.19,6.23)) + , (mkDate 55025,(5.98,6.02,6.12,6.13)) + , (mkDate 55022,(5.93,5.96,6.08,6.12)) + , (mkDate 55021,(5.74,5.8,5.97,6.0)) + , (mkDate 55020,(5.61,5.74,5.69,5.82)) + , (mkDate 55019,(5.68,5.82,5.69,5.84)) + , (mkDate 55018,(5.77,5.84,5.91,5.93)) + , (mkDate 55014,(5.89,6.03,5.94,6.06)) + , (mkDate 55013,(5.93,5.98,5.95,6.03)) + ] + + diff --git a/tests/GtkTestPicking.hs b/tests/GtkTestPicking.hs new file mode 100644 --- /dev/null +++ b/tests/GtkTestPicking.hs @@ -0,0 +1,117 @@ +module GtkTestPicking where + +import Graphics.Rendering.Chart +import Graphics.Rendering.Chart.Layout(layoutLRToRenderable) +import Graphics.Rendering.Chart.Grid +import Graphics.Rendering.Chart.Backend.Cairo +import qualified Graphics.UI.Gtk as G +import qualified Graphics.UI.Gtk.Gdk.Events as GE +import qualified Graphics.Rendering.Cairo as C + +import Data.Time.LocalTime +import Data.Colour +import Data.Colour.Names +import Data.Colour.SRGB +import Data.Default.Class +import Control.Lens +import Data.IORef +import System.Environment(getArgs) +import Prices(prices2) + +type PickType = LayoutPick LocalTime Double Double + +chart :: [(LocalTime,Double,Double)] + -> Bool -> Double -> Renderable (LayoutPick LocalTime Double Double) +chart prices showMinMax lwidth = layoutLRToRenderable layout + where + + lineStyle c = line_width .~ 3 * lwidth + $ line_color .~ c + $ def ^. plot_lines_style + + limitLineStyle c = line_width .~ lwidth + $ line_color .~ opaque c + $ line_dashes .~ [5,10] + $ def ^. plot_lines_style + + price1 = plot_lines_style .~ lineStyle (opaque blue) + $ plot_lines_values .~ [[ (d, v) | (d,v,_) <- prices]] + $ plot_lines_title .~ "price 1" + $ def + + price2 = plot_lines_style .~ lineStyle (opaque green) + $ plot_lines_values .~ [[ (d, v) | (d,_,v) <- prices]] + $ plot_lines_title .~ "price 2" + $ def + + (min1,max1) = (minimum [v | (_,v,_) <- prices],maximum [v | (_,v,_) <- prices]) + (min2,max2) = (minimum [v | (_,_,v) <- prices],maximum [v | (_,_,v) <- prices]) + limits | showMinMax = [ Left $ hlinePlot "min/max" (limitLineStyle blue) min1, + Left $ hlinePlot "" (limitLineStyle blue) max1, + Right $ hlinePlot "min/max" (limitLineStyle green) min2, + Right $ hlinePlot "" (limitLineStyle green) max2 ] + | otherwise = [] + + bg = opaque $ sRGB 0 0 0.25 + fg = opaque white + fg1 = opaque $ sRGB 0.0 0.0 0.15 + + layout = layoutlr_title .~"Price History" + $ layoutlr_background .~ solidFillStyle bg + $ layoutlr_axes_styles %~ (axis_grid_style .~ solidLine 1 fg1) + $ layoutlr_left_axis . laxis_override .~ axisGridHide + $ layoutlr_right_axis . laxis_override .~ axisGridHide + $ layoutlr_x_axis . laxis_override .~ axisGridHide + $ layoutlr_plots .~ ([Left (toPlot price1), Right (toPlot price2)] ++ limits) + $ layoutlr_grid_last .~ False + $ layoutlr_foreground .~ fg + $ def + +updateCanvas :: Renderable a -> G.DrawingArea -> IORef (Maybe (PickFn a)) -> IO Bool +updateCanvas chart canvas pickfv = do + win <- G.widgetGetDrawWindow canvas + (width, height) <- G.widgetGetSize canvas + let sz = (fromIntegral width,fromIntegral height) + pickf <- G.renderWithDrawable win $ runBackend (defaultEnv bitmapAlignmentFns) (render chart sz) + writeIORef pickfv (Just pickf) + return True + +createRenderableWindow :: (Show a) => Renderable a -> Int -> Int -> IO G.Window +createRenderableWindow chart windowWidth windowHeight = do + pickfv <- newIORef Nothing + window <- G.windowNew + canvas <- G.drawingAreaNew + G.widgetSetSizeRequest window windowWidth windowHeight + G.onExpose canvas $ const (updateCanvas chart canvas pickfv) + G.onButtonPress canvas $ \(GE.Button{GE.eventX=x,GE.eventY=y}) -> do + print (x,y) + (Just pickf) <- readIORef pickfv + print (pickf (Point x y)) + return True + G.set window [G.containerChild G.:= canvas] + return window + +chartWindow = do + window <- createRenderableWindow (chart prices2 True 1.00) 640 480 + G.onDestroy window G.mainQuit + G.widgetShowAll window + G.mainGUI + +gridWindow = do + window <- createRenderableWindow (gridToRenderable testgrid) 640 480 + G.onDestroy window G.mainQuit + G.widgetShowAll window + G.mainGUI + where + testgrid :: Grid (Renderable String) + testgrid = aboveN + [ besideN [ f "AAAAA", e, f "BBBBB" ] + , besideN [ f "CCCCC", e, f "DDDDD" ] + ] + f s = tval $ setPickFn (const (Just s)) $ label def HTA_Centre VTA_Centre s + e = tval $ spacer (20,20) + + +main = do + G.initGUI + chartWindow diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,70 @@ +module Main where + + +import Graphics.Rendering.Chart +import Graphics.Rendering.Chart.Backend.Cairo + +import System.Environment(getArgs,getProgName) +import qualified GtkTestPicking +import qualified DiagramsCairo +import qualified DiagramsSVG +import qualified DiagramsEPS +import qualified CompareFonts +import qualified Drawing.Cairo +import qualified Drawing.DiagramsCairo + +import Control.Monad +import Tests + +chooseLineWidth PNG = 1.0 +chooseLineWidth PDF = 0.25 +chooseLineWidth PS = 0.25 +chooseLineWidth SVG = 0.25 + +main = do + args <- getArgs + main1 args + +main1 :: [String] -> IO () +main1 ("charts-cairo":"--pdf":tests) = renderTestsToFiles PDF ".pdf" tests +main1 ("charts-cairo":"--svg":tests) = renderTestsToFiles SVG ".svg" tests +main1 ("charts-cairo":"--ps":tests) = renderTestsToFiles PS ".ps" tests +main1 ("charts-cairo":"--png":tests) = renderTestsToFiles PNG ".png" tests + +main1 ("charts-diagrams":"--cairo":args) = DiagramsCairo.main1 args +main1 ("charts-diagrams":"--svg":args) = DiagramsSVG.main1 args +main1 ("charts-diagrams":"--eps":args) = DiagramsEPS.main1 args + +main1 ("drawing-cairo":[]) = Drawing.Cairo.main +main1 ("drawing-diagrams":[]) = Drawing.DiagramsCairo.main + +main1 ("compare-fonts":[]) = CompareFonts.main +main1 ("gtk-picking":[]) = GtkTestPicking.main + +main1 _ = usage + +usage :: IO () +usage = do + progname <- getProgName + putStrLn "Usage:" + putStrLn $ " " ++ progname ++ " charts-cairo (--pdf|--svg|--ps|--png) chart-name..." + putStrLn $ " " ++ progname ++ " charts-diagrams (--cairo|--svg|--eps) chart-name..." + putStrLn $ " " ++ progname ++ " drawing-cairo" + putStrLn $ " " ++ progname ++ " drawing-diagrams" + putStrLn $ " " ++ progname ++ " compare-fonts" + putStrLn $ " " ++ progname ++ " gtk-picking" + +chartsCairo :: [String] -> IO () +chartsCairo ("--pdf":tests) = renderTestsToFiles PDF ".pdf" tests +chartsCairo ("--svg":tests) = renderTestsToFiles SVG ".svg" tests +chartsCairo ("--ps":tests) = renderTestsToFiles PS ".ps" tests +chartsCairo ("--png":tests) = renderTestsToFiles PNG ".png" tests +chartsCairo (tests) = renderTestsToFiles PNG ".png" tests + +renderTestsToFiles :: FileFormat -> String -> [String] -> IO () +renderTestsToFiles fmt suffix tests = mapM_ doTest (getTests tests) + where + doTest (n,sz,rf) = do + let f = n++suffix + putStrLn (f ++ "...") + void $ renderableToFile (FileOptions sz fmt) f (rf (chooseLineWidth fmt)) diff --git a/tests/Prices.hs b/tests/Prices.hs new file mode 100644 --- /dev/null +++ b/tests/Prices.hs @@ -0,0 +1,392 @@ +module Prices where + +import Data.Time.Calendar +import Data.Time.LocalTime + +rawPrices = [ + (03,05,2005, 16.18, 42.02), + (04,05,2005, 16.25, 42.31), + (05,05,2005, 16.50, 42.95), + (06,05,2005, 16.52, 43.50), + (09,05,2005, 16.84, 44.91), + (10,05,2005, 16.70, 44.55), + (11,05,2005, 16.43, 43.63), + (12,05,2005, 16.29, 43.18), + (13,05,2005, 15.95, 42.40), + (16,05,2005, 15.55, 41.65), + (17,05,2005, 15.71, 42.17), + (18,05,2005, 15.93, 42.37), + (19,05,2005, 16.20, 42.85), + (20,05,2005, 15.88, 42.30), + (23,05,2005, 15.92, 42.53), + (24,05,2005, 16.25, 42.81), + (25,05,2005, 16.20, 42.67), + (26,05,2005, 16.05, 42.35), + (27,05,2005, 16.45, 43.12), + (30,05,2005, 16.85, 43.24), + (31,05,2005, 16.68, 42.57), + (01,06,2005, 16.85, 43.22), + (02,06,2005, 17.17, 43.85), + (03,06,2005, 17.42, 44.15), + (06,06,2005, 17.50, 44.07), + (07,06,2005, 17.37, 43.76), + (08,06,2005, 17.15, 43.21), + (09,06,2005, 17.12, 43.42), + (10,06,2005, 17.15, 43.27), + (14,06,2005, 17.34, 43.30), + (15,06,2005, 17.46, 43.90), + (16,06,2005, 17.71, 44.43), + (17,06,2005, 18.25, 45.45), + (20,06,2005, 18.23, 45.16), + (21,06,2005, 18.26, 45.54), + (22,06,2005, 18.11, 45.06), + (23,06,2005, 17.79, 44.65), + (24,06,2005, 17.76, 44.43), + (27,06,2005, 17.63, 44.22), + (28,06,2005, 18.08, 44.94), + (29,06,2005, 18.13, 44.80), + (30,06,2005, 18.15, 44.82), + (01,07,2005, 18.09, 45.12), + (04,07,2005, 18.20, 45.20), + (05,07,2005, 18.45, 45.85), + (06,07,2005, 18.40, 45.91), + (07,07,2005, 18.60, 46.35), + (08,07,2005, 18.38, 45.76), + (11,07,2005, 18.80, 46.41), + (12,07,2005, 18.60, 45.86), + (13,07,2005, 18.73, 46.00), + (14,07,2005, 18.70, 46.44), + (15,07,2005, 18.67, 46.25), + (18,07,2005, 18.54, 45.77), + (19,07,2005, 18.20, 45.21), + (20,07,2005, 18.65, 46.13), + (21,07,2005, 19.00, 46.87), + (22,07,2005, 19.09, 47.32), + (25,07,2005, 19.22, 47.36), + (26,07,2005, 19.19, 47.66), + (27,07,2005, 19.17, 47.64), + (28,07,2005, 19.15, 47.98), + (29,07,2005, 19.36, 49.12), + (01,08,2005, 19.40, 49.30), + (02,08,2005, 19.30, 49.17), + (03,08,2005, 19.52, 49.91), + (04,08,2005, 19.80, 50.60), + (05,08,2005, 19.60, 50.40), + (08,08,2005, 19.92, 50.94), + (09,08,2005, 20.34, 52.09), + (10,08,2005, 20.45, 51.42), + (11,08,2005, 20.74, 52.30), + (12,08,2005, 21.05, 53.01), + (15,08,2005, 21.16, 53.02), + (16,08,2005, 20.90, 52.74), + (17,08,2005, 20.55, 51.93), + (18,08,2005, 20.28, 51.42), + (19,08,2005, 20.68, 52.20), + (22,08,2005, 21.22, 53.10), + (23,08,2005, 21.07, 53.01), + (24,08,2005, 20.56, 52.72), + (25,08,2005, 19.90, 50.45), + (26,08,2005, 20.60, 51.42), + (29,08,2005, 20.03, 50.10), + (30,08,2005, 20.47, 50.74), + (31,08,2005, 20.46, 50.31), + (01,09,2005, 20.93, 51.80), + (02,09,2005, 20.83, 51.60), + (05,09,2005, 20.46, 51.56), + (06,09,2005, 20.25, 50.60), + (07,09,2005, 20.55, 51.54), + (08,09,2005, 20.03, 50.55), + (09,09,2005, 20.19, 50.90), + (12,09,2005, 20.20, 51.27), + (13,09,2005, 20.47, 51.91), + (14,09,2005, 20.59, 51.59), + (15,09,2005, 20.70, 52.44), + (16,09,2005, 20.99, 53.77), + (19,09,2005, 21.39, 55.45), + (20,09,2005, 21.53, 55.88), + (21,09,2005, 20.89, 54.63), + (22,09,2005, 21.41, 55.50), + (23,09,2005, 21.30, 55.56), + (26,09,2005, 21.86, 57.55), + (27,09,2005, 22.01, 58.56), + (28,09,2005, 21.81, 58.26), + (29,09,2005, 22.48, 60.01), + (30,09,2005, 22.25, 59.14), + (03,10,2005, 22.30, 58.93), + (04,10,2005, 22.20, 58.61), + (05,10,2005, 21.45, 57.10), + (06,10,2005, 20.76, 56.30), + (07,10,2005, 20.47, 56.50), + (10,10,2005, 20.72, 57.25), + (11,10,2005, 20.33, 57.00), + (12,10,2005, 20.83, 57.48), + (13,10,2005, 20.47, 56.69), + (14,10,2005, 19.98, 55.21), + (17,10,2005, 20.05, 55.95), + (18,10,2005, 20.75, 57.90), + (19,10,2005, 20.05, 56.19), + (20,10,2005, 20.01, 56.30), + (21,10,2005, 20.03, 55.82), + (24,10,2005, 19.77, 54.27), + (25,10,2005, 20.09, 54.82), + (26,10,2005, 20.42, 55.58), + (27,10,2005, 20.49, 55.80), + (28,10,2005, 20.10, 54.94), + (31,10,2005, 20.75, 56.31), + (01,11,2005, 20.89, 57.00), + (02,11,2005, 20.70, 57.11), + (03,11,2005, 21.28, 58.39), + (04,11,2005, 21.35, 58.60), + (07,11,2005, 21.09, 58.18), + (08,11,2005, 21.35, 59.80), + (09,11,2005, 21.03, 59.25), + (10,11,2005, 21.11, 59.21), + (11,11,2005, 21.12, 59.71), + (14,11,2005, 21.60, 61.24), + (15,11,2005, 21.53, 60.96), + (16,11,2005, 21.42, 60.60), + (17,11,2005, 21.40, 60.79), + (18,11,2005, 21.85, 62.45), + (21,11,2005, 21.71, 62.60), + (22,11,2005, 21.67, 61.70), + (23,11,2005, 21.55, 60.70), + (24,11,2005, 21.86, 61.89), + (25,11,2005, 22.02, 62.21), + (28,11,2005, 22.22, 62.09), + (29,11,2005, 21.83, 61.35), + (30,11,2005, 21.87, 61.76), + (01,12,2005, 21.50, 60.40), + (02,12,2005, 21.95, 61.92), + (05,12,2005, 22.03, 63.33), + (06,12,2005, 21.83, 62.99), + (07,12,2005, 21.85, 63.84), + (08,12,2005, 21.56, 63.10), + (09,12,2005, 21.80, 63.55), + (12,12,2005, 21.92, 63.60), + (13,12,2005, 21.65, 63.35), + (14,12,2005, 21.72, 63.15), + (15,12,2005, 21.69, 63.16), + (16,12,2005, 21.60, 62.63), + (19,12,2005, 21.87, 63.81), + (20,12,2005, 22.10, 65.50), + (21,12,2005, 22.50, 67.18), + (22,12,2005, 22.49, 67.75), + (23,12,2005, 22.58, 68.50), + (28,12,2005, 22.59, 68.25), + (29,12,2005, 22.93, 69.10), + (30,12,2005, 22.75, 69.00), + (03,01,2006, 23.18, 69.90), + (04,01,2006, 23.85, 71.06), + (05,01,2006, 23.60, 69.80), + (06,01,2006, 23.35, 68.80), + (09,01,2006, 24.06, 70.18), + (10,01,2006, 23.85, 69.15), + (11,01,2006, 23.88, 69.35), + (12,01,2006, 23.80, 70.19), + (13,01,2006, 23.73, 70.50), + (16,01,2006, 23.74, 71.05), + (17,01,2006, 23.96, 71.94), + (18,01,2006, 23.73, 70.25), + (19,01,2006, 24.45, 72.50), + (20,01,2006, 24.66, 74.00), + (23,01,2006, 24.47, 73.25), + (24,01,2006, 24.84, 74.25), + (25,01,2006, 25.08, 73.96), + (27,01,2006, 26.05, 76.10), + (30,01,2006, 26.58, 78.45), + (31,01,2006, 25.80, 75.82), + (01,02,2006, 25.99, 75.21), + (02,02,2006, 25.50, 74.98), + (03,02,2006, 25.53, 74.75), + (06,02,2006, 25.85, 75.57), + (07,02,2006, 25.70, 75.06), + (08,02,2006, 24.37, 72.75), + (09,02,2006, 24.68, 72.77), + (13,02,2006, 23.88, 70.95), + (14,02,2006, 24.16, 72.37), + (15,02,2006, 24.35, 71.84), + (16,02,2006, 24.29, 71.89), + (17,02,2006, 23.88, 71.65), + (20,02,2006, 24.54, 74.90), + (21,02,2006, 24.98, 75.50), + (22,02,2006, 24.90, 73.24), + (23,02,2006, 25.28, 74.69), + (24,02,2006, 24.55, 72.20), + (27,02,2006, 24.66, 73.00), + (28,02,2006, 24.25, 71.20), + (01,03,2006, 24.03, 70.25), + (02,03,2006, 24.45, 70.50), + (03,03,2006, 24.34, 70.35), + (06,03,2006, 24.51, 70.85), + (08,03,2006, 23.60, 67.95), + (09,03,2006, 23.70, 68.65), + (10,03,2006, 23.37, 67.50), + (13,03,2006, 23.93, 70.36), + (14,03,2006, 23.64, 69.45), + (15,03,2006, 23.90, 69.40), + (16,03,2006, 24.46, 70.90), + (17,03,2006, 24.70, 71.25), + (20,03,2006, 25.24, 72.85), + (21,03,2006, 25.32, 73.08), + (22,03,2006, 25.18, 72.99), + (23,03,2006, 25.57, 74.34), + (24,03,2006, 25.92, 75.23), + (27,03,2006, 26.78, 77.05), + (28,03,2006, 26.85, 77.13), + (30,03,2006, 27.60, 77.96), + (31,03,2006, 28.00, 78.85), + (03,01,2007, 23.18, 69.90), + (04,01,2007, 23.85, 71.06), + (05,01,2007, 23.60, 69.80), + (06,01,2007, 23.35, 68.80), + (09,01,2007, 24.06, 70.18), + (10,01,2007, 23.85, 69.15), + (11,01,2007, 23.88, 69.35), + (12,01,2007, 23.80, 70.19), + (13,01,2007, 23.73, 70.50), + (16,01,2007, 23.74, 71.05), + (17,01,2007, 23.96, 71.94), + (18,01,2007, 23.73, 70.25), + (19,01,2007, 24.45, 72.50), + (20,01,2007, 24.66, 74.00), + (23,01,2007, 24.47, 73.25), + (24,01,2007, 24.84, 74.25), + (25,01,2007, 25.08, 73.96), + (27,01,2007, 26.05, 76.10), + (30,01,2007, 26.58, 78.45), + (31,01,2007, 25.80, 75.82), + (01,02,2007, 25.99, 75.21), + (02,02,2007, 25.50, 74.98), + (03,02,2007, 25.53, 74.75), + (06,02,2007, 25.85, 75.57), + (07,02,2007, 25.70, 75.06), + (08,02,2007, 24.37, 72.75), + (09,02,2007, 24.68, 72.77), + (13,02,2007, 23.88, 70.95), + (14,02,2007, 24.16, 72.37), + (15,02,2007, 24.35, 71.84), + (16,02,2007, 24.29, 71.89), + (17,02,2007, 23.88, 71.65), + (20,02,2007, 24.54, 74.90), + (21,02,2007, 24.98, 75.50), + (22,02,2007, 24.90, 73.24), + (23,02,2007, 25.28, 74.69), + (24,02,2007, 24.55, 72.20), + (27,02,2007, 24.66, 73.00), + (28,02,2007, 24.25, 71.20), + (01,03,2007, 24.03, 70.25), + (02,03,2007, 24.45, 70.50), + (03,03,2007, 24.34, 70.35), + (06,03,2007, 24.51, 70.85), + (08,03,2007, 23.60, 67.95), + (09,03,2007, 23.70, 68.65), + (10,03,2007, 23.37, 67.50), + (13,03,2007, 23.93, 70.36), + (14,03,2007, 23.64, 69.45), + (15,03,2007, 23.90, 69.40), + (16,03,2007, 24.46, 70.90), + (17,03,2007, 24.70, 71.25), + (20,03,2007, 25.24, 72.85), + (21,03,2007, 25.32, 73.08), + (22,03,2007, 25.18, 72.99), + (23,03,2007, 25.57, 74.34), + (24,03,2007, 25.92, 75.23), + (27,03,2007, 26.78, 77.05), + (28,03,2007, 26.85, 77.13), + (30,03,2007, 27.60, 77.96), + (31,03,2007, 28.00, 78.85) + ] + +rawHourly = [ + (03,05,2005,00, 16.18, 42.02), + (03,05,2005,01, 16.25, 42.31), + (03,05,2005,02, 16.50, 42.95), + (03,05,2005,03, 16.52, 43.50), + (03,05,2005,04, 16.84, 44.91), + (03,05,2005,05, 16.70, 44.55), + (03,05,2005,06, 16.43, 43.63), + (03,05,2005,07, 16.29, 43.18), + (03,05,2005,08, 15.95, 42.40), + (03,05,2005,09, 15.55, 41.65), + (03,05,2005,10, 15.71, 42.17), + (03,05,2005,11, 15.93, 42.37), + (03,05,2005,12, 16.20, 42.85), + (03,05,2005,13, 15.88, 42.30), + (03,05,2005,14, 15.92, 42.53), + (03,05,2005,15, 16.25, 42.81), + (03,05,2005,16, 16.20, 42.67), + (03,05,2005,17, 16.05, 42.35), + (03,05,2005,18, 16.45, 43.12), + (03,05,2005,19, 16.85, 43.24), + (03,05,2005,20, 16.68, 42.57), + (03,05,2005,21, 16.85, 43.22), + (03,05,2005,22, 17.17, 43.85), + (03,05,2005,23, 17.42, 44.15), + (04,05,2005,00, 17.50, 44.07), + (04,05,2005,01, 17.37, 43.76), + (04,05,2005,02, 17.15, 43.21), + (04,05,2005,03, 17.12, 43.42), + (04,05,2005,04, 17.15, 43.27), + (04,05,2005,05, 17.34, 43.30), + (04,05,2005,06, 17.46, 43.90), + (04,05,2005,07, 17.71, 44.43), + (04,05,2005,08, 18.25, 45.45), + (04,05,2005,09, 18.23, 45.16), + (04,05,2005,10, 18.26, 45.54), + (04,05,2005,11, 18.11, 45.06), + (04,05,2005,12, 17.79, 44.65) + ] + +prices :: [(LocalTime,Double,Double)] +prices = [ (mkDate dd mm yyyy, p1, p2) | (dd,mm,yyyy,p1,p2) <- rawPrices ] + +hourlyPrices :: [(LocalTime,Double,Double)] +hourlyPrices = [ (mkDateTime dd mm yyyy hh 00, p1, p2) + | (dd,mm,yyyy,hh,p1,p2) <- rawHourly ] + +minutePrices :: [(LocalTime,Double,Double)] +minutePrices = [ (mkDateTime dd mm yyyy 05 hh, p1, p2) + | (dd,mm,yyyy,hh,p1,p2) <- take 24 rawHourly ] + ++ [ (mkDateTime dd mm yyyy 05 (hh+24), p1, p2) + | (dd,mm,yyyy,hh,p1,p2) <- take 24 rawHourly ] + +secondPrices :: [(LocalTime,Double,Double)] +secondPrices = [ (mkSeconds ss, p1, p2) + | (ss,(_,_,_,p1,p2)) <- zip [0..] rawPrices ] + +filterPrices prices t1 t2 = [ v | v@(d,_,_) <- prices + , let t = d in t >= t1 && t <= t2] + +prices1 = filterPrices prices (mkDate 1 1 2005) (mkDate 31 12 2005) +prices2 = filterPrices prices (mkDate 1 6 2005) (mkDate 1 9 2005) +prices3 = filterPrices prices (mkDate 1 1 2006) (mkDate 10 1 2006) +prices4 = filterPrices prices (mkDate 1 8 2005) (mkDate 31 8 2005) +prices5 = filterPrices prices (mkDate 1 6 2005) (mkDate 15 7 2005) +prices6 = filterPrices prices (mkDate 1 6 2005) (mkDate 2 7 2005) +prices7 = filterPrices prices (mkDate 20 6 2005) (mkDate 12 7 2005) +prices8 = filterPrices prices (mkDate 6 6 2005) (mkDate 9 6 2005) +prices9 = filterPrices prices (mkDate 6 6 2005) (mkDate 8 6 2005) +prices10 = hourlyPrices +prices10a = take 31 hourlyPrices +prices10b = take 15 hourlyPrices +prices11 = filterPrices hourlyPrices (mkDateTime 3 5 2005 02 30) + (mkDateTime 4 5 2005 02 30) +prices12 = filterPrices hourlyPrices (mkDateTime 3 5 2005 02 30) + (mkDateTime 3 5 2005 06 30) +prices13 = minutePrices +prices13a = take 24 minutePrices +prices13b = take 16 minutePrices +prices14 = secondPrices +prices14a = take 90 secondPrices +prices14b = take 35 secondPrices +prices14c = take 30 secondPrices +prices14d = take 7 secondPrices + +mkDate dd mm yyyy = + LocalTime (fromGregorian (fromIntegral yyyy) mm dd) midnight +mkDateTime dd mm yyyy hh nn = + LocalTime (fromGregorian (fromIntegral yyyy) mm dd) + (dayFractionToTimeOfDay ((hh*60+nn)/1440)) +mkSeconds ss = LocalTime (fromGregorian (fromIntegral 2009) 11 23) + (dayFractionToTimeOfDay (((14*60+32)*60+ss)/(1440*60))) + diff --git a/tests/Test1.hs b/tests/Test1.hs new file mode 100644 --- /dev/null +++ b/tests/Test1.hs @@ -0,0 +1,38 @@ +module Test1 where + +import Graphics.Rendering.Chart +import Data.Colour +import Data.Colour.Names +import Data.Colour.SRGB +import Control.Lens +import Data.Default.Class + +import Utils + +chart :: Double -> Renderable (LayoutPick Double Double Double) +chart lwidth = layoutToRenderable (layout lwidth) + +layout :: Double -> Layout Double Double +layout lwidth = layout' + where + layout' = layout_title .~ "Amplitude Modulation" + $ layout_plots .~ [ toPlot sinusoid1 + , toPlot sinusoid2 ] + $ layout_plot_background .~ Just (solidFillStyle $ opaque white) + $ def + + am x = (sin (x*pi/45) + 1) / 2 * (sin (x*pi/5)) + + sinusoid1 = plot_lines_values .~ [[ (x,(am x)) | x <- [0,(0.5)..400]]] + $ plot_lines_style .~ solidLine lwidth (opaque blue) + $ plot_lines_title .~"am" + $ def + + sinusoid2 = plot_points_style .~ filledCircles 2 (opaque red) + $ plot_points_values .~ [ (x,(am x)) | x <- [0,7..400]] + $ plot_points_title .~"am points" + $ def + +-- main = main' "test1" (chart 0.25) + + diff --git a/tests/Test14.hs b/tests/Test14.hs new file mode 100644 --- /dev/null +++ b/tests/Test14.hs @@ -0,0 +1,45 @@ +module Test14 where + +import Graphics.Rendering.Chart +import Data.Colour +import Data.Colour.Names +import Control.Lens +import Data.Default.Class +import Data.Time.LocalTime +import System.Random +import Prices(prices1) + +import Utils + +-- demonstrate AreaSpots + +chart :: Double -> Renderable (LayoutPick LocalTime Double Double) +chart lwidth = layoutToRenderable layout + where + layout = layout_title .~"Price History" + $ layout_background .~ solidFillStyle (opaque white) + $ layout_left_axis_visibility . axis_show_ticks .~ False + $ layout_plots .~ [ toPlot price1, toPlot spots ] + $ layout_foreground .~ opaque black + $ def + + price1 = plot_lines_style .~ lineStyle + $ plot_lines_values .~ [[ (d, v) | (d,v,_) <- prices1]] + $ plot_lines_title .~ "price 1" + $ def + + spots = area_spots_title .~ "random value" + $ area_spots_max_radius .~ 20 + $ area_spots_values .~ values + $ def + + points = map (\ (d,v,z)-> (d,v) ) values + values = [ (d, v, z) | ((d,v,_),z) <- zip prices1 zs ] + zs :: [Int] + zs = randoms $ mkStdGen 0 + + lineStyle = line_width .~ 3 * lwidth + $ line_color .~ opaque blue + $ def ^. plot_lines_style + +-- main = main' "test14" (chart 0.25) diff --git a/tests/Test14a.hs b/tests/Test14a.hs new file mode 100644 --- /dev/null +++ b/tests/Test14a.hs @@ -0,0 +1,47 @@ +module Test14a where + +import Graphics.Rendering.Chart +import Graphics.Rendering.Chart.Plot +import Data.Colour +import Data.Colour.Names +import Control.Lens +import Data.Default.Class +import Data.Time.LocalTime +import System.Random +import Prices(prices1) + +import Utils + +-- demonstrate AreaSpots4D + +chart :: Double -> Renderable (LayoutPick LocalTime Double Double) +chart lwidth = layoutToRenderable layout + where + layout = layout_title .~"Price History" + $ layout_background .~ solidFillStyle (opaque white) + $ layout_left_axis_visibility . axis_show_ticks .~ False + $ layout_plots .~ [ toPlot price1, toPlot spots ] + $ layout_foreground .~ opaque black + $ def + + price1 = plot_lines_style .~ lineStyle + $ plot_lines_values .~ [[ (d, v) | (d,v,_) <- prices1]] + $ plot_lines_title .~ "price 1" + $ def + + spots = area_spots_4d_title .~ "random value" + $ area_spots_4d_max_radius .~ 20 + $ area_spots_4d_values .~ values + $ def + + points = map (\ (d,v,z,t)-> (d,v) ) values + values = [ (d, v, z, t) | ((d,v,_),z,t) <- zip3 prices1 zs ts ] + zs,ts :: [Int] + zs = randoms $ mkStdGen 0 + ts = randomRs (-2,27) $ mkStdGen 1 + + lineStyle = line_width .~ 3 * lwidth + $ line_color .~ opaque blue + $ def ^. plot_lines_style + +-- main = main' "test14" (chart 0.25) diff --git a/tests/Test15.hs b/tests/Test15.hs new file mode 100644 --- /dev/null +++ b/tests/Test15.hs @@ -0,0 +1,43 @@ +module Test15 where + +import Graphics.Rendering.Chart +import Data.Colour +import Data.Colour.Names +import Control.Lens +import Data.Default.Class + +import Utils + +chart lo lp = layoutToRenderable layout + where + layout = + layout_title .~ "Legend Test" + $ layout_title_style . font_size .~ 10 + $ layout_x_axis . laxis_generate .~ autoIndexAxis alabels + $ layout_y_axis . laxis_override .~ axisGridHide + $ layout_left_axis_visibility . axis_show_ticks .~ False + $ layout_plots .~ [ plotBars bars2 ] + $ layout_legend .~ Just lstyle + $ def :: Layout PlotIndex Double + + bars2 = plot_bars_titles .~ ["A","B","C","D","E","F","G","H","I","J"] + $ plot_bars_values .~ addIndexes [[2,3,4,2,1,5,6,4,8,1,3], + [7,4,5,6,2,4,4,5,7,8,9] + ] + $ plot_bars_style .~ BarsClustered + $ plot_bars_spacing .~ BarsFixGap 30 5 + $ plot_bars_item_styles .~ map mkstyle (cycle defaultColorSeq) + $ def + + alabels = [ "X", "Y" ] + + lstyle = legend_orientation .~ lo + $ legend_position .~ lp + $ def + + btitle = "" + mkstyle c = (solidFillStyle c, Nothing) + +-- main = main' "test15" (chart (LORows 3)) + + diff --git a/tests/Test17.hs b/tests/Test17.hs new file mode 100644 --- /dev/null +++ b/tests/Test17.hs @@ -0,0 +1,79 @@ +module Test17 where + +import Graphics.Rendering.Chart +import Data.Colour +import Data.Colour.Names +import Control.Lens +import Data.Default.Class +import Data.Time.LocalTime +import System.Random +import ExampleStocks + +import Utils + +-- demonstrate Candles + +chart :: Double -> Renderable (LayoutPick LocalTime Double Double) +chart lwidth = layoutLRToRenderable layout + where + layout = layoutlr_title .~"Stock Prices" + $ layoutlr_background .~ solidFillStyle (opaque white) + $ layoutlr_left_axis_visibility . axis_show_ticks .~ False + $ layoutlr_plots .~ [ Right (toPlot msftArea) + , Right (toPlot msftLine) + , Right (toPlot msftCandle) + , Left (toPlot aaplArea) + , Left (toPlot aaplLine) + , Left (toPlot aaplCandle) ] + $ layoutlr_foreground .~ opaque black + $ def + + aaplLine = plot_lines_style .~ lineStyle 2 green + $ plot_lines_values .~ [[ (d, cl) + | (d,(lo,op,cl,hi)) <- pricesAAPL]] + $ plot_lines_title .~ "AAPL closing" + $ def + + msftLine = plot_lines_style .~ lineStyle 2 purple + $ plot_lines_values .~ [[ (d, cl) + | (d,(lo,op,cl,hi)) <- pricesMSFT]] + $ plot_lines_title .~ "MSFT closing" + $ def + + aaplArea = plot_fillbetween_style .~ solidFillStyle (withOpacity green 0.4) + $ plot_fillbetween_values .~ [ (d, (lo,hi)) + | (d,(lo,op,cl,hi)) <- pricesAAPL] + $ plot_fillbetween_title .~ "AAPL spread" + $ def + + msftArea = plot_fillbetween_style .~ solidFillStyle (withOpacity purple 0.4) + $ plot_fillbetween_values .~ [ (d, (lo,hi)) + | (d,(lo,op,cl,hi)) <- pricesMSFT] + $ plot_fillbetween_title .~ "MSFT spread" + $ def + + aaplCandle = plot_candle_line_style .~ lineStyle 1 blue + $ plot_candle_fill .~ True + $ plot_candle_tick_length .~ 0 + $ plot_candle_width .~ 2 + $ plot_candle_values .~ [ Candle d lo op 0 cl hi + | (d,(lo,op,cl,hi)) <- pricesAAPL] + $ plot_candle_title .~ "AAPL candle" + $ def + + msftCandle = plot_candle_line_style .~ lineStyle 1 red + $ plot_candle_fill .~ True + $ plot_candle_rise_fill_style .~ solidFillStyle (opaque pink) + $ plot_candle_fall_fill_style .~ solidFillStyle (opaque red) + $ plot_candle_tick_length .~ 0 + $ plot_candle_width .~ 2 + $ plot_candle_values .~ [ Candle d lo op 0 cl hi + | (d,(lo,op,cl,hi)) <- pricesMSFT] + $ plot_candle_title .~ "MSFT candle" + $ def + + lineStyle n colour = line_width .~ n * lwidth + $ line_color .~ opaque colour + $ def ^. plot_lines_style + +-- main = main' "test17" (chart 0.25) diff --git a/tests/Test19.hs b/tests/Test19.hs new file mode 100644 --- /dev/null +++ b/tests/Test19.hs @@ -0,0 +1,28 @@ +module Test19 where + +import Graphics.Rendering.Chart.Easy +import Control.Lens +import System.Random +import Data.Default.Class + +samples :: [Double] +samples = zipWith (+) raw (tail raw) + where + raw = take 2000 (randomRs (0,50) (mkStdGen 0)) + +samples2 :: [Double] +samples2 = concat $ zipWith replicate [5, 4, 3, 7] [0..3] + +chart = toRenderable $ + plot $ fmap histToPlot $ liftEC $ do + plot_hist_title .= "Demo histogram" + plot_hist_bins .= 100 + plot_hist_values .= samples + plot_hist_norm_func .= const id + +chart2 :: Renderable () +chart2 = toRenderable $ + plot $ fmap histToPlot $ liftEC $ do + plot_hist_bins .= 4 + plot_hist_values .= samples2 + plot_hist_norm_func .= const id diff --git a/tests/Test2.hs b/tests/Test2.hs new file mode 100644 --- /dev/null +++ b/tests/Test2.hs @@ -0,0 +1,63 @@ +module Test2 where + +import Graphics.Rendering.Chart +import Data.Time.LocalTime +import Data.Colour +import Data.Colour.Names +import Data.Colour.SRGB +import Control.Lens +import Data.Default.Class +import Prices(prices2) + +import Utils + +chart :: [(LocalTime,Double,Double)] -> Bool -> Double -> Renderable (LayoutPick LocalTime Double Double) +chart prices showMinMax lwidth = layoutLRToRenderable $ chartLR prices showMinMax lwidth + +chartLR :: [(LocalTime,Double,Double)] -> Bool -> Double -> LayoutLR LocalTime Double Double +chartLR prices showMinMax lwidth = layout + where + + lineStyle c = line_width .~ 3 * lwidth + $ line_color .~ c + $ def ^. plot_lines_style + + limitLineStyle c = line_width .~ lwidth + $ line_color .~ opaque c + $ line_dashes .~ [5,10] + $ def ^. plot_lines_style + + price1 = plot_lines_style .~ lineStyle (opaque blue) + $ plot_lines_values .~ [[ (d, v) | (d,v,_) <- prices]] + $ plot_lines_title .~ "price 1" + $ def + + price2 = plot_lines_style .~ lineStyle (opaque green) + $ plot_lines_values .~ [[ (d, v) | (d,_,v) <- prices]] + $ plot_lines_title .~ "price 2" + $ def + + (min1,max1) = (minimum [v | (_,v,_) <- prices],maximum [v | (_,v,_) <- prices]) + (min2,max2) = (minimum [v | (_,_,v) <- prices],maximum [v | (_,_,v) <- prices]) + limits | showMinMax = [ Left $ hlinePlot "min/max" (limitLineStyle blue) min1, + Left $ hlinePlot "" (limitLineStyle blue) max1, + Right $ hlinePlot "min/max" (limitLineStyle green) min2, + Right $ hlinePlot "" (limitLineStyle green) max2 ] + | otherwise = [] + + bg = opaque $ sRGB 0 0 0.25 + fg = opaque white + fg1 = opaque $ sRGB 0.0 0.0 0.15 + + layout = layoutlr_title .~"Price History" + $ layoutlr_background .~ solidFillStyle bg + $ layoutlr_axes_styles %~ (axis_grid_style .~ solidLine 1 fg1) + $ layoutlr_left_axis . laxis_override .~ axisGridHide + $ layoutlr_right_axis . laxis_override .~ axisGridHide + $ layoutlr_x_axis . laxis_override .~ axisGridHide + $ layoutlr_plots .~ ([Left (toPlot price1), Right (toPlot price2)] ++ limits) + $ layoutlr_grid_last .~ False + $ layoutlr_foreground .~ fg + $ def + +-- main = main' "test2" (chart prices2 True 0.25) diff --git a/tests/Test3.hs b/tests/Test3.hs new file mode 100644 --- /dev/null +++ b/tests/Test3.hs @@ -0,0 +1,36 @@ +module Test3 where + +import Graphics.Rendering.Chart +import Data.Time.LocalTime +import Data.Colour +import Data.Colour.Names +import Data.Colour.SRGB +import Control.Lens +import Data.Default.Class +import Prices(prices1) + +import Utils + +green1 = opaque $ sRGB 0.5 1 0.5 +blue1 = opaque $ sRGB 0.5 0.5 1 + +chart :: Renderable (LayoutPick LocalTime Double Double) +chart = layoutToRenderable layout + where + price1 = plot_fillbetween_style .~ solidFillStyle green1 + $ plot_fillbetween_values .~ [ (d,(0,v2)) | (d,v1,v2) <- prices1] + $ plot_fillbetween_title .~ "price 1" + $ def + + price2 = plot_fillbetween_style .~ solidFillStyle blue1 + $ plot_fillbetween_values .~ [ (d,(0,v1)) | (d,v1,v2) <- prices1] + $ plot_fillbetween_title .~ "price 2" + $ def + + layout = layout_title .~ "Price History" + $ layout_grid_last .~ True + $ layout_plots .~ [ toPlot price1 + , toPlot price2 ] + $ def + +-- main = main' "test3" chart diff --git a/tests/Test4.hs b/tests/Test4.hs new file mode 100644 --- /dev/null +++ b/tests/Test4.hs @@ -0,0 +1,35 @@ +module Test4 where + +import Graphics.Rendering.Chart +import Data.Colour +import Data.Colour.Names +import Control.Lens +import Data.Default.Class + +import Utils + +chart :: Bool -> Bool -> Renderable (LayoutPick Double Double Double) +chart xrev yrev = layoutToRenderable layout + where + + points = plot_points_style .~ filledCircles 3 (opaque red) + $ plot_points_values .~ [ (x, 10**x) | x <- [0.5,1,1.5,2,2.5 :: Double] ] + $ plot_points_title .~ "values" + $ def + + lines = plot_lines_values .~ [ [(x, 10**x) | x <- [0,3]] ] + $ plot_lines_title .~ "values" + $ def + + layout = layout_title .~ "Log/Linear Example" + $ layout_x_axis . laxis_title .~ "horizontal" + $ layout_x_axis . laxis_reverse .~ xrev + $ layout_y_axis . laxis_generate .~ autoScaledLogAxis def + $ layout_y_axis . laxis_title .~ "vertical" + $ layout_y_axis . laxis_reverse .~ yrev + $ layout_plots .~ [ toPlot points, toPlot lines ] + $ def + +-- main = main' "test4" (chart False False) + + diff --git a/tests/Test5.hs b/tests/Test5.hs new file mode 100644 --- /dev/null +++ b/tests/Test5.hs @@ -0,0 +1,46 @@ +module Test5 where + +import Graphics.Rendering.Chart +import Data.Colour +import Data.Colour.Names +import Control.Lens +import Data.Default.Class +import System.Random + +import Utils + +---------------------------------------------------------------------- +-- Example thanks to Russell O'Connor + +chart :: Double -> Renderable (LayoutPick Double LogValue LogValue) +chart lwidth = layoutToRenderable (layout 1001 (trial bits) :: Layout Double LogValue) + where + bits = randoms $ mkStdGen 0 + + layout n t = layout_title .~ "Simulation of betting on a biased coin" + $ layout_plots .~ [ + toPlot (plot "f=0.05" s1 n 0 (t 0.05)), + toPlot (plot "f=0.1" s2 n 0 (t 0.1)) + ] + $ def + + plot tt s n m t = plot_lines_style .~ s + $ plot_lines_values .~ + [[(fromIntegral x, LogValue y) | (x,y) <- + filter (\(x,_)-> x `mod` (m+1)==0) $ take n $ zip [0..] t]] + $ plot_lines_title .~ tt + $ def + + b = 0.1 + + trial bits frac = scanl (*) 1 (map f bits) + where + f True = (1+frac*(1+b)) + f False = (1-frac) + + s1 = solidLine lwidth $ opaque green + s2 = solidLine lwidth $ opaque blue + +-- main = main' "test5" (chart 0.25) + + diff --git a/tests/Test7.hs b/tests/Test7.hs new file mode 100644 --- /dev/null +++ b/tests/Test7.hs @@ -0,0 +1,32 @@ +module Test7 where + +import Graphics.Rendering.Chart +import Data.Colour +import Data.Colour.Names +import Control.Lens +import Data.Default.Class + +import Utils + +chart :: Renderable (LayoutPick Double Double Double) +chart = layoutToRenderable layout + where + vals :: [(Double,Double,Double,Double)] + vals = [ (x,sin (exp x),sin x/2,cos x/10) | x <- [1..20]] + bars = plot_errbars_values .~ [symErrPoint x y dx dy | (x,y,dx,dy) <- vals] + $ plot_errbars_title .~"test" + $ def + + points = plot_points_style .~ filledCircles 2 (opaque red) + $ plot_points_values .~ [(x,y) | (x,y,dx,dy) <- vals] + $ plot_points_title .~ "test data" + $ def + + layout = layout_title .~ "Error Bars" + $ layout_plots .~ [ toPlot bars + , toPlot points ] + $ def + +-- main = main' "test7" chart + + diff --git a/tests/Test8.hs b/tests/Test8.hs new file mode 100644 --- /dev/null +++ b/tests/Test8.hs @@ -0,0 +1,23 @@ +module Test8 where + +import Graphics.Rendering.Chart +import Control.Lens +import Data.Default.Class + +import Utils + +chart :: Renderable () +chart = mapPickFn (const ()) $ pieToRenderable layout + where + values = [ ("eggs",38,e), ("milk",45,e), ("bread",11,e1), ("salmon",8,e) ] + e = 0 + e1 = 25 + layout = pie_title .~ "Pie Chart Example" + $ pie_plot . pie_data .~ [ def{_pitem_value=v,_pitem_label=s,_pitem_offset=o} + | (s,v,o) <- values ] + $ pie_plot . pie_label_style .~ (font_size .~ 20 $ def) + $ def + +-- main = main' "test8" chart + + diff --git a/tests/Test9.hs b/tests/Test9.hs new file mode 100644 --- /dev/null +++ b/tests/Test9.hs @@ -0,0 +1,38 @@ +module Test9 where + +import Graphics.Rendering.Chart +import Data.Colour +import Data.Colour.Names +import Control.Lens +import Data.Default.Class + +import Utils + +chart :: Bool -> Renderable (LayoutPick PlotIndex Double Double) +chart borders = layoutToRenderable layout + where + layout = + layout_title .~ "Sample Bars" ++ btitle + $ layout_title_style . font_size .~ 10 + $ layout_x_axis . laxis_generate .~ autoIndexAxis alabels + $ layout_y_axis . laxis_override .~ axisGridHide + $ layout_left_axis_visibility . axis_show_ticks .~ False + $ layout_plots .~ [ plotBars bars2 ] + $ def :: Layout PlotIndex Double + + bars2 = plot_bars_titles .~ ["Cash","Equity"] + $ plot_bars_values .~ addIndexes [[20,45],[45,30],[30,20],[70,25]] + $ plot_bars_style .~ BarsClustered + $ plot_bars_spacing .~ BarsFixGap 30 5 + $ plot_bars_item_styles .~ map mkstyle (cycle defaultColorSeq) + $ def + + alabels = [ "Jun", "Jul", "Aug", "Sep", "Oct" ] + + btitle = if borders then "" else " (no borders)" + bstyle = if borders then Just (solidLine 1.0 $ opaque black) else Nothing + mkstyle c = (solidFillStyle c, bstyle) + +-- main = main' "test9" (chart True) + + diff --git a/tests/TestParametric.hs b/tests/TestParametric.hs new file mode 100644 --- /dev/null +++ b/tests/TestParametric.hs @@ -0,0 +1,27 @@ +module TestParametric where + +import Graphics.Rendering.Chart +import Data.Colour +import Data.Colour.Names +import Control.Lens +import Data.Default.Class + +import Utils + +chart :: Double -> Renderable (LayoutPick Double Double Double) +chart lwidth = layoutToRenderable layout + where + circle = [ (r a * sin (a*dr),r a * cos (a*dr)) | a <- [0,0.5..360::Double] ] + where + dr = 2 * pi / 360 + r a = 0.8 * cos (a * 20 * pi /360) + + circleP = plot_lines_values .~ [circle] + $ plot_lines_style .~ solidLine lwidth (opaque blue) + $ def + + layout = layout_title .~ "Parametric Plot" + $ layout_plots .~ [toPlot circleP] + $ def + +-- main = main' "test1" (chart 0.25) diff --git a/tests/TestSparkLines.hs b/tests/TestSparkLines.hs new file mode 100644 --- /dev/null +++ b/tests/TestSparkLines.hs @@ -0,0 +1,30 @@ +module TestSparkLines where + +import Graphics.Rendering.Chart +import Graphics.Rendering.Chart.SparkLine +import Data.Colour +import Data.Colour.Names +import Control.Lens +import System.Random +import System.Environment(getArgs) +import ExampleStocks + +-- demonstrate SparkLine + +msft = SparkLine { sl_options = smoothSpark { so_limits=(bot,top), so_height=40 } + , sl_data = closing } + where + closing = [ cl | (d,(lo,op,cl,hi)) <- reverse pricesMSFT ] + lowpoint = [ lo | (d,(lo,op,cl,hi)) <- reverse pricesMSFT ] + bot = minimum lowpoint + top = maximum closing + +chart :: Renderable () +chart = sparkLineToRenderable msft +chartSize = sparkSize msft +{- Cairo dependent +main1 :: [String] -> IO (PickFn ()) +main1 _ = sparkLineToPNG "test_sparkline.png" msft + +main = getArgs >>= main1 +-} diff --git a/tests/Tests.hs b/tests/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Tests.hs @@ -0,0 +1,498 @@ + +module Tests where + +import Graphics.Rendering.Chart +import Graphics.Rendering.Chart.Drawing +import Graphics.Rendering.Chart.Grid + +import System.Time +import System.Random +import Data.Time.LocalTime +import Control.Lens +import Data.Char (chr) +import Data.Colour +import Data.Colour.Names +import Data.Colour.SRGB +import Data.List(sort,nub,scanl1) +import Data.Default.Class +import qualified Data.Map as Map +import Control.Monad +import Prices +import qualified Test1 +import qualified Test2 +import qualified Test3 +import qualified Test4 +import qualified Test5 +import qualified Test7 +import qualified Test8 +import qualified Test9 +import qualified Test14 +import qualified Test14a +import qualified Test15 +import qualified Test17 +import qualified Test19 +import qualified TestParametric +import qualified TestSparkLines + +type LineWidth = Double + +fwhite = solidFillStyle $ opaque white + +test1a :: Double -> Renderable (LayoutPick Double Double Double) +test1a lwidth = fillBackground fwhite $ (gridToRenderable t) + where + t = aboveN [ besideN [layoutToGrid l1, layoutToGrid l2, layoutToGrid l3], + besideN [layoutToGrid l4, layoutToGrid l5, layoutToGrid l6] ] + + l1 = layout_title .~ "minimal" + $ layout_bottom_axis_visibility . axis_show_ticks .~ False + $ layout_left_axis_visibility . axis_show_ticks .~ False + $ layout_x_axis . laxis_override .~ axisGridHide + $ layout_y_axis . laxis_override .~ axisGridHide + $ Test1.layout lwidth + + l2 = layout_title .~ "with borders" + $ layout_bottom_axis_visibility . axis_show_ticks .~ False + $ layout_left_axis_visibility . axis_show_ticks .~ False + $ layout_top_axis_visibility . axis_show_line .~ True + $ layout_right_axis_visibility . axis_show_line .~ True + $ layout_x_axis . laxis_override .~ axisGridHide + $ layout_y_axis . laxis_override .~ axisGridHide + $ Test1.layout lwidth + + l3 = layout_title .~ "default" + $ Test1.layout lwidth + + l4 = layout_title .~ "tight grid" + $ layout_y_axis . laxis_generate .~ axis + $ layout_y_axis . laxis_override .~ axisGridAtTicks + $ layout_x_axis . laxis_generate .~ axis + $ layout_x_axis . laxis_override .~ axisGridAtTicks + $ Test1.layout lwidth + where + axis = autoScaledAxis ( + la_nLabels .~ 5 + $ la_nTicks .~ 20 + $ def + ) + + l5 = layout_title .~ "y linked" + $ layout_right_axis_visibility . axis_show_line .~ True + $ layout_right_axis_visibility . axis_show_ticks .~ True + $ layout_right_axis_visibility . axis_show_labels .~ True + $ Test1.layout lwidth + + l6 = layout_title .~ "everything" + $ layout_right_axis_visibility . axis_show_line .~ True + $ layout_right_axis_visibility . axis_show_ticks .~ True + $ layout_right_axis_visibility . axis_show_labels .~ True + $ layout_top_axis_visibility . axis_show_line .~ True + $ layout_top_axis_visibility . axis_show_ticks .~ True + $ layout_top_axis_visibility . axis_show_labels .~ True + $ Test1.layout lwidth + +---------------------------------------------------------------------- +test4d :: LineWidth -> Renderable (LayoutPick Double Double Double) +test4d lw = layoutToRenderable layout + where + + points = plot_points_style .~ filledCircles 3 (opaque red) + $ plot_points_values .~ [ (x, 10**x) | x <- [0.5,1,1.5,2,2.5::Double] ] + $ plot_points_title .~ "values" + $ def + + lines = plot_lines_values .~ [ [(x, 10**x) | x <- [0,3]] ] + $ plot_lines_title .~ "values" + $ def + + layout = layout_title .~ "Log/Linear Example" + $ layout_x_axis . laxis_title .~ "horizontal" + $ layout_x_axis . laxis_reverse .~ False + $ layout_y_axis . laxis_generate .~ autoScaledLogAxis def + $ layout_y_axis . laxis_title .~ "vertical" + $ layout_y_axis . laxis_reverse .~ False + $ layout_plots .~ [ toPlot points `joinPlot` toPlot lines ] + $ def + +---------------------------------------------------------------------- + +test9 :: PlotBarsAlignment -> LineWidth -> Renderable (LayoutPick PlotIndex Double Double) +test9 alignment lw = fillBackground fwhite $ (gridToRenderable t) + where + t = weights (1,1) $ aboveN [ besideN [rf g0, rf g1, rf g2], + besideN [rf g3, rf g4, rf g5] ] + + g0 = layout "clustered 1" + $ plot_bars_style .~ BarsClustered + $ plot_bars_spacing .~ BarsFixWidth 25 + $ bars1 + + g1 = layout "clustered/fix width " + $ plot_bars_style .~ BarsClustered + $ plot_bars_spacing .~ BarsFixWidth 25 + $ bars2 + + g2 = layout "clustered/fix gap " + $ plot_bars_style .~ BarsClustered + $ plot_bars_spacing .~ BarsFixGap 10 5 + $ bars2 + + g3 = layout "stacked 1" + $ plot_bars_style .~ BarsStacked + $ plot_bars_spacing .~ BarsFixWidth 25 + $ bars1 + + g4 = layout "stacked/fix width" + $ plot_bars_style .~ BarsStacked + $ plot_bars_spacing .~ BarsFixWidth 25 + $ bars2 + + g5 = layout "stacked/fix gap" + $ plot_bars_style .~ BarsStacked + $ plot_bars_spacing .~ BarsFixGap 10 5 + $ bars2 + + rf = tval . layoutToRenderable + + alabels = [ "Jun", "Jul", "Aug", "Sep", "Oct" ] + + + layout title bars = + layout_title .~ (show alignment ++ "/" ++ title) + $ layout_title_style . font_size .~ 10 + $ layout_x_axis . laxis_generate .~ autoIndexAxis alabels + $ layout_y_axis . laxis_override .~ axisGridHide + $ layout_left_axis_visibility . axis_show_ticks .~ False + $ layout_plots .~ [ plotBars bars ] + $ def :: Layout PlotIndex Double + + bars1 = plot_bars_titles .~ ["Cash"] + $ plot_bars_values .~ addIndexes [[20],[45],[30],[70]] + $ plot_bars_alignment .~ alignment + $ def + + bars2 = plot_bars_titles .~ ["Cash","Equity"] + $ plot_bars_values .~ addIndexes [[20,45],[45,30],[30,20],[70,25]] + $ plot_bars_alignment .~ alignment + $ def + +------------------------------------------------------------------------------- + +test10 :: [(LocalTime,Double,Double)] -> LineWidth -> Renderable (LayoutPick LocalTime Double Double) +test10 prices lw = layoutLRToRenderable $ test10LR prices lw + +test10LR :: [(LocalTime,Double,Double)] -> LineWidth -> LayoutLR LocalTime Double Double +test10LR prices lw = layout + where + + lineStyle c = line_width .~ 3 * lw + $ line_color .~ c + $ def ^. plot_lines_style + + price1 = plot_lines_style .~ lineStyle (opaque blue) + $ plot_lines_values .~ [[ (d,v) | (d,v,_) <- prices]] + $ plot_lines_title .~ "price 1" + $ def + + price1_area = plot_fillbetween_values .~ [(d, (v * 0.95, v * 1.05)) | (d,v,_) <- prices] + $ plot_fillbetween_style .~ solidFillStyle (withOpacity blue 0.2) + $ def + + price2 = plot_lines_style .~ lineStyle (opaque red) + $ plot_lines_values .~ [[ (d, v) | (d,_,v) <- prices]] + $ plot_lines_title .~ "price 2" + $ def + + price2_area = plot_fillbetween_values .~ [(d, (v * 0.95, v * 1.05)) | (d,_,v) <- prices] + $ plot_fillbetween_style .~ solidFillStyle (withOpacity red 0.2) + $ def + + fg = opaque black + fg1 = opaque $ sRGB 0.0 0.0 0.15 + + layout = layoutlr_title .~"Price History" + $ layoutlr_background .~ solidFillStyle (opaque white) + $ layoutlr_right_axis . laxis_override .~ axisGridHide + $ layoutlr_plots .~ [ Left (toPlot price1_area), Right (toPlot price2_area) + , Left (toPlot price1), Right (toPlot price2) + ] + $ layoutlr_foreground .~ fg + $ def + +------------------------------------------------------------------------------- +-- A quick test of stacked layouts + +test11_ f = f layout1 layout2 + where + vs1 :: [(Int,Int)] + vs1 = [ (2,2), (3,40), (8,400), (12,60) ] + + vs2 :: [(Int,Double)] + vs2 = [ (0,0.7), (3,0.35), (4,0.25), (7, 0.6), (10,0.4) ] + + plot1 = plot_points_style .~ filledCircles 5 (opaque red) + $ plot_points_values .~ vs1 + $ plot_points_title .~ "spots" + $ def + + layout1 = layout_title .~ "Multi typed stack" + $ layout_plots .~ [toPlot plot1] + $ layout_y_axis . laxis_title .~ "integer values" + $ def + + plot2 = plot_lines_values .~ [vs2] + $ plot_lines_title .~ "lines" + $ def + + layout2 = layout_plots .~ [toPlot plot2] + $ layout_y_axis . laxis_title .~ "double values" + $ def + +mkStack ls f = + renderStackedLayouts + $ slayouts_layouts .~ ls + $ slayouts_compress_legend .~ f + $ def + +test11a :: LineWidth -> Renderable () +test11a lw = test11_ f + where + f l1 l2 = mkStack [StackedLayout l1, StackedLayout l2] False + +test11b :: LineWidth -> Renderable () +test11b lw = test11_ f + where + f l1 l2 = mkStack [StackedLayout l1', StackedLayout l2] True + where + l1' = layout_bottom_axis_visibility . axis_show_labels .~ False + $ l1 + +-- should produce the same output as test10 +test11c :: LineWidth -> Renderable () +test11c lw = + mkStack [ StackedLayoutLR (test10LR prices1 lw)] True + +test11d :: LineWidth -> Renderable () +test11d lw = + mkStack [ StackedLayoutLR (Test2.chartLR prices1 False lw) + , StackedLayoutLR (test10LR prices1 lw) + ] False + +test11e :: LineWidth -> Renderable () +test11e lw = + let l2 = Test2.chartLR prices1 False lw + b = opaque black + -- how to use lens to get inside the maybe? + l2' = -- layoutlr_legend . Just . legend_label_style . font_color .~ b + layoutlr_legend .~ Just ((legend_label_style . font_color .~ b) $ def) + $ (layoutlr_axes_styles %~ c) l2 + c as = axis_line_style .~ solidLine 1 b + $ axis_label_style . font_color .~ b + $ as + in mkStack [ StackedLayoutLR (test10LR prices1 lw) + , StackedLayoutLR l2' + ] True + +------------------------------------------------------------------------------- +-- More of an example that a test: +-- configuring axes explicitly configured axes + +test12 :: LineWidth -> Renderable (LayoutPick Int Int Int) +test12 lw = layoutToRenderable layout + where + vs1 :: [(Int,Int)] + vs1 = [ (2,10), (3,40), (8,400), (12,60) ] + + baxis = AxisData { + _axis_visibility = def, + _axis_viewport = vmap (0,15), + _axis_tropweiv = invmap (0,15), + _axis_ticks = [(v,3) | v <- [0,1..15]], + _axis_grid = [0,5..15], + _axis_labels = [[(v,show v) | v <- [0,5..15]]] + } + + laxis = AxisData { + _axis_visibility = def, + _axis_viewport = vmap (0,500), + _axis_tropweiv = invmap (0,500), + _axis_ticks = [(v,3) | v <- [0,25..500]], + _axis_grid = [0,100..500], + _axis_labels = [[(v,show v) | v <- [0,100..500]]] + } + + plot = plot_lines_values .~ [vs1] + $ def + + layout = layout_plots .~ [toPlot plot] + $ layout_x_axis . laxis_generate .~ const baxis + $ layout_y_axis . laxis_generate .~ const laxis + $ layout_title .~ "Explicit Axes" + $ def + + +------------------------------------------------------------------------------- +-- Plot annotations test + +test13 lw = fillBackground fwhite $ (gridToRenderable t) + where + t = weights (1,1) $ aboveN [ besideN [tval (annotated h v) | h <- hs] | v <- vs ] + hs = [HTA_Left, HTA_Centre, HTA_Right] + vs = [VTA_Top, VTA_Centre, VTA_Bottom] + points=[-2..2] + pointPlot :: PlotPoints Int Int + pointPlot = plot_points_style.~ filledCircles 2 (opaque red) + $ plot_points_values .~ [(x,x)|x<-points] + $ def + p = toPlot pointPlot + annotated h v = layoutToRenderable ( layout_plots .~ [toPlot labelPlot, toPlot rotPlot, p] $ def ) + where labelPlot = plot_annotation_hanchor .~ h + $ plot_annotation_vanchor .~ v + $ plot_annotation_values .~ [(x,x,"Hello World\n(plain)")|x<-points] + $ def + rotPlot = plot_annotation_angle .~ -45.0 + $ plot_annotation_style .~ def {_font_size=10, _font_weight=FontWeightBold, _font_color=(opaque blue) } + $ plot_annotation_values .~ [(x,x,"Hello World\n(fancy)")|x<-points] + $ labelPlot + + +---------------------------------------------------------------------- +-- Vector Plot Test + +test18 :: Renderable (LayoutPick Double Double Double) +test18 = layoutToRenderable layout + where + grid = [(x,y) | x <- range, y <- range] where range = [-5,-4..5] + + proj1 = plot_vectors_style . vector_head_style . point_color .~ (opaque green) + $ plot_vectors_mapf .~ (\(x,y) -> (-x,-y)) + $ plot_vectors_grid .~ grid + $ plot_vectors_title .~ "Projection1" + $ def + + proj2 = plot_vectors_mapf .~ (\(x,y) -> (-(x+1), -(y-1))) + $ plot_vectors_grid .~ grid + $ plot_vectors_title .~ "Projection2" + $ def + + layout = layout_title .~ "Vector Plot: Abyss" + $ layout_plots .~ plotVectorField `liftM` [proj1,proj2] + $ def + +---------------------------------------------------------------------- +-- a quick test to display labels with all combinations +-- of anchors +misc1 fsz rot lw = fillBackground fwhite $ (gridToRenderable t) + where + t = weights (1,1) $ aboveN [ besideN [tval (lb h v) | h <- hs] | v <- vs ] + lb h v = addMargins (20,20,20,20) $ fillBackground fblue $ crossHairs $ rlabel fs h v rot s + s = if rot == 0 + then "Labelling" + else "Angle " ++ show (floor rot :: Int) ++ [chr 176] + hs = [HTA_Left, HTA_Centre, HTA_Right] + vs = [VTA_Top, VTA_Centre, VTA_Bottom, VTA_BaseLine] + fwhite = solidFillStyle $ opaque white + fblue = solidFillStyle $ withOpacity (sRGB 0.8 0.8 1) 0.6 + fs = def {_font_size=fsz,_font_weight=FontWeightBold} + crossHairs r =Renderable { + minsize = minsize r, + render = \sz@(w,h) -> do + let xa = w / 2 + let ya = h / 2 + alignStrokePoints [Point 0 ya,Point w ya] >>= strokePointPath + alignStrokePoints [Point xa 0,Point xa h] >>= strokePointPath + render r sz + } + +---------------------------------------------------------------------- +stdSize = (640,480) + +allTests :: [ (String, (Int,Int), LineWidth -> Renderable ()) ] +allTests = + [ ("test1", stdSize, \lw -> simple $ Test1.chart lw ) + , ("test1a", stdSize, \lw -> simple $ test1a lw ) + , ("test2a", stdSize, \lw -> simple $ Test2.chart prices False lw) + , ("test2b", stdSize, \lw -> simple $ Test2.chart prices1 False lw) + , ("test2c", stdSize, \lw -> simple $ Test2.chart prices2 False lw) + , ("test2d", stdSize, \lw -> simple $ Test2.chart prices5 True lw) + , ("test2e", stdSize, \lw -> simple $ Test2.chart prices6 True lw) + , ("test2f", stdSize, \lw -> simple $ Test2.chart prices7 True lw) + , ("test2g", stdSize, \lw -> simple $ Test2.chart prices3 False lw) + , ("test2h", stdSize, \lw -> simple $ Test2.chart prices8 True lw) + , ("test2i", stdSize, \lw -> simple $ Test2.chart prices9 True lw) + , ("test2j", stdSize, \lw -> simple $ Test2.chart prices10 True lw) + , ("test2k", stdSize, \lw -> simple $ Test2.chart prices10a True lw) + , ("test2m", stdSize, \lw -> simple $ Test2.chart prices11 True lw) + , ("test2n", stdSize, \lw -> simple $ Test2.chart prices10b True lw) + , ("test2o", stdSize, \lw -> simple $ Test2.chart prices12 True lw) + , ("test2p", stdSize, \lw -> simple $ Test2.chart prices13 True lw) + , ("test2q", stdSize, \lw -> simple $ Test2.chart prices13a True lw) + , ("test2r", stdSize, \lw -> simple $ Test2.chart prices13b True lw) + , ("test2s", stdSize, \lw -> simple $ Test2.chart prices14 True lw) + , ("test2t", stdSize, \lw -> simple $ Test2.chart prices14a True lw) + , ("test2u", stdSize, \lw -> simple $ Test2.chart prices14b True lw) + , ("test2v", stdSize, \lw -> simple $ Test2.chart prices14c True lw) + , ("test2w", stdSize, \lw -> simple $ Test2.chart prices14d True lw) + , ("test3", stdSize, const $ simple Test3.chart) + , ("test4a", stdSize, const $ simple (Test4.chart False False)) + , ("test4b", stdSize, const $ simple (Test4.chart True False)) + , ("test4c", stdSize, const $ simple (Test4.chart False True)) + , ("test4d", stdSize, \lw -> simple $ test4d lw) + , ("test5", stdSize, \lw -> simple $ Test5.chart lw) + , ("test7", stdSize, const $ simple Test7.chart) + , ("test8", stdSize, const $ simple Test8.chart) + , ("test9", stdSize, const $ simple (Test9.chart True)) + , ("test9b", stdSize, const $ simple (Test9.chart False)) + , ("test9c", stdSize, \lw -> simple $ test9 BarsCentered lw) + , ("test9l", stdSize, \lw -> simple $ test9 BarsLeft lw) + , ("test9r", stdSize, \lw -> simple $ test9 BarsRight lw) + , ("test10", stdSize, \lw -> simple $ test10 prices1 lw) + , ("test11a", stdSize, \lw -> simple $ test11a lw) + , ("test11b", stdSize, \lw -> simple $ test11b lw) + , ("test11c", stdSize, \lw -> simple $ test11c lw) + , ("test11d", stdSize, \lw -> simple $ test11d lw) + , ("test11e", stdSize, \lw -> simple $ test11e lw) + , ("test12", stdSize, \lw -> simple $ test12 lw) + , ("test13", stdSize, \lw -> simple $ test13 lw) + , ("test14", stdSize, \lw -> simple $ Test14.chart lw ) + , ("test14a", stdSize, \lw -> simple $ Test14a.chart lw ) + , ("test15a", stdSize, const $ simple (Test15.chart (LORows 2) LegendBelow)) + , ("test15b", stdSize, const $ simple (Test15.chart (LOCols 2) LegendBelow)) + , ("test15c", stdSize, const $ simple (Test15.chart (LORows 2) LegendLeft)) + , ("test15d", stdSize, const $ simple (Test15.chart (LORows 2) LegendRight)) + , ("test15e", stdSize, const $ simple (Test15.chart (LOCols 2) LegendAbove)) + , ("test17", stdSize, \lw -> simple $ Test17.chart lw) + , ("test18", stdSize, const $ simple test18) + , ("test19", stdSize, const $ simple Test19.chart) + , ("test19b", stdSize, const $ simple Test19.chart2) + , ("misc1", stdSize, setPickFn nullPickFn . misc1 20 0) + -- perhaps a bit excessive + , ("misc1a", stdSize, setPickFn nullPickFn . misc1 12 45) + , ("misc1b", stdSize, setPickFn nullPickFn . misc1 12 90) + , ("misc1c", stdSize, setPickFn nullPickFn . misc1 12 135) + , ("misc1d", stdSize, setPickFn nullPickFn . misc1 12 180) + , ("misc1e", stdSize, setPickFn nullPickFn . misc1 12 205) + , ("misc1f", stdSize, setPickFn nullPickFn . misc1 12 270) + , ("misc1g", stdSize, setPickFn nullPickFn . misc1 12 315) + , ("parametric", stdSize, \lw -> simple $ TestParametric.chart lw ) + , ("sparklines", TestSparkLines.chartSize, const $ simple TestSparkLines.chart ) + ] + where simple :: Renderable a -> Renderable () + simple = mapPickFn (const ()) + + + +showTests :: [String] -> ((String,(Int,Int),LineWidth -> Renderable ()) -> IO()) -> IO () +showTests tests ofn = mapM_ doTest (filter (match tests) allTests) + where + doTest (s,size,f) = do + putStrLn (s ++ "... ") + ofn (s,size,f) + + +getTests :: [String] -> [(String,(Int,Int),LineWidth -> Renderable ())] +getTests names = filter (match names) allTests + +match :: [String] -> (String,s,a) -> Bool +match [] t = True +match ts (s,_,_) = s `elem` ts diff --git a/tests/Utils.hs b/tests/Utils.hs new file mode 100644 --- /dev/null +++ b/tests/Utils.hs @@ -0,0 +1,12 @@ +module Utils where + +import System.Environment(getArgs) +import Graphics.Rendering.Chart +{- +mainCairo :: String -> Renderable a -> [String] -> IO (PickFn a) +mainCairo name chart ["small"] = renderableToPNGFile chart 320 240 $ name ++ "_small.png" +mainCairo name chart ["big"] = renderableToPNGFile chart 800 600 $ name ++ "_big.png" + +main' :: String -> Renderable a -> IO (PickFn a) +main' name chart = getArgs >>= mainCairo name chart +-}