gruff-0.4: src/Browser.hs

{-# LANGUAGE PatternSynonyms #-}
module Browser (Browser(..), browserNew, browserRenders) where

import Prelude hiding (log, lines)
import Control.Concurrent
  ( forkIO, MVar, newEmptyMVar, newMVar, takeMVar, putMVar, tryTakeMVar, threadDelay )
import Control.Monad (foldM, forever, forM_, replicateM, unless, when)
import Data.IORef (IORef, newIORef, readIORef, atomicModifyIORef)
import Data.List (sortBy)
import qualified Data.Map as M
import Data.Map (Map)
import Data.Maybe (fromMaybe)
import Data.Ord (comparing)
import qualified Data.Set as S
import Data.Set ((\\))
import Foreign (Ptr, malloc, alloca, peek, poke, nullPtr)
import Foreign.C (CFloat, CInt)
import GHC.Conc (numCapabilities)
import Graphics.Rendering.OpenGL hiding
  ( viewport, Angle, Color, Point, Position, Size, S, R )
import qualified Graphics.Rendering.OpenGL as GL
import Graphics.GL
  ( glTexImage2D, pattern GL_TEXTURE_2D, pattern GL_R32F, pattern GL_RGBA, pattern GL_RED
  , pattern GL_FLOAT, pattern GL_UNSIGNED_BYTE, pattern GL_FALSE, glClampColor
  , pattern GL_CLAMP_VERTEX_COLOR, pattern GL_CLAMP_READ_COLOR, pattern GL_CLAMP_FRAGMENT_COLOR
  , glGenFramebuffers, glBindFramebuffer, glFramebufferTexture2D
  , pattern GL_FRAMEBUFFER, pattern GL_COLOR_ATTACHMENT0, glGenerateMipmap
  , pattern GL_FRAMEBUFFER_COMPLETE, glCheckFramebufferStatus
  , glGetError
  )
import Graphics.UI.Gtk hiding
  ( get, Window, Viewport, Region, Size, Action, Image, Label, labelText )
import qualified Graphics.UI.Gtk as GTK

import Graphics.Rendering.FTGL as FTGL

import Fractal.RUFF.Types.Complex (Complex((:+)))

import GLUTGtk
  ( GLUTGtk, Size(Size), Key(MouseButton), KeyState(Down), Position(Position)
  , postRedisplay, widget, realizeCallback, reshapeCallback
  , displayCallback, keyboardMouseCallback
  )
import Shader (shader)
import QuadTree (Quad(..))
import Tile (Tile(Tile), getTile, freeTile)
import Logger (Logger, LogLevel(Debug))
import qualified Logger as Log
import Snapshot (writeSnapshot)
import View
  ( Image(..), Window(..), Viewport(..), Label(..), Line(..)
  , BufferSize(..), bufferSize, tileSize, delta
  , Colours(..), Colour(..)
  , pixelLocation, originQuad, visibleQuads, locationPixel
  , defImage, defWindow
  )
import Interact (MouseCallbacks, Mod(..), But(..))

import Paths_gruff (getDataFileName)

type TextureObject3 = (TextureObject, TextureObject, TextureObject)
type QuadList = [(Complex Int, Quad)]
data GruffImage = GruffImage
  { image :: Image
  -- tile cache
  , tiles :: Map Quad TextureObject3
  , queue :: MVar [Tile]
  , jobs :: MVar [Quad]
  , viewQuads :: (QuadList, QuadList)
  , workers :: [Ptr CInt]
  , progress :: Map (Ptr CInt) Quad
  , gl :: GLUTGtk
  , cacheDir :: FilePath
  , log :: LogLevel -> String -> IO ()
  , prog :: Program
  , combineProg :: Program
  , tsheet0 :: TextureObject
  , tsheet1 :: TextureObject
  , sheetCount0 :: Int
  , sheetCount1 :: Int
  , sheetCountTarget :: Int
  , fbo :: GLuint
  , cacheSizeMin :: Int
  , cacheSizeMax :: Int
  -- callbacks
  , exitCallback :: Maybe (IO ())
  , reshapeCallback :: Maybe (Int -> Int -> IO ())
  , mouseCallback :: MouseCallbacks
  , doneCallback :: Maybe (IO ())
  , abortCallback :: Maybe (IO ())
  , doClear :: Bool
  , font :: FTGL.Font
  }

sheetSize :: GruffImage -> BufferSize
sheetSize g = bufferSize (sheetOffset g) (imageWindow (image g))

zoomPhase :: GruffImage -> Double
zoomPhase = delta . imageLocation . image

rotationA :: GruffImage -> Double
rotationA = orient . imageViewport . image

sheetBlend :: GruffImage -> (Int, (Double, Double))
sheetBlend g =
  let z = zoomPhase g
      s = supersamples (imageWindow (image g))
      b = logBase 4 (4 ** z * s)
      h = floor b
      d = fromIntegral h - b
  in  (h, (d, 1 - (1 - 4**d) / (4**(d+1) - 4**d)))

sheetOffset :: GruffImage -> Int
sheetOffset = fst . sheetBlend

{-
sheetDelta :: GruffImage -> Double
sheetDelta = fst . snd . sheetBlend
-}

blendFactor :: GruffImage -> Double
blendFactor = snd . snd . sheetBlend

iDisplay :: IORef GruffImage -> IO ()
iDisplay iR = do
  checkError "display begin"
  s0 <- readIORef iR
  mtls <- tryTakeMVar (queue s0)
  case mtls of
    Just tls -> do
      putMVar (queue s0) []
      forM_ tls $ \tile@(Tile q ns ds ts) -> do
        tde <- upload ds
        checkError "upload ds"
        tit <- upload ns
        checkError "upload ns"
        ttt <- upload ts
        checkError "upload ts"
        freeTile tile
        atomicModifyIORef iR $ \s' ->
          ( s'{ tiles = M.insert q (tde, tit, ttt) (tiles s')
              , progress = M.filter (/= q) (progress s') }
          , ())
    Nothing -> return ()
  s <- readIORef iR
  log s Debug $ "displayCallback " ++ show (imageLocation (image s))
  c <- atomicModifyIORef iR $ \s' -> (s'{ doClear = False }, doClear s')
  when c $ do
    clearSheet s False
    checkError "clear sheet F"
    clearSheet s True
    checkError "clear sheet T"
    atomicModifyIORef iR $ \s' -> (s'{ sheetCount0 = 0, sheetCount1 = 0 }, ())
  (todo0, upped0) <- renderSheet s False
  checkError "render sheet F"
  (todo1, upped1) <- renderSheet s True
  checkError "render sheet T"
  atomicModifyIORef iR $ \s' ->
    ( s'{ viewQuads = (todo0, todo1)
        , sheetCount0 = sheetCount0 s' + upped0
        , sheetCount1 = sheetCount1 s' + upped1
        }, () )
  let w = width (imageWindow (image s))
      h = height (imageWindow (image s))
  GL.viewport $=
    (GL.Position 0 0, GL.Size (fromIntegral w) (fromIntegral h))
  checkError "clear V"
  loadIdentity
  checkError "clear I"
  ortho2D 0 (fromIntegral w) 0 (fromIntegral h)
  checkError "clear O"
  clearColor $= Color4 0.5 0.5 0.5 1
  checkError "clear CC"
  clear [ColorBuffer]
  checkError "clear C"
  currentProgram $= Just (combineProg s)
  checkError "shader 1"
  lsheet0 <- get $ uniformLocation (combineProg s) "sheet0"
  checkError "shader 2a"
  lsheet1 <- get $ uniformLocation (combineProg s) "sheet1"
  checkError "shader 2b"
  lblend  <- get $ uniformLocation (combineProg s) "blend"
  checkError "shader 2c"
  uniform lsheet0 $= TexCoord1 (0 :: GLint)
  checkError "shader 3a"
  uniform lsheet1 $= TexCoord1 (1 :: GLint)
  checkError "shader 3b"
  uniform lblend $= TexCoord1 (realToFrac (blendFactor s) :: GLfloat)
  checkError "shader 3c"
  activeTexture $= TextureUnit 0
  checkError "shader 4"
  textureBinding Texture2D $= Just (tsheet0 s)
  checkError "shader 5"
  activeTexture $= TextureUnit 1
  checkError "shader 6"
  textureBinding Texture2D $= Just (tsheet1 s)
  checkError "shader 7"
  let t x0 y0 = texCoord $ TexCoord2 (0.5 + x' :: GLdouble) (0.5 + y' :: GLdouble)
        where
          p = realToFrac . sqrt . aspect . imageViewport . image $ s
          x = k * x0 * p
          y = k * y0 / p
          a = - rotationA s
          co = realToFrac $ cos a
          si = realToFrac $ sin a
          x' =  co * x + si * y
          y' = -si * x + co * y
      v :: Int -> Int -> IO ()
      v x y = vertex $ Vertex2
        (fromIntegral x :: GLdouble) (fromIntegral y :: GLdouble)
      k = 0.125 * realToFrac (0.5 ** zoomPhase s) :: GLdouble
  renderPrimitive Quads $ do
    t (-1) 1 >> v 0 h
    t (-1) (-1) >> v 0 0
    t 1 (-1) >> v w 0
    t 1 1 >> v w h
  checkError "quad"
  textureBinding Texture2D $= Nothing
  checkError "shader 8"
  activeTexture $= TextureUnit 0
  checkError "shader 9"
  textureBinding Texture2D $= Nothing
  checkError "shader A"
  currentProgram $= Nothing
  checkError "shader B"

  -- save state
  m <- get matrixMode
  matrixMode $= Modelview 0
  colour0 <- get currentColor
  -- pixel mapping
  let i = image s
      locP = locationPixel (imageWindow i) (imageViewport i) (imageLocation i)
      locL (a, b) = [locP a, locP b]
  -- draw lines
  forM_ (imageLines i) $ \l -> do
    let ps = concatMap locL (lineSegments l)
        Colour r g b = lineColour l
    currentColor $= Color4 (realToFrac r) (realToFrac g) (realToFrac b) 1
    renderPrimitive Lines $ forM_ ps $ \(x, y) -> do
      vertex $ Vertex2 (realToFrac x) (fromIntegral h - realToFrac y :: GLdouble)
  -- draw labels
  forM_ (imageLabels i) $ \l -> do
    let (x, y) = locP (labelCoords l)
        Colour r g b = labelColour l
    currentColor $= Color4 (realToFrac r) (realToFrac g) (realToFrac b) 1
    translate (Vector3 (realToFrac x) (fromIntegral h - realToFrac y) (0 :: GLdouble))
    renderFont (font s) (labelText l) All
    translate (Vector3 (-realToFrac x) (realToFrac y - fromIntegral h) (0 :: GLdouble))
  -- restore state
  currentColor $= colour0
  matrixMode $= m

  s'' <- readIORef iR
  when (sheetCount0 s'' + sheetCount1 s'' >= sheetCountTarget s'') $ do
    case doneCallback s of
      Nothing -> return ()
      Just act -> do
        atomicModifyIORef iR $ \s' -> (s'{ doneCallback = Nothing, abortCallback = Nothing }, ())
        act
  prune iR
  checkError "display end"

