gruff-0.2: src/Browser.hs

module Browser (Browser(..), browserNew, browserRenders) where

import Prelude hiding (log)
import Control.Concurrent
  ( forkIO, MVar, 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)
import qualified Graphics.Rendering.OpenGL as GL
import Graphics.Rendering.OpenGL.Raw
  ( glTexImage2D, gl_TEXTURE_2D, gl_R32F, gl_RGBA, gl_LUMINANCE
  , gl_FLOAT, gl_UNSIGNED_BYTE, gl_FALSE, glClampColor
  , gl_CLAMP_VERTEX_COLOR, gl_CLAMP_READ_COLOR, gl_CLAMP_FRAGMENT_COLOR
  , glGenFramebuffers, glBindFramebuffer, glFramebufferTexture2D
  , gl_FRAMEBUFFER, gl_COLOR_ATTACHMENT0, glGenerateMipmap
  , glGetError
  )
import Graphics.UI.Gtk hiding (get, Window, Viewport, Region, Size, Action, Image)
import qualified Graphics.UI.Gtk as GTK

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

import Number (R)
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(..), Location(..), Window(..), Viewport(..)
  , BufferSize(..), bufferSize, tileSize, delta
  , Colours(..), Colour(..), defColours
  , pixelLocation, originQuad, visibleQuads
  , defLocation, defWindow, defViewport
  )
import Paths_gruff (getDataFileName)

type TextureObject3 = (TextureObject, TextureObject, TextureObject)
type QuadList = [(Complex Int, Quad)]
data GruffImage = GruffImage
  { location :: Location
  , window :: Window
  , viewport :: Viewport
  , 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 ()
  , colours :: Colours
  , prog :: Program
  , combineProg :: Program
  , tsheet0 :: TextureObject
  , tsheet1 :: TextureObject
  , fbo :: GLuint
  , cacheSizeMin :: Int
  , cacheSizeMax :: Int
  -- callbacks
  , exitCallback :: Maybe (IO ())
  , reshapeCallback :: Maybe (Int -> Int -> IO ())
  , mouseCallback :: Maybe (Complex R -> Double -> IO ())
  , doneCallback :: Maybe (IO ())
  , abortCallback :: Maybe (IO ())
  , doClear :: Bool
  }

sheetSize :: GruffImage -> Size
sheetSize g = let s = texels . bufferSize . window $ g in Size s s

zoomPhase :: GruffImage -> Double
zoomPhase = delta . location

rotationA :: GruffImage -> Double
rotationA = orient . viewport

iDisplay :: IORef GruffImage -> IO ()
iDisplay iR = do
  prune iR
  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
        tit <- upload ns
        ttt <- 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 (location s)
  c <- atomicModifyIORef iR $ \s' -> (s'{ doClear = False }, doClear s')
  when c $ do
    clearSheet s False
    clearSheet s True
  todo0 <- renderSheet s False
  todo1 <- renderSheet s True
  atomicModifyIORef iR $ \s' -> (s'{ viewQuads = (todo0, todo1) }, ())
  let complete = null todo0 && null todo1
      w = width (window s)
      h = height (window s)
  GL.viewport $=
    (GL.Position 0 0, GL.Size (fromIntegral w) (fromIntegral h))
  loadIdentity
  ortho2D 0 (fromIntegral w) 0 (fromIntegral h)
  clearColor $= Color4 0.5 0.5 0.5 1
  clear [ColorBuffer]
  currentProgram $= Just (combineProg s)
  lsheet0 <- get $ uniformLocation (combineProg s) "sheet0"
  lsheet1 <- get $ uniformLocation (combineProg s) "sheet1"
  lblend  <- get $ uniformLocation (combineProg s) "blend"
  uniform lsheet0 $= TexCoord1 (0 :: GLint)
  uniform lsheet1 $= TexCoord1 (1 :: GLint)
  uniform lblend $= TexCoord1 (realToFrac (
    let p = negate $ zoomPhase s
        q = 4 -- realToFrac $ supersamples (window s) -- FIXME figure out correct blend
    in  1 - (1 - q**p) / (q**(p + 1) - q**p) ) :: GLfloat)
  activeTexture $= TextureUnit 0
  textureBinding Texture2D $= Just (tsheet0 s)
  activeTexture $= TextureUnit 1
  textureBinding Texture2D $= Just (tsheet1 s)
  let t x0 y0 = texCoord $ TexCoord2 (0.5 + x' :: GLdouble) (0.5 + y' :: GLdouble)
        where
          p = realToFrac . sqrt . aspect . viewport $ 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.25 * 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
  textureBinding Texture2D $= Nothing
  activeTexture $= TextureUnit 0
  textureBinding Texture2D $= Nothing
  currentProgram $= Nothing
  when complete $ case doneCallback s of
    Nothing -> return ()
    Just act -> do
      atomicModifyIORef iR $ \s' -> (s'{ doneCallback = Nothing, abortCallback = Nothing }, ())
      act
  err <- glGetError
  when (err /= 0) $ print ("error: " ++ show err)

