dynamic-graph 0.1.0.1 → 0.1.0.2
raw patch · 15 files changed
+626/−214 lines, 15 filesdep +bytestringdep +cairodep +colour
Dependencies added: bytestring, cairo, colour, deepseq, pango
Files
- Graphics/DynamicGraph/Axis.hs +103/−0
- Graphics/DynamicGraph/FillLine.hs +153/−0
- Graphics/DynamicGraph/RenderCairo.hs +90/−0
- Graphics/DynamicGraph/SimpleLine.hs +0/−66
- Graphics/DynamicGraph/TextureLine.hs +93/−57
- Graphics/DynamicGraph/Util.hs +11/−1
- Graphics/DynamicGraph/Waterfall.hs +124/−72
- dynamic-graph.cabal +4/−4
- shaders/cairo.frag +9/−0
- shaders/cairo.vert +10/−0
- shaders/fill_line.frag +19/−0
- shaders/fill_line.vert +9/−0
- shaders/simple_line.frag +0/−6
- shaders/simple_line.vert +0/−7
- shaders/texture_line.vert +1/−1
+ Graphics/DynamicGraph/Axis.hs view
@@ -0,0 +1,103 @@+{-| Various utilities for drawing axes with Cairo that will be later+ rendered using @Graphics.DynamicGraph.RenderCairo@+-}++{-# LANGUAGE RecordWildCards #-}++module Graphics.DynamicGraph.Axis where++import Control.Monad+import Data.Colour.RGBSpace+import Data.Colour.SRGB+import Data.Colour.Names+import Graphics.Rendering.Cairo+import Graphics.Rendering.Pango++-- Make a pango layout, fill it with text and return its extents+makeLayout :: PangoContext -> String -> Render (PangoLayout, PangoRectangle)+makeLayout ctx text = liftIO $ do+ layout <- layoutEmpty ctx+ layoutSetMarkup layout text+ (_, rect) <- layoutGetExtents layout+ return (layout, rect)++layoutTopCentre :: PangoContext -> String -> Double -> Double -> Render ()+layoutTopCentre ctx text x y = do+ (layout, PangoRectangle _ _ w _) <- makeLayout ctx text+ moveTo (x - w/2) y+ showLayout layout++layoutRightCentre :: PangoContext -> String -> Double -> Double -> Render ()+layoutRightCentre ctx text x y = do+ (layout, PangoRectangle _ _ w h) <- makeLayout ctx text+ moveTo (x - w) (y - h/2)+ showLayout layout++blankCanvas :: Colour Double -> Double -> Double -> Render ()+blankCanvas colour width height = do+ uncurryRGB setSourceRGB (toSRGB colour)+ rectangle 0 0 width height+ fill++blankCanvasAlpha :: Colour Double -> Double -> Double -> Double -> Render ()+blankCanvasAlpha colour alpha width height = do+ uncurryRGB (\x y z -> setSourceRGBA x y z alpha) (toSRGB colour)+ rectangle 0 0 width height+ fill++drawAxes :: Double -> Double -> Double -> Double -> Double -> Double -> Colour Double -> Double -> Render ()+drawAxes width height topMargin bottomMargin leftMargin rightMargin axisColor axisWidth = do+ setDash [] 0+ setLineCap LineCapRound+ setLineJoin LineJoinRound+ setLineWidth axisWidth+ uncurryRGB setSourceRGB (toSRGB axisColor)++ --Y axis+ moveTo leftMargin topMargin+ lineTo leftMargin (height - bottomMargin)+ stroke++ --X axis+ moveTo leftMargin (height - bottomMargin)+ lineTo (width - rightMargin) (height - bottomMargin)+ stroke++gridXCoords :: Double -> Double -> Double -> Double -> Double -> [Double]+gridXCoords width offset leftMargin rightMargin spacing = takeWhile (< (width - rightMargin)) $ iterate (+ spacing) (offset + leftMargin)++gridYCoords :: Double -> Double -> Double -> Double -> Double -> [Double]+gridYCoords height offset topMargin bottomMargin spacing = takeWhile (> topMargin) $ iterate (flip (-) spacing) (height - bottomMargin - offset)++xAxisLabels :: PangoContext -> Colour Double -> [String] -> [Double] -> Double -> Render ()+xAxisLabels ctx textColor gridLabels gridXCoords yCoord = do+ uncurryRGB setSourceRGB (toSRGB textColor)+ forM_ (zip gridLabels gridXCoords) $ \(label, xCoord) -> do+ layoutTopCentre ctx label xCoord yCoord++yAxisLabels :: PangoContext -> Colour Double -> [String] -> [Double] -> Double -> Render ()+yAxisLabels ctx textColor gridLabels gridYCoords xCoord = do+ uncurryRGB setSourceRGB (toSRGB textColor)+ forM_ (zip gridLabels gridYCoords) $ \(label, yCoord) -> do+ layoutRightCentre ctx label xCoord yCoord++xAxisGrid :: Colour Double -> Double -> [Double] -> Double -> Double -> [Double] -> Render ()+xAxisGrid gridColor gridWidth gridDash yStart yEnd gridXCoords = do+ uncurryRGB setSourceRGB (toSRGB gridColor)+ setLineWidth gridWidth+ setDash gridDash 0+ forM_ gridXCoords $ \xCoord -> do+ moveTo xCoord yStart+ lineTo xCoord yEnd+ stroke++yAxisGrid :: Colour Double -> Double -> [Double] -> Double -> Double -> [Double] -> Render ()+yAxisGrid gridColor gridWidth gridDash xStart xEnd gridYCoords = do+ uncurryRGB setSourceRGB (toSRGB gridColor)+ setLineWidth gridWidth+ setDash gridDash 0+ forM_ gridYCoords $ \yCoord -> do+ moveTo xStart yCoord+ lineTo xEnd yCoord+ stroke+
+ Graphics/DynamicGraph/FillLine.hs view
@@ -0,0 +1,153 @@+{-# LANGUAGE ScopedTypeVariables #-}++{-| Draw and update filled in line graphs with OpenGL.+-}++module Graphics.DynamicGraph.FillLine (+ filledLineWindow,+ renderFilledLine+ ) 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 Pipes++import Graphics.DynamicGraph.Util++import Paths_dynamic_graph++{-| @(filledLineWindow windowWidth windowHeight samples colorMap)@ creates+ a window of width @windowWidth@ and height @windowHeight@ for+ displaying a line graph. + + A function is returned for dynamically updating the line graph. It+ takes an instance of IsPixelData of length @samples@ as the y values. + + The fill is drawn with a vertical gradient defined by @colorMap@.+-}+filledLineWindow :: IsPixelData a => Int -> Int -> Int -> [GLfloat] -> EitherT String IO (a -> IO ())+filledLineWindow width height samples colorMap = do+ mv :: MVar a <- lift $ newEmptyMVar+ completion <- lift $ newEmptyMVar++ lift $ forkOS $ void $ do+ res <- runEitherT $ do+ res' <- lift $ createWindow width height "" Nothing Nothing+ win <- maybe (left "error creating window") return res'++ lift $ makeContextCurrent (Just win)+ lift $ clearColor $= Color4 0 0 0 0++ renderFunc <- lift $ renderFilledLine samples colorMap++ return $ forever $ do+ 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 $ replaceMVar mv ++{-| @(renderFilledLine samples colorMap)@ returns a function that+ renders a filled in line graph into the current OpenGL context. The+ function takes an instance of IsPixelData of length @samples@.++ The fill is drawn with a vertical gradient defined by @colorMap@.++ All OpenGL based initialization of the rendering function (loading of+ shaders, etc) is performed before the function is returned.+-}+renderFilledLine :: IsPixelData a => Int -> [GLfloat] -> IO (a -> IO ())+renderFilledLine samples colorMap = do+ --Load the shaders+ vertFN <- getDataFileName "shaders/fill_line.vert"+ fragFN <- getDataFileName "shaders/fill_line.frag"+ vs <- loadShader VertexShader vertFN+ fs <- loadShader FragmentShader fragFN+ p <- linkShaderProgram [vs, fs]++ --Set stuff+ currentProgram $= Just p++ ab <- genObjectName + locc <- get $ attribLocation p "coord"++ --The quad that covers the whole screen+ let stride = fromIntegral $ sizeOf (undefined::GLfloat) * 2+ vad = VertexArrayDescriptor 2 Float stride offset0++ bindBuffer ArrayBuffer $= Just ab+ vertexAttribArray locc $= Enabled+ vertexAttribPointer locc $= (ToFloat, vad)++ let xCoords :: [GLfloat]+ xCoords = [-1, -1, 1, -1, 1, 1, -1, 1]+ withArray xCoords $ \ptr -> + bufferData ArrayBuffer $= (fromIntegral $ sizeOf(undefined::GLfloat) * 8, ptr, StaticDraw)++ --The y coordinates+ let yCoords :: [GLfloat]+ yCoords = take samples $ repeat 0++ activeTexture $= TextureUnit 0+ texture Texture2D $= Enabled+ to <- loadTexture (TexInfo (fromIntegral samples) 1 TexMono yCoords)++ loc <- get $ uniformLocation p "texture"+ asUniform (0 :: GLint) loc + + textureFilter Texture2D $= ((Linear', Nothing), Linear')+ textureWrapMode Texture2D S $= (Repeated, ClampToEdge)+ textureWrapMode Texture2D T $= (Repeated, Repeat)++ --The color map+ activeTexture $= TextureUnit 1+ texture Texture2D $= Enabled+ loadTexture (TexInfo (fromIntegral $ length colorMap `quot` 3) 1 TexRGB colorMap)+ textureFilter Texture2D $= ((Linear', Nothing), Linear')+ textureWrapMode Texture2D S $= (Repeated, ClampToEdge)+ textureWrapMode Texture2D T $= (Repeated, ClampToEdge)++ loc <- get $ uniformLocation p "colorMap"+ asUniform (1 :: GLint) loc ++ let lcm :: GLfloat+ lcm = fromIntegral $ length colorMap `quot` 3+ loc <- get $ uniformLocation p "scale"+ asUniform ((lcm - 1) / lcm) loc ++ loc <- get $ uniformLocation p "offset"+ asUniform (0.5 / lcm) loc + + --No idea why this is needed+ activeTexture $= TextureUnit 0++ return $ \vbd -> do+ currentProgram $= Just p+ reloadTexture to (TexInfo (fromIntegral samples) 1 TexMono vbd)++ bindBuffer ArrayBuffer $= Just ab+ vertexAttribArray locc $= Enabled+ vertexAttribPointer locc $= (ToFloat, vad)++ drawArrays Quads 0 4+
+ Graphics/DynamicGraph/RenderCairo.hs view
@@ -0,0 +1,90 @@+{-| Render Cairo drawings with OpenGL. Useful for drawing axes.+-}++module Graphics.DynamicGraph.RenderCairo (+ renderCairo+ ) 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 Data.Colour.RGBSpace+import Data.Colour.SRGB+import Data.Colour.Names+import Graphics.Rendering.Cairo hiding (height, width)+import Graphics.Rendering.Pango++import qualified Data.ByteString as BS+import Data.ByteString (ByteString)++import Paths_dynamic_graph++{-| @(renderCairo rm width height)@ returns a function that+ renders the cairo drawing @rm@ into the current OpenGL context. The+ drawing is rendered with x resolution @width@ and y resolution+ @height@.++ All OpenGL based initialization of the rendering function (loading of+ shaders, rendering the cairo drawing to a texture, etc) is performed+ before the function is returned.+-}+renderCairo :: Render a -> Int -> Int -> IO (IO ())+renderCairo rm width height = do++ --Render the graph to a ByteString+ dat <- withImageSurface FormatARGB32 width height $ \surface -> do+ renderWith surface rm + imageSurfaceGetData surface++ --Load the shaders+ vertFN <- getDataFileName "shaders/cairo.vert"+ fragFN <- getDataFileName "shaders/cairo.frag"+ vs <- loadShader VertexShader vertFN+ fs <- loadShader FragmentShader fragFN+ p <- linkShaderProgram [vs, fs]++ --Set stuff+ currentProgram $= Just p+ ab <- genObjectName ++ locc <- get $ attribLocation p "coord"++ let stride = fromIntegral $ sizeOf (undefined::GLfloat) * 2+ vad = VertexArrayDescriptor 2 Float stride offset0++ bindBuffer ArrayBuffer $= Just ab+ vertexAttribArray locc $= Enabled+ vertexAttribPointer locc $= (ToFloat, vad)++ let xCoords :: [GLfloat]+ xCoords = [-1, -1, 1, -1, 1, 1, -1, 1]+ withArray xCoords $ \ptr -> + bufferData ArrayBuffer $= (fromIntegral $ sizeOf(undefined::GLfloat) * 8, ptr, StaticDraw)++ activeTexture $= TextureUnit 0+ texture Texture2D $= Enabled+ to <- genObjectName + textureBinding Texture2D $= Just to+ withPixels dat $ texImage2D Texture2D NoProxy 0 RGBA8 (TextureSize2D (fromIntegral width) (fromIntegral height)) 0 . PixelData BGRA UnsignedInt8888Rev+ + loc <- get $ uniformLocation p "texture"+ asUniform (0 :: GLint) loc ++ textureFilter Texture2D $= ((Linear', Nothing), Linear')+ textureWrapMode Texture2D S $= (Repeated, ClampToEdge)+ textureWrapMode Texture2D T $= (Repeated, Repeat)++ return $ do+ currentProgram $= Just p+ bindBuffer ArrayBuffer $= Just ab+ vertexAttribPointer locc $= (ToFloat, vad)+ textureBinding Texture2D $= Just to+ drawArrays Quads 0 4+
− Graphics/DynamicGraph/SimpleLine.hs
@@ -1,66 +0,0 @@-{-| Draw and update line graphs with OpenGL.-- Based on: <https://en.wikibooks.org/wiki/OpenGL_Programming/Scientific_OpenGL_Tutorial_01>-- You probably want to use "Graphics.DynamicGraph.TextureLine" as it is better.--}-module Graphics.DynamicGraph.SimpleLine (- graph- ) 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.Ptr--import Paths_dynamic_graph--{-| @(graph windowWidth windowHeight bufLen)@ creates a window- of width @windowWidth@ and height @windowHeight@ for displaying a line- graph. A function is returned for updating the line graph. It takes- a pointer to a c array of length @bufLen@ consisting of pairs of \<x,- y\> coordinates for updating the graph as this is the format that- OpenGL requires.--}-graph :: Int -> Int -> Int -> EitherT String IO (Ptr GLfloat -> IO ())-graph width height bufLen = do- res' <- lift $ createWindow width height "" Nothing Nothing- win <- maybe (left "error creating window") return res'-- lift $ do- makeContextCurrent (Just win)-- --Load the shaders- vertFN <- getDataFileName "shaders/simple_line.vert"- fragFN <- getDataFileName "shaders/simple_line.frag"- vs <- loadShader VertexShader vertFN- fs <- loadShader FragmentShader fragFN- p <- linkShaderProgram [vs, fs]-- --Set stuff- clearColor $= Color4 1 1 1 1- currentProgram $= Just p-- ab <- genObjectName-- loc <- get $ attribLocation p "coord"-- let stride = fromIntegral $ sizeOf (undefined::GLfloat) * 2- vad = VertexArrayDescriptor 2 Float stride offset0-- bindBuffer ArrayBuffer $= Just ab- vertexAttribArray loc $= Enabled- vertexAttribPointer loc $= (ToFloat, vad)-- return $ \ptr -> do- makeContextCurrent (Just win)- clear [ColorBuffer]- bufferData ArrayBuffer $= (fromIntegral $ 2 * bufLen * sizeOf (undefined :: GLfloat), ptr, StaticDraw)- drawArrays LineStrip 0 (fromIntegral bufLen)- swapBuffers win-
Graphics/DynamicGraph/TextureLine.hs view
@@ -1,10 +1,13 @@+{-# LANGUAGE ScopedTypeVariables #-}+ {-| Draw and update line graphs with OpenGL. Based on: <https://en.wikibooks.org/wiki/OpenGL_Programming/Scientific_OpenGL_Tutorial_02> -}+ module Graphics.DynamicGraph.TextureLine (- graph,- graphAsConsumer+ textureLineWindow,+ renderTextureLine ) where import Control.Monad@@ -16,82 +19,115 @@ import Control.Monad.Trans.Either import Foreign.Storable import Foreign.Marshal.Array+import Control.Concurrent+import Control.Concurrent.MVar import Pipes +import Graphics.DynamicGraph.RenderCairo+import Graphics.DynamicGraph.Axis+import Graphics.DynamicGraph.Util+ import Paths_dynamic_graph -{-| @(graph windowWidth windowHeight samples xResolution)@ creates a window- of width @windowWidth@ and height @windowHeight@ for displaying a line- graph. A function is returned for updating the line graph. It takes an- instance of IsPixelData of length @samples@ as the y values and draws- a line graph with @xResolution@ vertices. +{-| @(textureLineWindow windowWidth windowHeight samples xResolution)@+ creates a window of width @windowWidth@ and height @windowHeight@ for+ displaying a line graph. + + A function is returned for dynamically updating the line graph. It+ takes an instance of IsPixelData of length @samples@ as the y values+ and draws a line graph with @xResolution@ vertices. -}-graph :: IsPixelData a => Int -> Int -> Int -> Int -> EitherT String IO (a -> IO ())-graph width height samples xResolution = do- res' <- lift $ createWindow width height "" Nothing Nothing- win <- maybe (left "error creating window") return res'+textureLineWindow :: forall a. (IsPixelData a) => Int -> Int -> Int -> Int -> EitherT String IO (a -> IO ())+textureLineWindow width height samples xResolution = do+ mv :: MVar a <- lift $ newEmptyMVar+ completion <- lift $ newEmptyMVar - lift $ makeContextCurrent (Just win)- mtu <- lift $ get maxVertexTextureImageUnits- when (mtu <= 0) $ left "No texture units accessible from vertex shader"+ lift $ forkOS $ void $ do+ --All the OpenGL stuff has to be in the same thread+ res <- runEitherT $ do+ res' <- lift $ createWindow width height "" Nothing Nothing+ win <- maybe (left "error creating window") return res' - lift $ do- --Load the shaders- vertFN <- getDataFileName "shaders/texture_line.vert"- fragFN <- getDataFileName "shaders/texture_line.frag"- vs <- loadShader VertexShader vertFN- fs <- loadShader FragmentShader fragFN- p <- linkShaderProgram [vs, fs]+ 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 - --Set stuff- clearColor $= Color4 1 1 1 1- currentProgram $= Just p+ (renderFunc :: a -> IO ()) <- lift $ renderTextureLine samples xResolution - ab <- genObjectName + return $ forever $ do+ dat <- takeMVar mv+ makeContextCurrent (Just win)+ clear [ColorBuffer]+ renderFunc dat+ swapBuffers win - loc <- get $ attribLocation p "coord"+ case res of+ Left err -> replaceMVar completion $ left err+ Right renderLoop -> do+ replaceMVar completion $ right ()+ renderLoop - let stride = fromIntegral $ sizeOf (undefined::GLfloat) - vad = VertexArrayDescriptor 1 Float stride offset0+ join $ lift $ takeMVar completion - bindBuffer ArrayBuffer $= Just ab- vertexAttribArray loc $= Enabled- vertexAttribPointer loc $= (ToFloat, vad)+ return $ replaceMVar mv - let xCoords :: [GLfloat]- xCoords = take xResolution $ iterate (+ 2 / fromIntegral xResolution) (-1)- withArray xCoords $ \ptr -> - bufferData ArrayBuffer $= (fromIntegral $ sizeOf(undefined::GLfloat) * xResolution, ptr, StaticDraw)+{-| @(renderTextureLine samples xResolution)@ returns a function that+ renders a line graph into the current OpenGL context. The function+ takes an instance of IsPixelData of length @samples@ and draws a line+ graph with @xResolution@ vertices. - let yCoords :: [GLfloat]- yCoords = take samples $ repeat 0+ All OpenGL based initialization of the rendering function (loading of+ shaders, etc) is performed before the function is returned.+-}+renderTextureLine :: IsPixelData a => Int -> Int -> IO (a -> IO())+renderTextureLine samples xResolution = do+ --Load the shaders+ vertFN <- getDataFileName "shaders/texture_line.vert"+ fragFN <- getDataFileName "shaders/texture_line.frag"+ vs <- loadShader VertexShader vertFN+ fs <- loadShader FragmentShader fragFN+ p <- linkShaderProgram [vs, fs] - --texture Texture2D $= Enabled- to <- loadTexture (TexInfo (fromIntegral samples) 1 TexMono yCoords)- - --activeTexture $= TextureUnit 0- --loc <- get $ uniformLocation p "texture"- --asUniform (0 :: GLint) loc + --Set stuff+ currentProgram $= Just p - textureFilter Texture2D $= ((Linear', Nothing), Linear')+ ab <- genObjectName - textureWrapMode Texture2D S $= (Repeated, ClampToEdge)- textureWrapMode Texture2D T $= (Repeated, ClampToEdge)+ loc <- get $ attribLocation p "coord" - return $ \vbd -> do- makeContextCurrent (Just win)- clear [ColorBuffer]+ let stride = fromIntegral $ sizeOf (undefined::GLfloat) + vad = VertexArrayDescriptor 1 Float stride offset0 - reloadTexture to (TexInfo (fromIntegral samples) 1 TexMono vbd)+ bindBuffer ArrayBuffer $= Just ab+ vertexAttribArray loc $= Enabled+ vertexAttribPointer loc $= (ToFloat, vad) - drawArrays LineStrip 0 (fromIntegral xResolution)- swapBuffers win+ let xCoords :: [GLfloat]+ xCoords = take xResolution $ iterate (+ 2 / fromIntegral xResolution) (-1)+ withArray xCoords $ \ptr -> + bufferData ArrayBuffer $= (fromIntegral $ sizeOf(undefined::GLfloat) * xResolution, ptr, StaticDraw) -toConsumer :: Monad m => (a -> m b) -> Consumer a m ()-toConsumer func = forever $ await >>= lift . func+ let yCoords :: [GLfloat]+ yCoords = take samples $ repeat 0 --- | Same as above, but returns a Consumer instead of an update function-graphAsConsumer :: IsPixelData a => Int -> Int -> Int -> Int -> EitherT String IO (Consumer a IO ())-graphAsConsumer width height samples xResolution = liftM toConsumer $ graph width height samples xResolution+ 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)
Graphics/DynamicGraph/Util.hs view
@@ -1,10 +1,13 @@ module Graphics.DynamicGraph.Util (- setupGLFW+ setupGLFW,+ replaceMVar ) where import Control.Monad import Control.Monad.Trans.Class import Control.Monad.Trans.Either+import Control.Concurrent.MVar+import Control.DeepSeq import Graphics.UI.GLFW as G @@ -17,3 +20,10 @@ res <- lift $ G.init unless res (left "error initializing glfw")++-- | tryTakeMVar then putMVar+replaceMVar :: MVar a -> a -> IO ()+replaceMVar mv val = do+ tryTakeMVar mv+ putMVar mv val+
Graphics/DynamicGraph/Waterfall.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ScopedTypeVariables #-} {-| Draw and update waterfall plots with OpenGL. Useful for spectrograms. -} module Graphics.DynamicGraph.Waterfall (@@ -6,10 +7,13 @@ hot, bw, wb,- graph+ waterfallWindow,+ renderWaterfall ) where import Control.Monad+import Control.Concurrent hiding (yield)+import Control.Concurrent.MVar import Graphics.UI.GLFW as G import Graphics.Rendering.OpenGL import Graphics.GLUtil@@ -21,6 +25,8 @@ import Pipes +import Graphics.DynamicGraph.Util+ import Paths_dynamic_graph -- | The matlab / octave \"jet\" color map@@ -43,100 +49,146 @@ wb :: [GLfloat] wb = [1, 1, 1, 0, 0, 0] -{-| @(graph windowWidth windowHeight width height colormap)@ creates- a window of width @windowWidth@ and height @windowHeight@ for displaying- a waterfall plot. A Consumer is returned for updating the waterfall- plot. Feeding an instance of IsPixelData of length @width@ shifts all- rows of the waterfall down and updates the top row with the data. The- waterfall is @height@ rows high. @colorMap@ is used to map values to- display color.+{-| @(waterfallWindow windowWidth windowHeight width height colormap)@+ creates a window of width @windowWidth@ and height @windowHeight@ for+ displaying a waterfall plot. + + A Consumer is returned for updating the waterfall plot. Feeding an+ instance of IsPixelData of length @width@ shifts all rows of the+ waterfall down and updates the top row with the data. + + The waterfall is @height@ rows of data high. @colorMap@ is used to map+ values to display color. -}-graph :: IsPixelData a => Int -> Int -> Int -> Int -> [GLfloat] -> EitherT String IO (Consumer a IO ())-graph windowWidth windowHeight width height colorMap = do- res' <- lift $ createWindow windowWidth windowHeight "" Nothing Nothing- win <- maybe (left "error creating window") return res'+waterfallWindow :: IsPixelData a => Int -> Int -> Int -> Int -> [GLfloat] -> EitherT String IO (a -> IO ())+waterfallWindow windowWidth windowHeight width height colorMap = do+ mv :: MVar a <- lift $ newEmptyMVar+ completion <- lift $ newEmptyMVar - lift $ do- makeContextCurrent (Just win)+ lift $ forkOS $ void $ do+ res <- runEitherT $ do+ res' <- lift $ createWindow windowWidth windowHeight "" Nothing Nothing+ win <- maybe (left "error creating window") return res'+ lift $ makeContextCurrent (Just win)+ renderPipe <- lift $ renderWaterfall width height colorMap+ let thePipe = (<-<) renderPipe $ forever $ do + dat <- lift $ takeMVar mv+ lift $ makeContextCurrent (Just win)+ yield dat+ lift $ swapBuffers win+ return $ runEffect thePipe - --Load the shaders- vertFN <- getDataFileName "shaders/waterfall.vert"- fragFN <- getDataFileName "shaders/waterfall.frag"- vs <- loadShader VertexShader vertFN- fs <- loadShader FragmentShader fragFN- p <- linkShaderProgram [vs, fs]+ case res of+ Left err -> replaceMVar completion $ left err+ Right renderLoop -> do+ replaceMVar completion $ right ()+ renderLoop - --Set stuff- currentProgram $= Just p+ join $ lift $ takeMVar completion - ab <- genObjectName + return $ \x -> replaceMVar mv x - loc <- get $ attribLocation p "coord"+{-| @(renderWaterfallLine width height colorMap)@ returns a Consumer that+ renders a waterfall plot into the current OpenGL context. The Consumer+ takes data that is an instance of IsPixelData and of length @width@.+ The waterfall is @height@ rows of data high. - let stride = fromIntegral $ sizeOf (undefined::GLfloat) * 2- vad = VertexArrayDescriptor 2 Float stride offset0+ The fill is drawn with a vertical gradient defined by @colorMap@. - bindBuffer ArrayBuffer $= Just ab- vertexAttribArray loc $= Enabled- vertexAttribPointer loc $= (ToFloat, vad)+ All OpenGL based initialization of the rendering function (loading of+ shaders, etc) is performed before the pipe is returned.+-}+renderWaterfall :: IsPixelData a => Int -> Int -> [GLfloat] -> IO (Consumer a IO ())+renderWaterfall width height colorMap = do+ --Load the shaders+ vertFN <- getDataFileName "shaders/waterfall.vert"+ fragFN <- getDataFileName "shaders/waterfall.frag"+ vs <- loadShader VertexShader vertFN+ fs <- loadShader FragmentShader fragFN+ p <- linkShaderProgram [vs, fs] - let xCoords :: [GLfloat]- xCoords = [-1, -1, 1, -1, 1, 1, -1, 1]- withArray xCoords $ \ptr -> - bufferData ArrayBuffer $= (fromIntegral $ sizeOf(undefined::GLfloat) * 8, ptr, StaticDraw)+ --Set stuff+ currentProgram $= Just p - let yCoords :: [GLfloat]- yCoords = take (width * height) $ repeat 0+ ab <- genObjectName - activeTexture $= TextureUnit 0- texture Texture2D $= Enabled- to <- loadTexture (TexInfo (fromIntegral width) (fromIntegral height) TexMono yCoords)- - loc <- get $ uniformLocation p "texture"- asUniform (0 :: GLint) loc + locc <- get $ attribLocation p "coord" - textureFilter Texture2D $= ((Linear', Nothing), Linear')- textureWrapMode Texture2D S $= (Repeated, ClampToEdge)- textureWrapMode Texture2D T $= (Repeated, Repeat)+ let stride = fromIntegral $ sizeOf (undefined::GLfloat) * 2+ vad = VertexArrayDescriptor 2 Float stride offset0 - activeTexture $= TextureUnit 1- texture Texture2D $= Enabled- to <- loadTexture (TexInfo (fromIntegral $ length colorMap `quot` 3) 1 TexRGB colorMap)- textureFilter Texture2D $= ((Linear', Nothing), Linear')- textureWrapMode Texture2D S $= (Repeated, ClampToEdge)- textureWrapMode Texture2D T $= (Repeated, ClampToEdge)+ bindBuffer ArrayBuffer $= Just ab+ vertexAttribArray locc $= Enabled+ vertexAttribPointer locc $= (ToFloat, vad) - loc <- get $ uniformLocation p "colorMap"- asUniform (1 :: GLint) loc + let xCoords :: [GLfloat]+ xCoords = [-1, -1, 1, -1, 1, 1, -1, 1]+ withArray xCoords $ \ptr -> + bufferData ArrayBuffer $= (fromIntegral $ sizeOf(undefined::GLfloat) * 8, ptr, StaticDraw) - let lcm :: GLfloat- lcm = fromIntegral $ length colorMap `quot` 3- loc <- get $ uniformLocation p "scale"- asUniform ((lcm - 1) / lcm) loc + let yCoords :: [GLfloat]+ yCoords = take (width * height) $ repeat 0 - loc <- get $ uniformLocation p "offset"- asUniform (0.5 / lcm) loc + activeTexture $= TextureUnit 0+ texture Texture2D $= Enabled+ to0 <- loadTexture (TexInfo (fromIntegral width) (fromIntegral height) TexMono yCoords)+ + loc <- get $ uniformLocation p "texture"+ asUniform (0 :: GLint) loc - --No idea why this is needed- activeTexture $= TextureUnit 0+ textureFilter Texture2D $= ((Linear', Nothing), Linear')+ textureWrapMode Texture2D S $= (Repeated, ClampToEdge)+ textureWrapMode Texture2D T $= (Repeated, Repeat) - loc <- get $ uniformLocation p "voffset"+ activeTexture $= TextureUnit 1+ texture Texture2D $= Enabled+ to1 <- loadTexture (TexInfo (fromIntegral $ length colorMap `quot` 3) 1 TexRGB colorMap)+ textureFilter Texture2D $= ((Linear', Nothing), Linear')+ textureWrapMode Texture2D S $= (Repeated, ClampToEdge)+ textureWrapMode Texture2D T $= (Repeated, ClampToEdge) - let pipe yoffset = do- dat <- await+ loc <- get $ uniformLocation p "colorMap"+ asUniform (1 :: GLint) loc - lift $ do- makeContextCurrent (Just win)+ let lcm :: GLfloat+ lcm = fromIntegral $ length colorMap `quot` 3+ loc <- get $ uniformLocation p "scale"+ asUniform ((lcm - 1) / lcm) loc - let textureOffset = (yoffset + height - 1) `mod` height+ loc <- get $ uniformLocation p "offset"+ asUniform (0.5 / lcm) loc - withPixels dat $ \ptr -> texSubImage2D Texture2D 0 (TexturePosition2D 0 (fromIntegral textureOffset)) (TextureSize2D (fromIntegral width) 1) (PixelData Red Float ptr)+ loc <- get $ uniformLocation p "voffset" - asUniform (fromIntegral yoffset / fromIntegral height :: GLfloat) loc+ let pipe yoffset = do+ dat <- await - drawArrays Quads 0 4- swapBuffers win+ lift $ do+ currentProgram $= Just p - pipe $ if yoffset + 1 >= height then 0 else yoffset + 1+ let textureOffset = (yoffset + height - 1) `mod` height - return $ pipe 0+ withPixels dat $ \ptr -> + texSubImage2D Texture2D 0 (TexturePosition2D 0 (fromIntegral textureOffset)) (TextureSize2D (fromIntegral width) 1) (PixelData Red Float ptr)++ asUniform (fromIntegral yoffset / fromIntegral height :: GLfloat) loc++ bindBuffer ArrayBuffer $= Just ab+ vertexAttribArray locc $= Enabled+ vertexAttribPointer locc $= (ToFloat, vad)++ activeTexture $= TextureUnit 0+ textureBinding Texture2D $= Just to0++ activeTexture $= TextureUnit 1+ textureBinding Texture2D $= Just to1++ --No idea why this is needed+ activeTexture $= TextureUnit 0++ drawArrays Quads 0 4++ pipe $ if yoffset + 1 >= height then 0 else yoffset + 1++ return $ pipe 0+
dynamic-graph.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: dynamic-graph-version: 0.1.0.1+version: 0.1.0.2 synopsis: Draw and update graphs in real time with OpenGL description: Draw and update graphs in real time with OpenGL. Suitable for displaying large amounts of frequently changing data. At this time, line graphs and waterfall plots are supported. Axis drawing will be added in a future version. license: BSD3@@ -14,17 +14,17 @@ build-type: Simple -- extra-source-files: cabal-version: >=1.10-data-files: shaders/simple_line.vert, shaders/simple_line.frag, shaders/texture_line.vert, shaders/texture_line.frag, shaders/waterfall.vert, shaders/waterfall.frag+data-files: shaders/texture_line.vert, shaders/texture_line.frag, shaders/waterfall.vert, shaders/waterfall.frag, shaders/fill_line.vert, shaders/fill_line.frag, shaders/cairo.vert, shaders/cairo.frag source-repository head type: git location: https://github.com/adamwalker/dynamic-graph library- exposed-modules: Graphics.DynamicGraph.SimpleLine, Graphics.DynamicGraph.TextureLine, Graphics.DynamicGraph.Waterfall, Graphics.DynamicGraph.Util+ exposed-modules: Graphics.DynamicGraph.TextureLine, Graphics.DynamicGraph.Waterfall, Graphics.DynamicGraph.Util, Graphics.DynamicGraph.FillLine, Graphics.DynamicGraph.Axis, Graphics.DynamicGraph.RenderCairo -- other-modules: -- other-extensions: - build-depends: base >=4.6 && <4.8, GLFW-b >=1.4 && <1.5, OpenGL >=2.9 && <2.10, GLUtil >=0.7 && <0.8, transformers >=0.3 && <0.5, either >=4.1 && <4.4, pipes+ build-depends: base >=4.6 && <4.8, GLFW-b >=1.4 && <1.5, OpenGL >=2.9 && <2.10, GLUtil >=0.7 && <0.8, transformers >=0.3 && <0.5, either >=4.1 && <4.4, pipes, pango, cairo, colour, bytestring, deepseq -- hs-source-dirs: default-language: Haskell2010 other-modules: Paths_dynamic_graph
+ shaders/cairo.frag view
@@ -0,0 +1,9 @@+#version 110++uniform sampler2D texture;+varying vec2 f_coord;++void main() {+ gl_FragColor = texture2D(texture, f_coord);+}+
+ shaders/cairo.vert view
@@ -0,0 +1,10 @@+#version 110++attribute vec2 coord;+varying vec2 f_coord;++void main(){+ gl_Position = vec4(coord, 0, 1);+ vec2 f_coord_p = (coord + vec2(1.0, 1.0)) / 2.0;+ f_coord = vec2(f_coord_p.x, 1.0 - f_coord_p.y);+}
+ shaders/fill_line.frag view
@@ -0,0 +1,19 @@+#version 110++uniform sampler2D texture;+uniform sampler2D colorMap;+varying vec2 f_coord;++uniform float offset;+uniform float scale;++void main() {+ float graph_height = texture2D(texture, vec2(f_coord.x, 0)).r;++ if(f_coord.y < graph_height){+ gl_FragColor = texture2D(colorMap, vec2(f_coord.y * scale + offset, 0));+ } else {+ gl_FragColor = vec4(0, 0, 0, 0);+ }+}+
+ shaders/fill_line.vert view
@@ -0,0 +1,9 @@+#version 110++attribute vec2 coord;+varying vec2 f_coord;++void main(){+ gl_Position = vec4(coord, 0, 1);+ f_coord = (coord + vec2(1.0, 1.0)) / 2.0;+}
− shaders/simple_line.frag
@@ -1,6 +0,0 @@-#version 110--void main() {- gl_FragColor = vec4(0, 0, 1, 0);-}-
− shaders/simple_line.vert
@@ -1,7 +0,0 @@-#version 110--attribute vec2 coord;--void main(){- gl_Position = vec4(coord, 0, 1);-}
shaders/texture_line.vert view
@@ -4,6 +4,6 @@ uniform sampler2D texture; void main(){- float y = texture2D(texture, vec2((coord + 1.0)/2.0, 0)).r;+ float y = (texture2D(texture, vec2((coord + 1.0)/2.0, 0)).r - 0.5) * 2.0; gl_Position = vec4(coord, y, 0, 1); }