clearSheet :: GruffImage -> Bool -> IO ()
clearSheet s b = do
  checkError "clearSheet begin"
  let tw' = texels $ sheetSize s
      th' = tw'
      tw = if b then tw' * 2 else tw'
      th = if b then th' * 2 else th'
      tsheet = (if b then tsheet1 else tsheet0) s
  bindFBO (fbo s) tsheet
  checkError "clearSheet fbo bind"
  GL.viewport $=
    (GL.Position 0 0, GL.Size (fromIntegral tw) (fromIntegral th))
  checkError "clearSheet V"
  loadIdentity
  checkError "clearSheet I"
  clearColor $= Color4 0 0 1 1
  checkError "clearSheet CC"
  clear [ColorBuffer]
  checkError "clearSheet C"
  unbindFBO
  checkError "clearSheet fbo unbind"
  textureBinding Texture2D $= Just tsheet
  checkError "clearSheet tex bind"
  glGenerateMipmap GL_TEXTURE_2D
  checkError "clearSheet tex mipmap"
  textureBinding Texture2D $= Nothing
  checkError "clearSheet tex unbind"
  checkError "clear end"

renderSheet :: GruffImage -> Bool -> IO ([(Complex Int, Quad)], Int)
renderSheet s b = do
  checkError "renderSheet begin"
  let tw' = texels $ sheetSize s
      th' = tw'
      tw = if b then tw' * 2 else tw'
      th = if b then th' * 2 else th'
      tsheet = (if b then tsheet1 else tsheet0) s
      vquads = (if b then snd else fst) (viewQuads s)
  if null vquads then return ([], 0) else do
    bindFBO (fbo s) tsheet
    checkError "renderSheet fbo bind"
    GL.viewport $=
      (GL.Position 0 0, GL.Size (fromIntegral tw) (fromIntegral th))
    checkError "renderSheet V"
    loadIdentity
    checkError "renderSheet I"
    ortho2D 0 (fromIntegral tw) 0 (fromIntegral th)
    checkError "renderSheet O"
    currentProgram $= Just (prog s)
    checkError "renderSheet shader 1"
    lde <- get $ uniformLocation (prog s) "de"
    checkError "renderSheet shader u1"
    lit <- get $ uniformLocation (prog s) "it"
    checkError "renderSheet shader u2"
    ltt <- get $ uniformLocation (prog s) "tt"
    checkError "renderSheet shader u3"
    lint <- get $ uniformLocation (prog s) "interior"
    checkError "renderSheet shader u4"
    lbrd <- get $ uniformLocation (prog s) "border"
    checkError "renderSheet shader u5"
    lext <- get $ uniformLocation (prog s) "exterior"
    checkError "renderSheet shader u6"
    uniform lde $= TexCoord1 (0 :: GLint)
    checkError "renderSheet shader t1"
    uniform lit $= TexCoord1 (1 :: GLint)
    checkError "renderSheet shader t2"
    uniform ltt $= TexCoord1 (2 :: GLint)
    checkError "renderSheet shader t3"
    let (ci, cb, ce) = fromColours . imageColours . image $ s
    uniform lint $= ci
    checkError "renderSheet shader s1"
    uniform lbrd $= cb
    checkError "renderSheet shader s2"
    uniform lext $= ce
    checkError "renderSheet shader s3"
    todo <- foldM (\a t -> do a' <- drawQuad (tiles s) t ; return (a' ++ a)) [] vquads
    checkError "renderSheet drawQuads"
    currentProgram $= Nothing
    checkError "renderSheet shader 2"
    unbindFBO
    checkError "renderSheet fbo unbind"
    let upped = length vquads - length todo
    when (upped > 0) $ do
      textureBinding Texture2D $= Just tsheet
      checkError "renderSheet tex bind"
      glGenerateMipmap GL_TEXTURE_2D
      checkError "renderSheet tex mipmap"
      textureBinding Texture2D $= Nothing
      checkError "renderSheet tex unbind"
    checkError "renderSheet end"
    return (todo, upped)