clearSheet :: GruffImage -> Bool -> IO ()
clearSheet s b = do
  let Size tw' th' = sheetSize s
      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
  GL.viewport $=
    (GL.Position 0 0, GL.Size (fromIntegral tw) (fromIntegral th))
  loadIdentity
  clearColor $= Color4 0 0 1 1
  clear [ColorBuffer]
  unbindFBO
  textureBinding Texture2D $= Just tsheet
  glGenerateMipmap gl_TEXTURE_2D
  textureBinding Texture2D $= Nothing

renderSheet :: GruffImage -> Bool -> IO [(Complex Int, Quad)]
renderSheet s b = do
  let Size tw' th' = sheetSize s
      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 [] else do
    bindFBO (fbo s) tsheet
    GL.viewport $=
      (GL.Position 0 0, GL.Size (fromIntegral tw) (fromIntegral th))
    loadIdentity
    ortho2D 0 (fromIntegral tw) 0 (fromIntegral th)
    currentProgram $= Just (prog s)
    lde <- get $ uniformLocation (prog s) "de"
    lit <- get $ uniformLocation (prog s) "it"
    ltt <- get $ uniformLocation (prog s) "tt"
    lint <- get $ uniformLocation (prog s) "interior"
    lbrd <- get $ uniformLocation (prog s) "border"
    lext <- get $ uniformLocation (prog s) "exterior"
    uniform lde $= TexCoord1 (0 :: GLint)
    uniform lit $= TexCoord1 (1 :: GLint)
    uniform ltt $= TexCoord1 (2 :: GLint)
    let (ci, cb, ce) = fromColours $ colours s
    uniform lint $= ci
    uniform lbrd $= cb
    uniform lext $= ce
    todo <- foldM (\a t -> do a' <- drawQuad (tiles s) t ; return (a' ++ a)) [] vquads
    currentProgram $= Nothing
    unbindFBO
    when (length todo < length vquads) $ do
      textureBinding Texture2D $= Just tsheet
      glGenerateMipmap gl_TEXTURE_2D
      textureBinding Texture2D $= Nothing
    return todo

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
    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
    textureBinding Texture2D $= Just tde
    activeTexture $= TextureUnit 1
    textureBinding Texture2D $= Just tit
    activeTexture $= TextureUnit 2
    textureBinding Texture2D $= Just ttt
    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
    textureBinding Texture2D $= Nothing
    activeTexture $= TextureUnit 1
    textureBinding Texture2D $= Nothing
    activeTexture $= TextureUnit 0
    textureBinding Texture2D $= Nothing
    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 (window s') ; Just r -> r
  atomicModifyIORef iR $ \s -> (s{ window = (window s){ width = w, height = h, supersamples = ss }, viewport = (viewport 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 LeftButton  ) Down _ p@(Position x y) = do
  s <- readIORef sR
  log s Debug $ "leftMouse " ++ show p
  case mouseCallback s of
    Nothing -> return ()
    Just act -> do
      let o = fromPixel s x y
          cx :+ cy = center (location s)
          c = fromRational cx :+ fromRational cy
          r = radius (location s)
          r' = 0.9 * r
          c' = 0.9 * c + 0.1 * o
      act c' r'
iMouse sR (MouseButton MiddleButton) Down _ p@(Position x y) = do
  s <- readIORef sR
  log s Debug $ "middleMouse " ++ show p
  case mouseCallback s of
    Nothing -> return ()
    Just act -> act (fromPixel s x y) (radius (location s))
iMouse sR (MouseButton RightButton ) Down _ p@(Position x y) = do
  s <- readIORef sR
  log s Debug $ "rightMouse " ++ show p
  case mouseCallback s of
    Nothing -> return ()
    Just act -> do
      let o = fromPixel s x y
          cx :+ cy = center (location s)
          c = fromRational cx :+ fromRational cy
          r = radius (location s)
          r' = 1.1 * r
          c' = 1.1 * c - 0.1 * o
      act c' r'
iMouse _ _ _ _ _ = return ()

fromPixel :: GruffImage -> Double -> Double -> Complex R
fromPixel g x y = let r:+i = pixelLocation (window g) (viewport g) (location g) x y in fromRational r :+ fromRational i

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
    log s0 Debug . concat $
      [ "pruning texture cache "
      , show cacheSize, " > ", show (cacheSizeMax s0)
      , " --> ", show (cacheSizeMin s0)
      ]
    bad <- atomicModifyIORef sR $ \s -> 
      let Just q0 = originQuad (location s) (bufferSize (window 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

update :: IORef GruffImage -> IO ()
update sR = do
  s' <- readIORef sR
  log s' Debug $ "updateCallback "
  todo' <- atomicModifyIORef sR $ \s ->
    let vq@(qs0, qs1) = fromMaybe ([],[]) $ visibleQuads (window s) (viewport s) (location s)
        qs = qs0 ++ qs1
        todo = S.filter (`M.notMember` tiles s) (S.fromList (map snd qs))
    in  (s{ viewQuads = vq }, 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 (location s) (bufferSize (window 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
  [tex] <- genObjectNames 1
  texture Texture2D $= Enabled
  textureBinding Texture2D $= Just tex
  glTexImage2D gl_TEXTURE_2D 0 (fromIntegral gl_R32F)
    (fromIntegral tileSize) (fromIntegral tileSize) 0
      gl_LUMINANCE gl_FLOAT p
  textureFilter Texture2D $= ((Nearest, Nothing), Nearest)
  textureWrapMode Texture2D S $= (Repeated, ClampToEdge)
  textureWrapMode Texture2D T $= (Repeated, ClampToEdge)
  textureBinding Texture2D $= Nothing
  texture Texture2D $= Disabled
  return tex

msPerFrame :: Int
msPerFrame = 200

data Browser = Browser
  { browserWindow :: GTK.Window
  , browserRender :: Image -> IO () -> IO () -> IO ()
  , browserAbort  :: IO ()
  , browserSaveImage :: FilePath -> IO ()
  , browserSetExitCallback :: IO () -> IO ()
  , browserSetReshapeCallback :: (Int -> Int -> IO ()) -> IO ()
  , browserSetMouseCallback :: (Complex R -> Double -> IO ()) -> IO ()
  , browserResize :: Int -> Int -> Double -> IO ()
  }

browserRenders :: Browser -> [(Image, FilePath)] -> IO ()
browserRenders _ [] = print "done"
browserRenders b ((i, f):ifs) = browserRender b i
  (browserSaveImage b f >> browserRenders b ifs)
  (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 (2048, 1536)) 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
    { location = defLocation
    , viewport = defViewport
    , window = defWindow
    , colours = defColours
      -- callbacks
    , exitCallback = Nothing
    , Browser.reshapeCallback = Nothing
    , mouseCallback = Nothing
    , 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
    , cacheSizeMin = 1000
    , cacheSizeMax = 1500
    , doClear = False
    }
  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
        atomicModifyIORef iR $ \i -> (i
          { doneCallback = Just done
          , abortCallback = Just aborted
          , location = imageLocation img
          , viewport = imageViewport img
          , window = imageWindow img
          , colours = imageColours img
          , doClear = True
          }, ())
        update iR
      browserSaveImage' fname = do
        s <- readIORef iR
        writeSnapshot fname (GL.Position 0 0) (GL.Size (fromIntegral (width (window s))) (fromIntegral (height (window 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 = Just act }, () )
      browserResize' w h s = windowResize iw w h >> iReshape iR (Just s) (Size w h)
  keyboardMouseCallback gl' $= iMouse iR
  _ <- timeoutAdd (timer iR >> return True) msPerFrame
  _ <- iw `onDestroy` atExit
  return Browser
    { browserWindow = iw
    , browserRender = browserRender'
    , browserAbort = browserAbort'
    , browserSaveImage = browserSaveImage'
    , browserSetExitCallback = browserSetExitCallback'
    , browserSetReshapeCallback = browserSetReshapeCallback'
    , browserSetMouseCallback = browserSetMouseCallback'
    , browserResize = browserResize'
    }

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
  s <- readIORef iR
  log s Debug "realizeCallback"
  drawBuffer $= BackBuffers
  glClampColor gl_CLAMP_VERTEX_COLOR gl_FALSE
  glClampColor gl_CLAMP_READ_COLOR gl_FALSE
  glClampColor gl_CLAMP_FRAGMENT_COLOR gl_FALSE
  f <- getDataFileName "minimal.frag"
  prog' <- shader Nothing (Just f)
  f' <- getDataFileName "merge.frag"
  combineProg' <- shader Nothing (Just f')
  fbo' <- newFBO
  [tsheet0', tsheet1'] <- genObjectNames 2
  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'
    }, ())
  reallocateBuffers iR

reallocateBuffers :: IORef GruffImage -> IO ()
reallocateBuffers iR = do
  s <- readIORef iR
  let Size tw' th' = sheetSize s
      ts = [tsheet0 s, tsheet1 s]
  forM_ (ts `zip` [(tw', th'), (tw' * 2, th' * 2)]) $ \(t, (tw, th)) -> do
    texture Texture2D $= Enabled
    textureBinding Texture2D $= Just t
    glTexImage2D gl_TEXTURE_2D 0 (fromIntegral gl_RGBA)
      (fromIntegral tw) (fromIntegral th) 0 gl_RGBA gl_UNSIGNED_BYTE
      nullPtr
    textureFilter Texture2D $= ((Linear', Just Linear'), Linear')
    textureWrapMode Texture2D S $= (Repeated, ClampToEdge)
    textureWrapMode Texture2D T $= (Repeated, ClampToEdge)
    textureBinding Texture2D $= Nothing
    texture Texture2D $= Disabled

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

bindFBO :: GLuint -> TextureObject -> IO ()
bindFBO f (TextureObject t) = do
  glBindFramebuffer gl_FRAMEBUFFER f
  glFramebufferTexture2D gl_FRAMEBUFFER gl_COLOR_ATTACHMENT0 gl_TEXTURE_2D t 0

unbindFBO :: IO ()
unbindFBO = do
  glFramebufferTexture2D gl_FRAMEBUFFER gl_COLOR_ATTACHMENT0 gl_TEXTURE_2D 0 0
  glBindFramebuffer gl_FRAMEBUFFER 0