Ticket #1228: bench.hs

File bench.hs, 3.2 kB (added by guest, 3 years ago)

cairo performance benchmarking (random lines)

Line 
1{-# LANGUAGE ForeignFunctionInterface #-}
2import Graphics.Rendering.Cairo
3
4import Data.Array.IO (IOUArray, newArray, writeArray, freeze)
5import Data.Array.Unboxed (UArray, (!))
6import Control.Exception (bracket)
7import Control.Monad (forM_)
8import Foreign.C (CInt)
9import Foreign.Ptr (Ptr)
10import System.Environment (getArgs)
11import System.IO (hSetBuffering, stdout, BufferMode(NoBuffering))
12import System.Random (randomRIO)
13
14width :: Num a => a
15width = 1050
16
17height :: Num a => a
18height = 576
19
20main :: IO ()
21main = do
22  hSetBuffering stdout NoBuffering
23  n <- (read . head) `fmap` getArgs
24  ps <- randomArray n
25  print "hs  begin"
26  hs n ps
27  print "hs  end"
28  print "raw begin"
29  raw n ps
30  print "raw end"
31
32randomArray :: Int -> IO (UArray (Int, Int) Double)
33randomArray n = do
34  a <- newArray ((0, 0), (n - 1, 3)) 0 :: IO (IOUArray (Int, Int) Double)
35  forM_ [0 .. n - 1] $ \i -> do
36    writeArray a (i, 0) =<< randomRIO (0, width)
37    writeArray a (i, 1) =<< randomRIO (0, height)
38    writeArray a (i, 2) =<< randomRIO (0, width)
39    writeArray a (i, 3) =<< randomRIO (0, height)
40  freeze a
41
42hs :: Int -> UArray (Int, Int) Double -> IO ()
43hs n ps = do
44  withImage FormatARGB32 width height $ \image -> do
45    renderWith image $ do
46      setSourceRGBA 1 1 1 1
47      rectangle 0 0 width height
48      fill
49      setSourceRGBA 0 0 0 1
50      forM_ [0 .. n - 1] $ \i -> do
51        moveTo (ps ! (i, 0)) (ps ! (i, 1))
52        lineTo (ps ! (i, 2)) (ps ! (i, 3))
53        stroke
54    surfaceFlush image
55
56withImage f w h = bracket (createImageSurface f w h) surfaceFinish
57
58raw :: Int -> UArray (Int, Int) Double -> IO ()
59raw n ps = do
60  c'withImage c'FormatARGB32 width height $ \image -> do
61    c'renderWith image $ \c -> do
62      c'setSourceRGBA c 1 1 1 1
63      c'rectangle c 0 0 width height
64      c'fill c
65      c'setSourceRGBA c 0 0 0 1
66      forM_ [0 .. n - 1] $ \i -> do
67        c'moveTo c (ps ! (i, 0)) (ps ! (i, 1))
68        c'lineTo c (ps ! (i, 2)) (ps ! (i, 3))
69        c'stroke c
70    c'surfaceFlush image
71 
72c'withImage f w h = bracket (c'createImageSurface f w h) c'destroySurface
73c'renderWith s = bracket (c'create s) c'destroy
74
75c'FormatARGB32 = 0
76
77foreign import ccall "cairo/cairo.h cairo_image_surface_create" c'createImageSurface :: CInt -> CInt -> CInt -> IO (Ptr ())
78foreign import ccall "cairo/cairo.h cairo_surface_destroy" c'destroySurface :: Ptr () -> IO ()
79foreign import ccall "cairo/cairo.h cairo_surface_flush" c'surfaceFlush :: Ptr () -> IO ()
80
81foreign import ccall "cairo/cairo.h cairo_create" c'create :: Ptr () -> IO (Ptr ())
82foreign import ccall "cairo/cairo.h cairo_destroy" c'destroy :: Ptr () -> IO ()
83
84foreign import ccall "cairo/cairo.h cairo_set_source_rgba" c'setSourceRGBA :: Ptr () -> Double -> Double -> Double -> Double -> IO ()
85foreign import ccall "cairo/cairo.h cairo_rectangle" c'rectangle :: Ptr () -> Double -> Double -> Double -> Double -> IO ()
86foreign import ccall "cairo/cairo.h cairo_move_to" c'moveTo :: Ptr () -> Double -> Double -> IO ()
87foreign import ccall "cairo/cairo.h cairo_line_to" c'lineTo :: Ptr () -> Double -> Double -> IO ()
88foreign import ccall "cairo/cairo.h cairo_fill" c'fill :: Ptr () -> IO ()
89foreign import ccall "cairo/cairo.h cairo_stroke" c'stroke :: Ptr () -> IO ()