Haskell GTK, double buffering with primitives

With an example like this. How can I do 2d double buffering with gtk and haskell. I want to render primitives to an offscreen buffer and flip. This code only renders a pixel/rectangle. I want to add movement using a double buffered approach.

import Graphics.UI.Gtk
import Graphics.UI.Gtk.Gdk.GC
import Graphics.UI.Gtk hiding (Color, Point, Object)

defaultFgColor :: Color
defaultFgColor = Color 65535 65535 65535

defaultBgColor :: Color
defaultBgColor = Color 0 0 0

renderScene d ev = do
    dw     <- widgetGetDrawWindow d
    (w, h) <- widgetGetSize d
    gc     <- gcNew dw
    let fg = Color  (round (65535 * 205))
                    (round (65535 * 0))
                    (round (65535 * 0))
    gcSetValues gc $ newGCValues { foreground = fg }
  开发者_如何学Python  drawPoint dw gc (120, 120)
    drawPoint dw gc (22, 22)
    drawRectangle dw gc True 20 20 20 20
    return True

main :: IO ()   
main = do
    initGUI
    window  <- windowNew
    drawing <- drawingAreaNew
    windowSetTitle window "Cells"
    containerAdd window drawing
    let bg = Color  (round (65535 * 205))
                    (round (65535 * 205))
                    (round (65535 * 255))
    widgetModifyBg drawing StateNormal bg
    onExpose drawing (renderScene drawing)

    onDestroy window mainQuit
    windowSetDefaultSize window 800 600
    windowSetPosition window WinPosCenter
    widgetShowAll window
    mainGUI

---

This is what I'm using to paint with cairo in a drawing area and avoid flickering. Try adding this code to your renderScene function:

  -- Get the draw window (dw) and its size (w,h)
  -- ...

  regio <- regionRectangle $ Rectangle 0 0 w h
  drawWindowBeginPaintRegion dw regio

  -- Put paiting code here
  -- ..

  drawWindowEndPaint dw

Your final code could look like this:

import Graphics.UI.Gtk
import Graphics.UI.Gtk.Gdk.GC
import Graphics.UI.Gtk hiding (Color, Point, Object)
import Data.IORef

defaultFgColor :: Color
defaultFgColor = Color 65535 65535 65535

defaultBgColor :: Color
defaultBgColor = Color 0 0 0

renderScene pref d _ev = renderScene' pref d

renderScene' :: IORef Int -> DrawingArea -> IO Bool
renderScene' pref d = do
    dw     <- widgetGetDrawWindow d
    (w, h) <- widgetGetSize d
    regio <- regionRectangle $ Rectangle 0 0 w h

    pos <- readIORef pref
    -- Go around, CCW, in a circle of size 20, centered at (100,100)
    let x = 100 + round ( 20 * sin (fromIntegral pos * pi * 2 / 360) )
        y = 100 + round ( 20 * cos (fromIntegral pos * pi * 2 / 360) )
        pos' = (pos + 1) `mod` 360
    writeIORef pref pos'

    drawWindowBeginPaintRegion dw regio
    gc     <- gcNew dw
    let fg = Color  (round (65535 * 205))
                    (round (65535 * 0))
                    (round (65535 * 0))
    gcSetValues gc $ newGCValues { foreground = fg }
    drawPoint dw gc (120, 120)
    drawPoint dw gc (22, 22)
    drawRectangle dw gc True x y 20 20
    -- Paint an extra rectangle
    drawRectangle dw gc True 200 200 200 200
    drawWindowEndPaint dw
    return True

main :: IO ()   
main = do
    initGUI
    window  <- windowNew
    drawing <- drawingAreaNew
    windowSetTitle window "Cells"
    containerAdd window drawing
    let bg = Color  (round (65535 * 205))
                    (round (65535 * 205))
                    (round (65535 * 255))
    widgetModifyBg drawing StateNormal bg

    pref <- newIORef 0

    onExpose drawing (renderScene pref drawing)
    timeoutAdd (renderScene' pref drawing) 10

    onDestroy window mainQuit
    windowSetDefaultSize window 800 600
    windowSetPosition window WinPosCenter
    widgetShowAll window
    mainGUI

---

It might be an idea to have a look at ThreadScope. Scrolling is implemented there with something that's pretty close to double-buffering. Here's a simplified version of what I think they do:

prev_surface <- readIORef prevView
win <- widgetGetDrawWindow timelineDrawingArea
renderWithDrawable win $ do

  -- Create new surface based on the old one
  new_surface <- liftIO $ createSimilarSurface [...]
  renderWith new_surface $ do
    setSourceSurface prev_surface off 0
    Cairo.rectangle [...]
    Cairo.fill
    [... render newly exposed stuff ...]
  surfaceFinish new_surface

  -- Save back new view
  liftIO $ writeIORef prevView new_surface

  -- Paint new view
  setSourceSurface new_surface 0 0
  setOperator OperatorSource
  paint

The actual code can be found in Timeline/Render.hs. No idea whether this is the best way to do it, but it seems to work well enough in practice. I hope this helps.