Ticket #1228: bench.hs

{-# LANGUAGE ForeignFunctionInterface #-}
import Graphics.Rendering.Cairo

import Data.Array.IO (IOUArray, newArray, writeArray, freeze)
import Data.Array.Unboxed (UArray, (!))
import Control.Exception (bracket)
import Control.Monad (forM_)
import Foreign.C (CInt)
import Foreign.Ptr (Ptr)
import System.Environment (getArgs)
import System.IO (hSetBuffering, stdout, BufferMode(NoBuffering))
import System.Random (randomRIO)

width :: Num a => a
width = 1050

height :: Num a => a
height = 576

main :: IO ()
main = do
  hSetBuffering stdout NoBuffering
  n <- (read . head) `fmap` getArgs
  ps <- randomArray n
  print "hs  begin"
  hs n ps
  print "hs  end"
  print "raw begin"
  raw n ps
  print "raw end"

randomArray :: Int -> IO (UArray (Int, Int) Double)
randomArray n = do
  a <- newArray ((0, 0), (n - 1, 3)) 0 :: IO (IOUArray (Int, Int) Double)
  forM_ [0 .. n - 1] $ \i -> do
    writeArray a (i, 0) =<< randomRIO (0, width)
    writeArray a (i, 1) =<< randomRIO (0, height)
    writeArray a (i, 2) =<< randomRIO (0, width)
    writeArray a (i, 3) =<< randomRIO (0, height)
  freeze a

hs :: Int -> UArray (Int, Int) Double -> IO ()
hs n ps = do
  withImage FormatARGB32 width height $ \image -> do
    renderWith image $ do
      setSourceRGBA 1 1 1 1
      rectangle 0 0 width height
      fill
      setSourceRGBA 0 0 0 1
      forM_ [0 .. n - 1] $ \i -> do
        moveTo (ps ! (i, 0)) (ps ! (i, 1))
        lineTo (ps ! (i, 2)) (ps ! (i, 3))
        stroke
    surfaceFlush image

withImage f w h = bracket (createImageSurface f w h) surfaceFinish

raw :: Int -> UArray (Int, Int) Double -> IO ()
raw n ps = do
  c'withImage c'FormatARGB32 width height $ \image -> do
    c'renderWith image $ \c -> do
      c'setSourceRGBA c 1 1 1 1
      c'rectangle c 0 0 width height
      c'fill c
      c'setSourceRGBA c 0 0 0 1
      forM_ [0 .. n - 1] $ \i -> do
        c'moveTo c (ps ! (i, 0)) (ps ! (i, 1))
        c'lineTo c (ps ! (i, 2)) (ps ! (i, 3))
        c'stroke c
    c'surfaceFlush image
  
c'withImage f w h = bracket (c'createImageSurface f w h) c'destroySurface
c'renderWith s = bracket (c'create s) c'destroy

c'FormatARGB32 = 0

foreign import ccall "cairo/cairo.h cairo_image_surface_create" c'createImageSurface :: CInt -> CInt -> CInt -> IO (Ptr ())
foreign import ccall "cairo/cairo.h cairo_surface_destroy" c'destroySurface :: Ptr () -> IO ()
foreign import ccall "cairo/cairo.h cairo_surface_flush" c'surfaceFlush :: Ptr () -> IO ()

foreign import ccall "cairo/cairo.h cairo_create" c'create :: Ptr () -> IO (Ptr ())
foreign import ccall "cairo/cairo.h cairo_destroy" c'destroy :: Ptr () -> IO ()

foreign import ccall "cairo/cairo.h cairo_set_source_rgba" c'setSourceRGBA :: Ptr () -> Double -> Double -> Double -> Double -> IO ()
foreign import ccall "cairo/cairo.h cairo_rectangle" c'rectangle :: Ptr () -> Double -> Double -> Double -> Double -> IO ()
foreign import ccall "cairo/cairo.h cairo_move_to" c'moveTo :: Ptr () -> Double -> Double -> IO ()
foreign import ccall "cairo/cairo.h cairo_line_to" c'lineTo :: Ptr () -> Double -> Double -> IO ()
foreign import ccall "cairo/cairo.h cairo_fill" c'fill :: Ptr () -> IO ()
foreign import ccall "cairo/cairo.h cairo_stroke" c'stroke :: Ptr () -> IO ()