module Graphics.DynamicGraph.TextureLine (
textureLineWindow,
renderTextureLine,
setupGLFW
) where
import Control.Monad
import Graphics.UI.GLFW as G
import Graphics.Rendering.OpenGL
import Graphics.GLUtil
import Control.Monad.Trans.Class
import Control.Monad.Trans.Either
import Foreign.Storable
import Foreign.Marshal.Array
import Control.Concurrent
import Control.Concurrent.MVar
import Data.IORef
import Pipes
import Graphics.DynamicGraph.RenderCairo
import Graphics.DynamicGraph.Axis
import Graphics.DynamicGraph.Util
import Paths_dynamic_graph
textureLineWindow :: forall a. (IsPixelData a) => Int -> Int -> Int -> Int -> EitherT String IO (Consumer a IO ())
textureLineWindow width height samples xResolution = do
mv :: MVar a <- lift $ newEmptyMVar
completion <- lift $ newEmptyMVar
closed <- lift $ newIORef False
lift $ forkOS $ void $ do
res <- runEitherT $ do
res' <- lift $ createWindow width height "" Nothing Nothing
win <- maybe (left "error creating window") return res'
lift $ setWindowSizeCallback win $ Just $ \win x y -> do
viewport $= (Position 0 0, Size (fromIntegral x) (fromIntegral y))
lift $ setWindowCloseCallback win $ Just $ \win -> writeIORef closed True
lift $ makeContextCurrent (Just win)
mtu <- lift $ get maxVertexTextureImageUnits
when (mtu <= 0) $ left "No texture units accessible from vertex shader"
lift $ clearColor $= Color4 0 0 0 0
(renderFunc :: a -> IO ()) <- lift $ renderTextureLine samples xResolution
return $ forever $ do
pollEvents
dat <- takeMVar mv
makeContextCurrent (Just win)
clear [ColorBuffer]
renderFunc dat
swapBuffers win
case res of
Left err -> replaceMVar completion $ left err
Right renderLoop -> do
replaceMVar completion $ right ()
renderLoop
join $ lift $ takeMVar completion
return $
let pipe = do
c <- lift $ readIORef closed
when (not c) $ do
x <- await
lift $ replaceMVar mv x
pipe
in pipe
renderTextureLine :: IsPixelData a => Int -> Int -> IO (a -> IO())
renderTextureLine samples xResolution = do
vertFN <- getDataFileName "shaders/texture_line.vert"
fragFN <- getDataFileName "shaders/texture_line.frag"
vs <- loadShader VertexShader vertFN
fs <- loadShader FragmentShader fragFN
p <- linkShaderProgram [vs, fs]
currentProgram $= Just p
ab <- genObjectName
loc <- get $ attribLocation p "coord"
let stride = fromIntegral $ sizeOf (undefined::GLfloat)
vad = VertexArrayDescriptor 1 Float stride offset0
bindBuffer ArrayBuffer $= Just ab
vertexAttribArray loc $= Enabled
vertexAttribPointer loc $= (ToFloat, vad)
let xCoords :: [GLfloat]
xCoords = take xResolution $ iterate (+ 2 / fromIntegral xResolution) (1)
withArray xCoords $ \ptr ->
bufferData ArrayBuffer $= (fromIntegral $ sizeOf(undefined::GLfloat) * xResolution, ptr, StaticDraw)
let yCoords :: [GLfloat]
yCoords = take samples $ repeat 0
activeTexture $= TextureUnit 0
texture Texture2D $= Enabled
to <- loadTexture (TexInfo (fromIntegral samples) 1 TexMono yCoords)
locc <- get $ uniformLocation p "texture"
asUniform (0 :: GLint) locc
textureFilter Texture2D $= ((Linear', Nothing), Linear')
textureWrapMode Texture2D S $= (Repeated, ClampToEdge)
textureWrapMode Texture2D T $= (Repeated, ClampToEdge)
return $ \vbd -> do
currentProgram $= Just p
bindBuffer ArrayBuffer $= Just ab
vertexAttribPointer loc $= (ToFloat, vad)
textureBinding Texture2D $= Just to
reloadTexture to (TexInfo (fromIntegral samples) 1 TexMono vbd)
drawArrays LineStrip 0 (fromIntegral xResolution)