drawQuad :: Map Quad TextureObject3 -> (Complex Int, Quad) -> IO [(Complex Int, Quad)]
drawQuad m ijq@(i :+ j, q) = case q `M.lookup` m of
  Nothing -> return [ijq]
  Just (tde, tit, ttt) -> do
    checkError "drawQuad begin"
    let t x y = texCoord $ TexCoord2 (x :: GLdouble) (y :: GLdouble)
        v x y = vertex $ Vertex2 (x :: GLdouble) (y :: GLdouble)
        x0 = fromIntegral i
        y0 = fromIntegral j
        x1 = x0 + fromIntegral tileSize
        y1 = y0 + fromIntegral tileSize
    activeTexture $= TextureUnit 0
    checkError "drawQuad tex 0"
    textureBinding Texture2D $= Just tde
    checkError "drawQuad tex 0b"
    activeTexture $= TextureUnit 1
    checkError "drawQuad tex 1"
    textureBinding Texture2D $= Just tit
    checkError "drawQuad tex 1b"
    activeTexture $= TextureUnit 2
    checkError "drawQuad tex 2"
    textureBinding Texture2D $= Just ttt
    checkError "drawQuad tex 2b"
    renderPrimitive Quads $ do
      color $ Color3 1 1 (1::GLdouble)
      t 0 1 >> v x0 y1
      t 0 0 >> v x0 y0
      t 1 0 >> v x1 y0
      t 1 1 >> v x1 y1
    checkError "drawQuad render"
    textureBinding Texture2D $= Nothing
    checkError "drawQuad tex 3b"
    activeTexture $= TextureUnit 1
    checkError "drawQuad tex 3"
    textureBinding Texture2D $= Nothing
    checkError "drawQuad tex 4b"
    activeTexture $= TextureUnit 0
    checkError "drawQuad tex 4"
    textureBinding Texture2D $= Nothing
    checkError "drawQuad tex 5b"
    return []

