module Interface.TV.Gtk.GL2
( module Interface.TV.Gtk2
, renderOut, emptyTexture, textureIsEmpty, textureIn
) where
import Control.Applicative ((<$>))
import Data.IORef
import Graphics.UI.Gtk hiding (Action)
import Graphics.UI.Gtk.OpenGL
import qualified Graphics.Rendering.OpenGL as G
import Graphics.Rendering.OpenGL hiding (Sink,get)
import Data.Bitmap.OpenGL
import Codec.Image.STB
import Interface.TV.Gtk2
mkCanvas :: IO GLDrawingArea
mkCanvas =
glConfigNew [ GLModeRGBA, GLModeDepth , GLModeDouble, GLModeAlpha ]
>>= glDrawingAreaNew
renderOut :: Out Action
renderOut = primMkO $
do forget initGL
canvas <- mkCanvas
widgetSetSizeRequest canvas 300 300
forget $ onRealize canvas $ withGLDrawingArea canvas $ const $
do
depthFunc $= Just Less
drawBuffer $= BackBuffers
clearColor $= Color4 0 0 0.2 1
drawRef <- newIORef (return ())
let display draw =
withGLDrawingArea canvas $ \ glwindow ->
do clear [DepthBuffer, ColorBuffer]
flipY
draw
flipY
finish
glDrawableSwapBuffers glwindow
writeIORef drawRef draw
forget $ onExpose canvas $ \_ ->
do (w',h') <- widgetGetSize canvas
let w = fromIntegral w' :: GLsizei
h = fromIntegral h'
maxWH = w `max` h
start s = fromIntegral ((s maxWH) `div` 2)
viewport $= (Position (start w) (start h), Size maxWH maxWH)
readIORef drawRef >>= display
return True
return (toWidget canvas, display, return ())
flipY :: Action
flipY = scale 1 (1 :: GLfloat) 1
emptyTexture :: TextureObject
emptyTexture = TextureObject bogusTO
bogusTO :: G.GLuint
bogusTO = 1
textureIsEmpty :: TextureObject -> Bool
textureIsEmpty (TextureObject i) = i == bogusTO
loadTexture :: FilePath -> IO (Either String TextureObject)
loadTexture path =
do e <- loadImage path
case e of
Left err -> return (Left err)
Right im -> Right <$> makeSimpleBitmapTexture im
textureIn :: In TextureObject
textureIn = fileMungeIn loadTexture deleteTexture emptyTexture
deleteTexture :: Sink TextureObject
deleteTexture tex | textureIsEmpty tex = return ()
| otherwise =
do
deleteObjectNames [tex]
fileMungeIn ::
(FilePath -> IO (Either String a)) -> Sink a -> a -> In a
fileMungeIn munge free start = primMkI $
do w <- fileChooserButtonNew "Select file" FileChooserActionOpen
current <- newIORef start
let install refresh =
forget2 onUpdatePreview w $
do
mb <- fileChooserGetFilename w
case mb of
Nothing -> return ()
Just path ->
do e <- munge path
case e of
Left _ -> return ()
Right a -> do readIORef current >>= free
writeIORef current a
refresh
return (toWidget w, readIORef current, return (), install)