module DrawFrame where import Control.Monad import Control.Exception import Data.Bits hiding (rotate) import Data.List import Data.Maybe import Data.Word import Foreign.Marshal.Alloc import Foreign.Marshal.Utils import Foreign.Ptr import Foreign.Storable import qualified Graphics.Rendering.OpenGL.GL as GL import qualified Graphics.Rendering.OpenGL.GLU.Matrix as Matrix import Graphics.Rendering.OpenGL.GLU.Matrix import Graphics.X11.Types import Graphics.X11.Xlib import Graphics.X11.Xlib.Types import Graphics.X11.Xlib.Color import Graphics.X11.Xlib.Misc import GLX.Constants import GLX import ClientMessage import qualified AVCodec as AVCodec -- create an openGL window createGlWindow :: Display -> Window -> Position -> Position -> Dimension -> Dimension -> [Attribute] -> IO (Maybe Window) createGlWindow dpy win xpos ypos xdimen ydimen glxAttrs = do mVis <- chooseVisual dpy (defaultScreen dpy) glxAttrs case mVis of Nothing -> return Nothing (Just vis) -> do dep <- depth vis w <- allocaXSetWindowAttributes $ \xwa -> do set_background_pixel xwa (blackPixel dpy (defaultScreen dpy)) set_border_pixel xwa (blackPixel dpy (defaultScreen dpy)) colorMap <- createColormap dpy win (visual vis) allocNone set_colormap xwa colorMap createWindow dpy win xpos ypos xdimen ydimen 0 dep inputOutput (visual vis) (cWBackPixel .|. cWBorderPixel .|. cWColormap) xwa mCtx <- createContext dpy vis Nothing True case mCtx of Nothing -> return Nothing (Just ctx) -> do ok <- makeCurrent dpy w ctx if ok then return (Just w) else return Nothing xInit f = bracket (openDisplay ":0") (\d -> closeDisplay d >> putStrLn "done.") $ \dpy -> do mW <- createGlWindow dpy (defaultRootWindow dpy) 100 100 800 800 [DoubleBuffer, RGBA, RedSize 1, GreenSize 1, BlueSize 1] when (isNothing mW) (error "Could not initialize GL window") (Just w) <- return mW GL.get GL.doubleBuffer >>= print atom <- internAtom dpy "WM_DELETE_WINDOW" False setWMProtocols dpy w [atom] selectInput dpy w (structureNotifyMask .|. pointerMotionMask .|. exposureMask) mapWindow dpy w gc <- createGC dpy w setForeground dpy gc (whitePixel dpy (defaultScreen dpy)) allocaXEvent $ \xe -> do waitForMapNotify dpy xe t <- glInit f t dpy w -- swapBuffers dpy w -- waitForDelete dpy w gc xe return () where waitForMapNotify dpy xe = do nextEvent dpy xe et <- get_EventType xe if et == mapNotify then return () else waitForMapNotify dpy xe {- waitForDelete dpy w gc xe = do glDrawFrame frame numBytes frameWidth frameHeight swapBuffers dpy w nextEvent dpy xe et <- get_EventType xe case () of () | et == clientMessage -> do (mt, data') <- get_ClientMessageEvent xe protocolsAtom <- internAtom dpy "WM_PROTOCOLS" True deleteWindowAtom <- internAtom dpy "WM_DELETE_WINDOW" True if (mt == protocolsAtom) then case data' of (ClientData32 (h:_)) | (fromIntegral h) == deleteWindowAtom -> return () -- error "done." _ -> print data' >> waitForDelete dpy w gc xe else waitForDelete dpy w gc xe | otherwise -> waitForDelete dpy w gc xe -} glInit = do GL.clearColor GL.$= GL.Color4 0 0 0 1 -- GL.blendFunc GL.$= (GL.SrcAlpha, GL.One) -- GL.blend GL.$= GL.Enabled GL.texture GL.Texture2D GL.$= GL.Enabled GL.generateMipmap GL.Texture2D GL.$= GL.Disabled [t] <- GL.genObjectNames 1 GL.textureBinding GL.Texture2D GL.$= Just t GL.textureFilter GL.Texture2D GL.$= ((GL.Nearest, Nothing), GL.Nearest) return t {- glDrawFrame t frame numBytes w h = do GL.clear [GL.ColorBuffer,GL.DepthBuffer] GL.matrixMode GL.$= GL.Projection GL.loadIdentity Matrix.ortho2D 0.0 400.0 0.0 400.0 GL.matrixMode GL.$= GL.Modelview 0 GL.loadIdentity GL.translate ((GL.Vector3 0.375 0.375 0.0) :: GL.Vector3 GL.GLfloat) GL.rowAlignment GL.Unpack GL.$= 1 GL.rasterPos (GL.Vertex2 200.00 200.0 :: GL.Vertex2 GL.GLfloat) pixels <- AVCodec.frameData frame -- print ("frame size", w, h) GL.drawPixels (GL.Size (fromIntegral w) (fromIntegral h)) (GL.PixelData GL.RGB GL.UnsignedByte pixels) -} -- FIXME: need to free texture pixels glDrawFrame r t frame numBytes w h = do GL.clear [GL.ColorBuffer,GL.DepthBuffer] GL.matrixMode GL.$= GL.Projection GL.loadIdentity -- Matrix.ortho2D GL.ortho 0.0 800.0 0.0 800.0 (-400.0) (400.0) GL.matrixMode GL.$= GL.Modelview 0 GL.loadIdentity let w2 = roundUpToNextPowerOf2 w h2 = roundUpToNextPowerOf2 h size = 3 -- print (numBytes, w,h,w2,h2) pixels <- AVCodec.frameData frame texPixels <- resizeBuf (w * size) h pixels (w2 * size) h2 -- print ("frame size", w, h)pn (GL.texImage2D Nothing GL.NoProxy 0 GL.RGB' (GL.TextureSize2D (fromIntegral w2) (fromIntegral h2)) 0 (GL.PixelData GL.RGB GL.UnsignedByte texPixels)) GL.textureBinding GL.Texture2D GL.$= Just t GL.translate (GL.Vector3 400.0 400.0 0.0 :: GL.Vector3 GL.GLfloat) GL.rotate r (GL.Vector3 0.0 1.0 0.0 :: GL.Vector3 GL.GLfloat) GL.rotate r (GL.Vector3 0.0 0.0 1.0 :: GL.Vector3 GL.GLfloat) GL.translate (GL.Vector3 160.0 (-200.0) 0 :: GL.Vector3 GL.GLfloat) GL.renderPrimitive GL.Quads $ do GL.texCoord (GL.TexCoord2 0.0 0.0 :: GL.TexCoord2 GL.GLfloat) GL.vertex (GL.Vertex2 (-512.0) (-512.0) :: GL.Vertex2 GL.GLfloat) GL.texCoord (GL.TexCoord2 1.0 0.0 :: GL.TexCoord2 GL.GLfloat) GL.vertex (GL.Vertex2 (511.0) (-512.0) :: GL.Vertex2 GL.GLfloat) GL.texCoord (GL.TexCoord2 1.0 1.0 :: GL.TexCoord2 GL.GLfloat) GL.vertex (GL.Vertex2 (511.0) (511.0) :: GL.Vertex2 GL.GLfloat) GL.texCoord (GL.TexCoord2 0.0 1.0 :: GL.TexCoord2 GL.GLfloat) GL.vertex (GL.Vertex2 (-512.0) (511.0) :: GL.Vertex2 GL.GLfloat) GL.flush free texPixels roundUpToNextPowerOf2 :: (Num a, Ord a) => a -> a roundUpToNextPowerOf2 n = fromJust $ find (\ n' -> n' > n) [ 2^p | p <- [0..]] -- FIXME: zero memory -- assumes dstLen > srcLen resizeBuf w h buf w' h' = do buf' <- mallocBytes (w' * h') copyRows (buf' `plusPtr` ((h' - 1) * w')) buf h w w' return buf' where copyRows to from 0 srcLen dstLen = do zeroRows to dstLen (h' - h) copyRows to from rows srcLen dstLen = do copyBytes to from srcLen zeroBytes (to `plusPtr` srcLen) (dstLen - srcLen) copyRows (to `plusPtr` (-dstLen)) (from `plusPtr` srcLen) (rows - 1) srcLen dstLen zeroBytes ptr 0 = return () zeroBytes ptr n = poke ptr (0 :: Word8) >> zeroBytes (ptr `plusPtr` 1) (n - 1) zeroRows ptr len 0 = return () zeroRows ptr len n = do zeroBytes ptr len zeroRows (ptr `plusPtr` (-len)) len (n - 1)