{-# OPTIONS -O #-}

-- Example of an drawing graphics onto a canvas.
import Graphics.UI.Gtk
import Graphics.UI.Gtk.Gdk.GC

import Data.Array.MArray
import Data.Word
import Data.IORef
import Control.Monad ( when )
import Control.Monad.Trans ( liftIO )
import Data.Array.Base ( unsafeWrite )


main = do
  initGUI
  dia <- dialogNew
  dialogAddButton dia stockOk ResponseOk
  contain <- dialogGetUpper dia
  canvas <- drawingAreaNew
  canvas `on` sizeRequest $ return (Requisition 256 256)

  -- create the Pixbuf
  pb <- pixbufNew ColorspaceRgb False 8 256 256
  pbData <- (pixbufGetPixels pb :: IO (PixbufData Int Word8))
  row <- pixbufGetRowstride pb
  chan <- pixbufGetNChannels pb
  bits <- pixbufGetBitsPerSample pb
  putStrLn ("bytes per row: "++show row++", channels per pixel: "++show chan++
            ", bits per sample: "++show bits)

  -- draw into the Pixbuf
  doFromTo 0 255 $ \y ->
    doFromTo 0 255 $ \x -> do
      writeArray pbData (x*chan+y*row) (fromIntegral x)
      writeArray pbData (1+x*chan+y*row) (fromIntegral y)
      writeArray pbData (2+x*chan+y*row) 0

  -- a function to update the Pixbuf
  blueRef <- newIORef 0
  dirRef <- newIORef True
  let updateBlue = do
        blue <- readIORef blueRef
        --print blue
        doFromTo 0 255 $ \y ->
          doFromTo 0 255 $ \x ->
        -- Here, writeArray was replaced with unsafeWrite. The latter does
        -- not check that the index is within bounds which has a tremendous
        -- effect on performance.
        --  writeArray  pbData (2+x*chan+y*row) blue  -- safe checked indexing
            unsafeWrite pbData (2+x*chan+y*row) blue  -- unchecked indexing

        -- arrange for the canvas to be redrawn now that we've changed
        -- the Pixbuf
        widgetQueueDraw canvas

        -- update the blue state ready for next time
        dir <- readIORef dirRef
        let diff = 4
        let blue' = if dir then blue+diff else blue-diff
        if dir then
          if blue<=maxBound-diff then writeIORef blueRef blue' else
            writeIORef blueRef maxBound >> modifyIORef dirRef not
          else
          if blue>=minBound+diff then writeIORef blueRef blue' else
            writeIORef blueRef minBound >> modifyIORef dirRef not
        return True

  idleAdd updateBlue priorityLow
  canvas `on` exposeEvent $ updateCanvas pb
  boxPackStartDefaults contain canvas
  widgetShow canvas
  dialogRun dia
  return ()

updateCanvas :: Pixbuf -> EventM EExpose Bool
updateCanvas pb = do
  win <- eventWindow
  region <- eventRegion
  liftIO $ do
  gc <- gcNew win
  width  <- pixbufGetWidth pb
  height <- pixbufGetHeight pb
  pbregion <- regionRectangle (Rectangle 0 0 width height)
  regionIntersect region pbregion
  rects <- regionGetRectangles region
--  putStrLn ("redrawing: "++show rects)
  (flip mapM_) rects $ \(Rectangle x y w h) -> do
    drawPixbuf win gc pb x y x y w h RgbDitherNone 0 0
  return True

-- GHC is much better at opimising loops like this:
--
-- > doFromTo 0 255 $ \y ->
-- >   doFromTo 0 255 $ \x -> do ...
--
-- Than it is at optimising loops like this:
--
-- > sequence_ [ do ...
-- >           | x <- [0..255]
-- >           , y <- [0..255] ]
--
-- The first kind of loop runs significantly faster (with GHC 6.2 and 6.4)

{-# INLINE doFromTo #-}
-- do the action for [from..to], ie it's inclusive.
doFromTo :: Int -> Int -> (Int -> IO ()) -> IO ()
doFromTo from to action =
  let loop n | n > to   = return ()
             | otherwise = do action n
                              loop (n+1)
   in loop from