iReshape :: IORef GruffImage -> Maybe Double -> Size -> IO ()
iReshape iR ms size'@(Size w h) = do
  s' <- readIORef iR
  log s' Debug $ "reshapeCallback " ++ show size'
  let ss = case ms of Nothing -> supersamples (imageWindow (image s')) ; Just r -> r
  atomicModifyIORef iR $ \s -> (s{ image = (image s)
    { imageWindow = (imageWindow (image s)){ width = w, height = h, supersamples = ss }
    , imageViewport = (imageViewport (image s)){ aspect = fromIntegral w / fromIntegral h }
    } }, ())
  s'' <- readIORef iR
  unless (sheetSize s' == sheetSize s'') (reallocateBuffers iR)
  case Browser.reshapeCallback s' of
    Nothing -> return ()
    Just act -> act w h

iMouse :: IORef GruffImage -> Key -> KeyState -> [Modifier] -> Position -> IO ()
iMouse sR (MouseButton but) Down mods p@(Position x y) | but `elem` buts = do
  let shift = Shift   `elem` mods
      ctrl  = Control `elem` mods
      m | shift && ctrl = SC
        | ctrl          = C
        | shift         = S
        | otherwise     = U
      b = case but of
        LeftButton   -> L
        MiddleButton -> M
        RightButton  -> R
        _ -> error "weasels!!!!111one"
  s <- readIORef sR
  log s Debug $ "mouse " ++ show (b, m) ++ " " ++ show p
  case (b, m) `M.lookup` mouseCallback s of
    Nothing -> return ()
    Just cb -> do
      let i = image s
          c = pixelLocation (imageWindow i) (imageViewport i) (imageLocation i) x y
      cb c i
  where buts = [LeftButton, MiddleButton, RightButton]
iMouse _ _ _ _ _ = return ()

quadDistance :: Quad -> Quad -> Double
quadDistance q0 q1 =
  let Quad{ quadLevel = l0, quadWest = r0, quadNorth = i0 } = q0
      Quad{ quadLevel = l, quadWest = r, quadNorth = i} = q1
      dl = sqr (fromIntegral l - fromIntegral l0)
      d x x0
        | l >  l0 = fromIntegral $ sqr (x - x0 * 2 ^ (l - l0))
        | l == l0 = fromIntegral $ sqr (x - x0)
        | l <  l0 = fromIntegral $ sqr (x0 - x * 2 ^ (l0 - l))
      d _ _ = error "score"
  in  dl + d r r0 + d i i0

sqr :: Num a => a -> a
sqr x = x * x

prune :: IORef GruffImage -> IO ()
prune sR = do
  s0 <- readIORef sR
  let cacheSize = M.size (tiles s0)
  when (cacheSize > cacheSizeMax s0) $ do
    checkError "prune begin"
    log s0 Debug . concat $
      [ "pruning texture cache "
      , show cacheSize, " > ", show (cacheSizeMax s0)
      , " --> ", show (cacheSizeMin s0)
      ]
    bad <- atomicModifyIORef sR $ \s -> 
      let Just q0 = originQuad (imageLocation (image s)) (sheetSize s)
          score = quadDistance q0
          o = comparing (score . fst)
          (good, bad)
            = splitAt (cacheSizeMin s) . sortBy o . M.toList . tiles $ s
      in  (s{ tiles = M.fromList good }, bad)
    let t (_, (t1, t2, t3)) = [t1, t2, t3]
    deleteObjectNames $ concatMap t bad
    checkError "prune end"

update :: IORef GruffImage -> IO ()
update sR = do
  s' <- readIORef sR
  log s' Debug $ "updateCallback "
  todo' <- atomicModifyIORef sR $ \s ->
    let i = image s
        vq@(qs0, qs1) = fromMaybe ([],[]) $
          visibleQuads (imageWindow i) (imageViewport i) (imageLocation i) (sheetOffset s)
        qs = qs0 ++ qs1
        todo = S.filter (`M.notMember` tiles s) (S.fromList (map snd qs))
    in  (s{ viewQuads = vq, sheetCountTarget = length qs }, todo)
  -- cancel in-progress jobs that aren't still needed
  _ <- takeMVar (jobs s')
  p <- atomicModifyIORef sR $ \s ->
    (s{ progress = M.filter (`S.member` todo') (progress s) }, progress s)
  mapM_ (`poke` 1) . filter (\w -> case M.lookup w p of
    Nothing -> False
    Just q -> q `S.notMember` todo') . workers $ s'
  -- set new jobs
  s <- readIORef sR
  let Just q0 = originQuad (imageLocation (image s)) (sheetSize s)
      score = quadDistance q0
  putMVar (jobs s') . sortBy (comparing score) . S.toList $ todo' \\ S.fromList (M.elems p)

putTile :: IORef GruffImage -> Ptr CInt -> Tile -> IO ()
putTile sR p t = do
  qu <- atomicModifyIORef sR $ \s ->
    (s{ progress = M.delete p (progress s) }, queue s)
  ts <- takeMVar qu
  putMVar qu (t:ts)

putJobs :: IORef GruffImage -> [Quad] -> IO ()
putJobs sR qs = do
  s <- readIORef sR
  _ <- takeMVar (jobs s)
  putMVar (jobs s) qs

takeJob :: IORef GruffImage -> Ptr CInt -> IO Quad
takeJob sR p = do
  s <- readIORef sR
  qs <- takeMVar (jobs s)
  case qs of
    [] -> do
      putMVar (jobs s) []
      threadDelay 10000
      takeJob sR p
    (q:qs') -> do
      atomicModifyIORef sR $ \s' ->
        ( s'{ progress = M.insert p q (progress s') }, ())
      putMVar (jobs s) qs'
      return q

worker :: IORef GruffImage -> Ptr CInt -> IO ()
worker sR p = forever $ do
  s <- readIORef sR
  q <- takeJob sR p
  mt <- getTile (log s Debug) (cacheDir s) p q
  case mt of
    Nothing -> return ()
    Just t -> putTile sR p t

timer :: IORef GruffImage -> IO ()
timer sR = do
  s <- readIORef sR
  mtls <- tryTakeMVar (queue s)
  case mtls of
    Just tls -> do
      putMVar (queue s) tls
      unless (null tls) $ postRedisplay (gl s)
    _ -> return ()

upload :: Ptr CFloat -> IO TextureObject
upload p = do
  checkError "upload begin"
  [tex] <- genObjectNames 1
  checkError "upload 1"
  texture Texture2D $= Enabled
  checkError "upload 2"
  textureBinding Texture2D $= Just tex
  checkError "upload 3"
  glTexImage2D GL_TEXTURE_2D 0 (fromIntegral GL_R32F)
    (fromIntegral tileSize) (fromIntegral tileSize) 0
      GL_RED GL_FLOAT p
  checkError "upload 4"
  textureFilter Texture2D $= ((Nearest, Nothing), Nearest)
  checkError "upload 5"
  textureWrapMode Texture2D GL.S $= (Repeated, ClampToEdge)
  checkError "upload 6"
  textureWrapMode Texture2D GL.T $= (Repeated, ClampToEdge)
  checkError "upload 7"
  textureBinding Texture2D $= Nothing
  checkError "upload 7"
  texture Texture2D $= Disabled
  checkError "upload end"
  return tex

msPerFrame :: Int
msPerFrame = 200

data Browser = Browser
  { browserWindow :: GTK.Window
  , browserGL :: GLUTGtk
  , browserRender :: Image -> IO () -> IO () -> IO ()
  , browserAbort  :: IO ()
  , browserSaveImage :: FilePath -> IO ()
  , browserSetExitCallback :: IO () -> IO ()
  , browserSetReshapeCallback :: (Int -> Int -> IO ()) -> IO ()
  , browserSetMouseCallback :: MouseCallbacks -> IO ()
  }

browserRenders :: Browser -> [(Image, FilePath)] -> IO ()
browserRenders _ [] = print "done"
browserRenders b ((i, f):ifs) = do
  result <- newEmptyMVar
  postGUISync $ do
          browserRender b i
            (browserSaveImage b f >> putMVar result True)
            (putMVar result False)
          postRedisplay (browserGL b)
  r <- takeMVar result
  if r then browserRenders b ifs else print "aborted"

browserNew :: GLUTGtk -> Pixbuf -> Logger -> FilePath -> IO Browser
browserNew gl' icon lg cacheDir' = do
  -- image window
  iw <- windowNew
  let defW = width  defWindow
      defH = height defWindow
  windowSetDefaultSize iw defW defH
  windowSetGeometryHints iw (Nothing `asTypeOf` Just iw)
    (Just (160, 120)) (Just (4096, 4096)) Nothing Nothing Nothing
  set iw
    [ containerBorderWidth := 0
    , containerChild := widget gl'
    , windowIcon  := Just icon
    , windowTitle := "gruff browser"
    ]
  queue' <- newMVar []
  jobs' <- newMVar []
  iR <- newIORef GruffImage
      -- image parameters
    { image = defImage
      -- callbacks
    , exitCallback = Nothing
    , Browser.reshapeCallback = Nothing
    , mouseCallback = M.empty
    , doneCallback = Nothing
    , abortCallback = Nothing
      -- job queue
    , tiles = M.empty
    , queue = queue'
    , jobs = jobs'
    , progress = M.empty
    , viewQuads = ([], [])
    , gl = gl'
    , cacheDir = cacheDir'
    , log = Log.log lg
    , workers = []
    , prog = error "prog"
    , fbo = 0
    , combineProg = error "combineProg"
    , tsheet0 = TextureObject 0
    , tsheet1 = TextureObject 0
    , sheetCount0 = 0
    , sheetCount1 = 0
    , sheetCountTarget = maxBound
    , cacheSizeMin = 1000
    , cacheSizeMax = 1500
    , doClear = False
    , font = error "font"
    }
  realizeCallback gl' $= iRealize iR
  GLUTGtk.reshapeCallback gl' $= iReshape iR Nothing
  displayCallback gl' $= iDisplay iR
  let browserAbort' = do
        i <- readIORef iR
        putJobs iR []
        mapM_ (`poke` 1) . workers $ i
        act <- atomicModifyIORef iR $ \s -> (s
          { progress = M.empty
          , doneCallback = Nothing
          , abortCallback = Nothing
          }, abortCallback s)
        fromMaybe (return ()) act
      atExit = do
        i <- readIORef iR
        case exitCallback i of
          Nothing -> return ()
          Just act -> act
      browserRender' img done aborted = do
        s <- readIORef iR
        let wr = width  (imageWindow img)
            hr = height (imageWindow img)
        unless (width  (imageWindow (image s)) == wr &&
                height (imageWindow (image s)) == hr) $ do
          windowResize iw wr hr
        atomicModifyIORef iR $ \s' -> (s'{ image = img }, ())
        s' <- readIORef iR
        unless (sheetSize s == sheetSize s') (reallocateBuffers iR)
        atomicModifyIORef iR $ \i -> (i
          { doneCallback = Just done
          , abortCallback = Just aborted
          , doClear = True
          }, ())
        update iR
      browserSaveImage' fname = do
        s <- readIORef iR
        writeSnapshot fname (GL.Position 0 0)
          (GL.Size (fromIntegral (width (imageWindow (image s))))
                   (fromIntegral (height (imageWindow (image s)))))
      browserSetExitCallback' act = atomicModifyIORef iR $ \i ->
        ( i{ exitCallback = Just act }, () )
      browserSetReshapeCallback' act = atomicModifyIORef iR $ \i ->
        ( i{ Browser.reshapeCallback = Just act }, () )
      browserSetMouseCallback' act = atomicModifyIORef iR $ \i ->
        ( i{ mouseCallback = act }, () )
  keyboardMouseCallback gl' $= iMouse iR
  _ <- timeoutAdd (timer iR >> return True) msPerFrame
  _ <- iw `onDestroy` atExit
  return Browser
    { browserWindow = iw
    , browserGL = gl'
    , browserRender = browserRender'
    , browserAbort = browserAbort'
    , browserSaveImage = browserSaveImage'
    , browserSetExitCallback = browserSetExitCallback'
    , browserSetReshapeCallback = browserSetReshapeCallback'
    , browserSetMouseCallback = browserSetMouseCallback'
    }

fromColours :: Colours -> (Color3 GLfloat, Color3 GLfloat, Color3 GLfloat)
fromColours c =
  ( fromColour (colourInterior c)
  , fromColour (colourBoundary c)
  , fromColour (colourExterior c)
  )

fromColour :: Colour -> Color3 GLfloat
fromColour (Colour r g b) = Color3 (realToFrac r) (realToFrac g) (realToFrac b)

iRealize :: IORef GruffImage -> IO ()
iRealize iR = do
  checkError "realize begin"
  s <- readIORef iR
  log s Debug "realizeCallback"
  drawBuffer $= BackBuffers
  checkError "realize db"
  glClampColor GL_CLAMP_VERTEX_COLOR $ fromIntegral GL_FALSE
  checkError "realize clv"
  glClampColor GL_CLAMP_READ_COLOR $ fromIntegral GL_FALSE
  checkError "realize clr"
  glClampColor GL_CLAMP_FRAGMENT_COLOR $ fromIntegral GL_FALSE
  checkError "realize clf"
  f <- getDataFileName "minimal.frag"
  prog' <- shader Nothing (Just f)
  checkError "realize s1"
  f' <- getDataFileName "merge.frag"
  combineProg' <- shader Nothing (Just f')
  checkError "realize s2"
  fbo' <- newFBO
  checkError "realize fbo"
  [tsheet0', tsheet1'] <- genObjectNames 2
  checkError "realize sheets"
  -- FIXME hardcoded font path
  font' <- createTextureFont "/usr/share/fonts/truetype/dejavu/DejaVuSansMono-Bold.ttf"
  -- FIXME destroyFont (font s) at exit
  _ <- setFontFaceSize font' 16 72
  ps <- replicateM numCapabilities $ do
    p <- malloc
    _ <- forkIO (worker iR p)
    return p
  atomicModifyIORef iR $ \i -> (i
    { prog = prog'
    , workers = ps
    , fbo = fbo'
    , combineProg = combineProg'
    , tsheet0 = tsheet0'
    , tsheet1 = tsheet1'
    , sheetCount0 = 0
    , sheetCount1 = 0
    , sheetCountTarget = maxBound
    , font = font'
    }, ())
  reallocateBuffers iR
  checkError "realize end"

reallocateBuffers :: IORef GruffImage -> IO ()
reallocateBuffers iR = do
  checkError "reallocate begin"
  s <- readIORef iR
  let tw' = texels $ sheetSize s
      th' = tw'
      ts = [tsheet0 s, tsheet1 s]
  forM_ (ts `zip` [(tw', th'), (tw' * 2, th' * 2)]) $ \(t, (tw, th)) -> do
    texture Texture2D $= Enabled
    checkError "reallocate 1"
    textureBinding Texture2D $= Just t
    checkError "reallocate 2"
    glTexImage2D GL_TEXTURE_2D 0 (fromIntegral GL_RGBA)
      (fromIntegral tw) (fromIntegral th) 0 GL_RGBA GL_UNSIGNED_BYTE
      nullPtr
    checkError "reallocate 3"
    textureFilter Texture2D $= ((Linear', Just Linear'), Linear')
    checkError "reallocate 4"
    textureWrapMode Texture2D GL.S $= (Repeated, ClampToEdge)
    checkError "reallocate 5"
    textureWrapMode Texture2D GL.T $= (Repeated, ClampToEdge)
    checkError "reallocate 6"
    textureBinding Texture2D $= Nothing
    checkError "reallocate 7"
    texture Texture2D $= Disabled
    checkError "reallocate 8"
  atomicModifyIORef iR $ \s' ->
    (s'{ sheetCount0 = 0, sheetCount1 = 0, sheetCountTarget = maxBound }, ())
  checkError "reallocate end"

newFBO :: IO GLuint
newFBO = alloca $ \p -> glGenFramebuffers 1 p >> peek p

bindFBO :: GLuint -> TextureObject -> IO ()
bindFBO f (TextureObject t) = do
  checkError "bindFBO begin"
  glBindFramebuffer GL_FRAMEBUFFER f
  checkError "bindFBO 1"
  glFramebufferTexture2D GL_FRAMEBUFFER GL_COLOR_ATTACHMENT0 GL_TEXTURE_2D t 0
  checkError "bindFBO 2"
  err <- glCheckFramebufferStatus GL_FRAMEBUFFER
  when (err /= GL_FRAMEBUFFER_COMPLETE) $
    putStrLn ("OpenGL framebuffer error: " ++ show err)
  checkError "bindFBO end"

unbindFBO :: IO ()
unbindFBO = do
  checkError "unbindFBO begin"
  glFramebufferTexture2D GL_FRAMEBUFFER GL_COLOR_ATTACHMENT0 GL_TEXTURE_2D 0 0
  checkError "unbindFBO 1"
  glBindFramebuffer GL_FRAMEBUFFER 0
  checkError "unbindFBO end"

checkError :: String -> IO ()
checkError s = do
  err <- glGetError
  when (err /= 0) $ putStrLn ("OpenGL error (" ++ s ++ "): " ++ show err)