dynamic-graph 0.1.0.5 → 0.1.0.6

raw patch · 14 files changed

+369/−383 lines, 14 filesdep ~OpenGLdep ~bytestringdep ~cairoPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: OpenGL, bytestring, cairo, colour, deepseq, pango, pipes

API changes (from Hackage documentation)

Files

• Graphics/DynamicGraph/Axis.hs +84/−19
• Graphics/DynamicGraph/ColorMaps.hs +1/−0
• Graphics/DynamicGraph/FillLine.hs +11/−72
• Graphics/DynamicGraph/Line.hs +108/−0
• Graphics/DynamicGraph/RenderCairo.hs +10/−22
• Graphics/DynamicGraph/TextureLine.hs +0/−171
• Graphics/DynamicGraph/Util.hs +11/−2
• Graphics/DynamicGraph/Waterfall.hs +15/−74
• Graphics/DynamicGraph/Window.hs +104/−0
• dynamic-graph.cabal +10/−8
• shaders/line.frag +6/−0
• shaders/line.vert +9/−0
• shaders/texture_line.frag +0/−6
• shaders/texture_line.vert +0/−9

@@ -1,9 +1,6 @@-{-| Various utilities for drawing axes with Cairo that will be later-    rendered using @Graphics.DynamicGraph.RenderCairo@+{-| Various utilities for drawing axes with Cairo that will later be rendered using @Graphics.DynamicGraph.RenderCairo@ -} -{-# LANGUAGE RecordWildCards #-}- module Graphics.DynamicGraph.Axis (     blankCanvas,     blankCanvasAlpha,@@ -23,39 +20,69 @@ 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)+-- | Make a pango layout, fill it with text and return its extents+makeLayout :: PangoContext -- ^ Pango context+           -> String       -- ^ The text+           -> Render (PangoLayout, PangoRectangle) makeLayout ctx text = liftIO $ do     layout <- layoutEmpty ctx     layoutSetMarkup layout text :: IO String     (_, rect) <- layoutGetExtents layout     return (layout, rect) -layoutTopCentre :: PangoContext -> String -> Double -> Double -> Render ()+-- | Draw some text in the top center +layoutTopCentre :: PangoContext -- ^ Pango context+                -> String       -- ^ The text+                -> Double       -- ^ Width+                -> Double       -- ^ Height+                -> 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 ()+-- | Draw some text right side half way up+layoutRightCentre :: PangoContext -- ^ Pango context +                  -> String       -- ^ The text+                  -> Double       -- ^ Width+                  -> Double       -- ^ Height+                  -> 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 ()+-- | Create a blank cairo canvas of the specified size and colour+blankCanvas :: Colour Double -- ^ The colour+            -> Double        -- ^ Width+            -> Double        -- ^ Height+            -> Render () blankCanvas colour width height  = do     uncurryRGB setSourceRGB (toSRGB colour)     rectangle 0 0 width height     fill -blankCanvasAlpha :: Colour Double -> Double -> Double -> Double -> Render ()+-- | Create a blank cairo canvas of the specified size and colour+blankCanvasAlpha :: Colour Double -- ^ The colour+                 -> Double        -- ^ Transparency+                 -> Double        -- ^ Width+                 -> Double        -- ^ Height+                 -> 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 ()+-- | Draw a set of axes without any labels+drawAxes :: Double        -- ^ Width+         -> Double        -- ^ Height+         -> Double        -- ^ Top Margin+         -> Double        -- ^ Bottom Margin+         -> Double        -- ^ Left Margin+         -> Double        -- ^ Right Margin+         -> Colour Double -- ^ Axis colour+         -> Double        -- ^ Axis width+         -> Render () drawAxes width height topMargin bottomMargin leftMargin rightMargin axisColor axisWidth = do     setDash [] 0     setLineCap  LineCapRound@@ -73,25 +100,56 @@     lineTo (width - rightMargin) (height - bottomMargin)     stroke -gridXCoords :: Double -> Double -> Double -> Double -> Double -> [Double]+-- | Calculate the coordinates to draw the X axis grid at+gridXCoords :: Double -- ^ Width of graph+            -> Double -- ^ X offset to start at+            -> Double -- ^ Left margin+            -> Double -- ^ Right margin+            -> Double -- ^ Spacing between coordinates+            -> [Double] gridXCoords width offset leftMargin rightMargin spacing = takeWhile (<= (width - rightMargin)) $ iterate (+ spacing) (offset + leftMargin) -gridYCoords :: Double -> Double -> Double -> Double -> Double -> [Double]+-- | Calculate the coordinates to draw the Y axis grid at+gridYCoords :: Double -- ^ Height of graph+            -> Double -- ^ Y offset to start at+            -> Double -- ^ Top margin+            -> Double -- ^ Bottom margin+            -> Double -- ^ Spacing between coordinates+            -> [Double] gridYCoords height offset topMargin bottomMargin spacing = takeWhile (>= topMargin) $ iterate (flip (-) spacing) (height - bottomMargin - offset) -xAxisLabels :: PangoContext -> Colour Double -> [String] -> [Double] -> Double -> Render ()+-- | Draw X axis labels+xAxisLabels :: PangoContext  -- ^ Pango context+            -> Colour Double -- ^ Label colour+            -> [String]      -- ^ Grid labels+            -> [Double]      -- ^ X coordinates to draw labels at+            -> Double        -- ^ Y coordinate to draw labels at+            -> Render () xAxisLabels ctx textColor gridLabels gridXCoords yCoord = do     uncurryRGB setSourceRGB (toSRGB textColor)-    forM_ (zip gridLabels gridXCoords) $ \(label, xCoord) -> do+    forM_ (zip gridLabels gridXCoords) $ \(label, xCoord) ->          layoutTopCentre ctx label xCoord yCoord -yAxisLabels :: PangoContext -> Colour Double -> [String] -> [Double] -> Double -> Render ()+-- | Draw Y axis labels+yAxisLabels :: PangoContext  -- ^ Pango context+            -> Colour Double -- ^ Label colour+            -> [String]      -- ^ Grid label+            -> [Double]      -- ^ Y coordinates to draw labels at+            -> Double        -- ^ X coordinate to draw labels at+            -> Render () yAxisLabels ctx textColor gridLabels gridYCoords xCoord = do     uncurryRGB setSourceRGB (toSRGB textColor)-    forM_ (zip gridLabels gridYCoords) $ \(label, yCoord) -> do+    forM_ (zip gridLabels gridYCoords) $ \(label, yCoord) ->          layoutRightCentre ctx label xCoord yCoord -xAxisGrid :: Colour Double -> Double -> [Double] -> Double -> Double -> [Double] -> Render ()+-- | Draw X axis grid+xAxisGrid :: Colour Double -- ^ Grid colour+          -> Double        -- ^ Width of grid lines+          -> [Double]      -- ^ Grid line dashing+          -> Double        -- ^ Starting Y coordinate+          -> Double        -- ^ Ending Y coordinate+          -> [Double]      -- ^ Grid X coordinates+          -> Render () xAxisGrid gridColor gridWidth gridDash yStart yEnd gridXCoords = do     uncurryRGB setSourceRGB (toSRGB gridColor)     setLineWidth gridWidth@@ -101,7 +159,14 @@         lineTo xCoord yEnd         stroke -yAxisGrid :: Colour Double -> Double -> [Double] -> Double -> Double -> [Double] -> Render ()+-- | Draw Y axis grid+yAxisGrid :: Colour Double -- ^ Grid color+          -> Double        -- ^ Width of grid lines+          -> [Double]      -- ^ Grid line dashing+          -> Double        -- ^ Starting X coordinate+          -> Double        -- ^ Ending X coordinate+          -> [Double]      -- ^ Grid Y coordinates+          -> Render () yAxisGrid gridColor gridWidth gridDash xStart xEnd gridYCoords = do     uncurryRGB setSourceRGB (toSRGB gridColor)     setLineWidth gridWidth

@@ -1,3 +1,4 @@+{-| Various color maps. -} module Graphics.DynamicGraph.ColorMaps (     jet,     jet_mod,

@@ -13,6 +13,7 @@ > import Graphics.Rendering.OpenGL >  > import Graphics.DynamicGraph.FillLine+> import Graphics.DynamicGraph.Window >  > randomVect :: Producer [GLfloat] IO () > randomVect =  P.repeatM $ do@@ -22,101 +23,39 @@ >  > main = eitherT putStrLn return $ do >     setupGLFW->     lineGraph <- filledLineWindow 1024 480 1000 jet_mod+>     lineGraph  <- window 1024 480 $ fmap (for cat . (lift . )) $ renderFilledLine 1000 jet_mod >  >     lift $ runEffect $ randomVect >-> lineGraph+ -}  module Graphics.DynamicGraph.FillLine (-    filledLineWindow,     renderFilledLine,-    setupGLFW,     module Graphics.DynamicGraph.ColorMaps     ) 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.Util import Graphics.DynamicGraph.ColorMaps  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 (Consumer a IO ())-filledLineWindow width height samples colorMap = 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)-            lift $ clearColor $= Color4 0 0 0 0--            renderFunc <- lift $ renderFilledLine samples colorMap--            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--{-| @(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@.+{-| Returns a function that renders a filled in line graph into the current OpenGL context. -    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. -    All OpenGL based initialization of the rendering function (loading of-    shaders, etc) is performed before the function is returned.+    This function must be called with an OpenGL context currently set. -}-renderFilledLine :: IsPixelData a => Int -> [GLfloat] -> IO (a -> IO ())+renderFilledLine :: IsPixelData a +                 => Int             -- ^ The number of samples in each buffer passed to the rendering function.+                 -> [GLfloat]       -- ^ Color map for the vertical gradient of the fill.+                 -> IO (a -> IO ()) -- ^ The function that does the rendering. Takes an instance of `IsPixelData` containing the specified number of y values. renderFilledLine samples colorMap = do     --Load the shaders     vertFN <- getDataFileName "shaders/fill_line.vert"@@ -146,7 +85,7 @@      --The y coordinates     let yCoords :: [GLfloat]-        yCoords = take samples $ repeat 0+        yCoords = replicate samples 0      activeTexture $= TextureUnit 0     texture Texture2D $= Enabled

@@ -0,0 +1,108 @@+{-# LANGUAGE ScopedTypeVariables #-}++{-| Draw and update line graphs with OpenGL.++    Based on: <https://en.wikibooks.org/wiki/OpenGL_Programming/Scientific_OpenGL_Tutorial_02>++    Example usage:++> import Control.Monad+> import Control.Monad.Trans.Either+> import Control.Concurrent+> import Pipes+> import qualified Pipes.Prelude as P+> import System.Random+> import Graphics.Rendering.OpenGL+> +> import Graphics.DynamicGraph.Line+> import Graphics.DynamicGraph.Window+> +> randomVect :: Producer [GLfloat] IO ()+> randomVect =  P.repeatM $ do+>     res <- replicateM 1000 randomIO+>     threadDelay 10000+>     return res+> +> main = eitherT putStrLn return $ do+>     setupGLFW+>     lineGraph <- window 1024 480 $ fmap (for cat . (lift .)) $ renderLine 1000 1024+> +>     lift $ runEffect $ randomVect >-> lineGraph++-}++module Graphics.DynamicGraph.Line (+    renderLine,+    ) where++import Graphics.Rendering.OpenGL+import Graphics.GLUtil++import Foreign.Storable+import Foreign.Marshal.Array++import Pipes++import Graphics.DynamicGraph.RenderCairo++import Paths_dynamic_graph++{-| Returns a function that renders a line graph into the current OpenGL context. ++    All OpenGL based initialization of the rendering function (loading of shaders, etc) is performed before the function is returned.++    This function must be called with an OpenGL context currently set.+-}+renderLine :: IsPixelData a +           => Int            -- ^ The number of samples in each buffer passed to the rendering function.+           -> Int            -- ^ The number of vertices in the plotted graph.+           -> IO (a -> IO()) -- ^ The function that does the rendering. Takes an instance of `IsPixelData` containing the specified number of y values.+renderLine samples xResolution = do+    --Load the shaders+    vertFN <- getDataFileName "shaders/line.vert"+    fragFN <- getDataFileName "shaders/line.frag"+    vs <- loadShader VertexShader   vertFN+    fs <- loadShader FragmentShader fragFN+    p  <- linkShaderProgram [vs, fs]++    --Set stuff+    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 = replicate samples 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)+

@@ -5,37 +5,25 @@     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.OpenGL+import Graphics.GLUtil 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@.+{-| Returns a function that renders a cairo drawing into the current OpenGL context. -    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.+    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.++    This function must be called with an OpenGL context currently set. -}-renderCairo :: Render a -> Int -> Int -> IO (IO ())+renderCairo :: Render a   -- ^ Cairo render monad that does the drawing+            -> Int        -- ^ X resolution+            -> Int        -- ^ Y resolution+            -> IO (IO ()) renderCairo rm width height = do      --Render the graph to a ByteString

@@ -1,171 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--{-| Draw and update line graphs with OpenGL.--    Based on: <https://en.wikibooks.org/wiki/OpenGL_Programming/Scientific_OpenGL_Tutorial_02>--    Example usage:--> import Control.Monad-> import Control.Monad.Trans.Either-> import Control.Concurrent-> import Pipes-> import qualified Pipes.Prelude as P-> import System.Random-> import Graphics.Rendering.OpenGL-> -> import Graphics.DynamicGraph.TextureLine-> -> randomVect :: Producer [GLfloat] IO ()-> randomVect =  P.repeatM $ do->     res <- replicateM 1000 randomIO->     threadDelay 10000->     return res-> -> main = eitherT putStrLn return $ do->     setupGLFW->     lineGraph <- textureLineWindow 1024 480 1000 1024 -> ->     lift $ runEffect $ randomVect >-> lineGraph--}--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 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. --}-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-        --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 $ 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 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. --    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]--    --Set stuff-    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)-

@@ -1,6 +1,8 @@+{-| Various utility functions -} module Graphics.DynamicGraph.Util (     setupGLFW,-    replaceMVar+    replaceMVar,+    checkVertexTextureUnits     ) where  import Control.Monad@@ -9,6 +11,7 @@ import Control.Concurrent.MVar import Control.DeepSeq +import Graphics.Rendering.OpenGL import Graphics.UI.GLFW as G  -- | Utility function to setup GLFW for graph drawing@@ -21,9 +24,15 @@     res <- lift $ G.init     unless res (left "error initializing glfw") --- | tryTakeMVar then putMVar+-- | `tryTakeMVar` then `putMVar` replaceMVar :: MVar a -> a -> IO () replaceMVar mv val = do     tryTakeMVar mv     putMVar mv val++-- | Check if texture units are accessible from the vertex shader. Needed  by Graphics.DynamicGraph.Line.+checkVertexTextureUnits :: EitherT String IO ()+checkVertexTextureUnits = do+    mtu <- lift $ get maxVertexTextureImageUnits+    when (mtu <= 0) $ left "No texture units accessible from vertex shader" 

@@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-}+ {-| Draw and update waterfall plots with OpenGL. Useful for spectrograms.  Example usage:@@ -12,6 +13,7 @@ > import Graphics.Rendering.OpenGL >  > import Graphics.DynamicGraph.Waterfall+> import Graphics.DynamicGraph.Window >  > randomVect :: Producer [GLfloat] IO () > randomVect =  P.repeatM $ do@@ -21,101 +23,40 @@ >  > main = eitherT putStrLn return $ do >     setupGLFW->     waterfall <- waterfallWindow 1024 480 1000 1000 jet_mod+>     waterfall <- window 1024 480 $ renderWaterfall 1000 1000 jet_mod >  >     lift $ runEffect $ randomVect >-> waterfall+ -}+ module Graphics.DynamicGraph.Waterfall (-    waterfallWindow,     renderWaterfall,-    setupGLFW,     module Graphics.DynamicGraph.ColorMaps     ) 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 -import Control.Monad.Trans.Class-import Control.Monad.Trans.Either import Foreign.Storable import Foreign.Marshal.Array-import Data.IORef  import Pipes -import Graphics.DynamicGraph.Util import Graphics.DynamicGraph.ColorMaps  import Paths_dynamic_graph -{-| @(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.--}-waterfallWindow :: IsPixelData a => Int -> Int -> Int -> Int -> [GLfloat] -> EitherT String IO (Consumer a IO ())-waterfallWindow windowWidth windowHeight width height colorMap = do-    mv :: MVar a <- lift $ newEmptyMVar-    completion <- lift $ newEmptyMVar--    closed <- lift $ newIORef False--    lift $ forkOS $ void $ do-        res <- runEitherT $ do-            res' <- lift $ createWindow windowWidth windowHeight "" 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)-            renderPipe <- lift $ renderWaterfall width height colorMap-            let thePipe = forever $ do -                    lift $ pollEvents-                    dat <- lift $ takeMVar mv-                    lift $ makeContextCurrent (Just win)-                    lift $ pollEvents-                    yield dat-                    lift $ swapBuffers win-            return $ runEffect $ thePipe >-> renderPipe--        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--{-| @(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.--    The fill is drawn with a vertical gradient defined by @colorMap@.+{-| Returns a `Consumer` that renders a waterfall plot into the current OpenGL context.  -    All OpenGL based initialization of the rendering function (loading of-    shaders, etc) is performed before the pipe is returned.+    All OpenGL based initialization of the rendering function (loading of shaders, etc) is performed before the Consumer is returned.+    +    This function must be called with an OpenGL context currently set. -}-renderWaterfall :: IsPixelData a => Int -> Int -> [GLfloat] -> IO (Consumer a IO ())+renderWaterfall :: IsPixelData a +                => Int       -- ^ waterfall columns+                -> Int       -- ^ waterfall rows+                -> [GLfloat] -- ^ waterfall color map+                -> IO (Consumer a IO ()) renderWaterfall width height colorMap = do     --Load the shaders     vertFN <- getDataFileName "shaders/waterfall.vert"@@ -144,7 +85,7 @@         bufferData ArrayBuffer $= (fromIntegral $ sizeOf(undefined::GLfloat) * 8, ptr, StaticDraw)      let yCoords :: [GLfloat]-        yCoords = take (width * height) $ repeat 0+        yCoords = replicate (width * height) 0      activeTexture $= TextureUnit 0     texture Texture2D $= Enabled

@@ -0,0 +1,104 @@+{-# LANGUAGE ScopedTypeVariables #-}++{-| A convenience function for rendering any of the graphs implemented in this package to a standalone window.++Example usage:++> import Control.Monad+> import Control.Monad.Trans.Either+> import Control.Concurrent+> import Pipes+> import qualified Pipes.Prelude as P+> import System.Random+> import Graphics.Rendering.OpenGL+> +> import Graphics.DynamicGraph.Waterfall+> import Graphics.DynamicGraph.Window+> +> randomVect :: Producer [GLfloat] IO ()+> randomVect =  P.repeatM $ do+>     res <- replicateM 1000 randomIO+>     threadDelay 10000+>     return res+> +> main = eitherT putStrLn return $ do+>     setupGLFW+>     waterfall <- window 1024 480 $ renderWaterfall 1000 1000 jet_mod+> +>     lift $ runEffect $ randomVect >-> waterfall++-}+module Graphics.DynamicGraph.Window (+    window,+    module Graphics.DynamicGraph.Util+    ) where++import Control.Monad.Trans.Either+import Control.Concurrent hiding (yield)+import Control.Concurrent.MVar+import Data.IORef+import Control.Monad++import Graphics.UI.GLFW as G+import Graphics.GLUtil+import Graphics.Rendering.OpenGL+import Pipes++import Graphics.DynamicGraph.Util++{-| A convenience function for rendering any of the graphs implemented in this package to a standalone window.+    +    Creates the window before returning.++    Returns either an error message or a consumer that draws to the window.+-}+window :: IsPixelData a +       => Int                                  -- ^ Window width+       -> Int                                  -- ^ Window height+       -> IO (Consumer a IO ())                -- ^ The Consumer that draws on the window. Obtain this from one of the other modules in this package. Must be given in an IO monad so that it can be initialised with the OpenGL context created within this function.+       -> EitherT String IO (Consumer a IO ()) +window width height renderPipe = 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 -> +                viewport $= (Position 0 0, Size (fromIntegral x) (fromIntegral y))+            lift $ setWindowCloseCallback win $ Just $ \win -> writeIORef closed True+            lift $ makeContextCurrent (Just win)+            lift $ clearColor $= Color4 0 0 0 0++            renderPipe <- lift renderPipe++            let thePipe = forever $ do +                    lift pollEvents+                    dat <- lift $ takeMVar mv+                    lift $ makeContextCurrent (Just win)+                    lift pollEvents+                    lift $ clear [ColorBuffer]+                    yield dat+                    lift $ swapBuffers win+            return $ runEffect $ thePipe >-> renderPipe++        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+                unless c $ do+                    x <- await+                    lift $ replaceMVar mv x+                    pipe+        in pipe+

@@ -1,10 +1,12 @@--- Initial dynamic-graph.cabal generated by cabal init.  For further --- documentation, see http://haskell.org/cabal/users-guide/- name:                dynamic-graph-version:             0.1.0.5+version:             0.1.0.6 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. Line graphs and waterfall plots are supported, as well as axis drawing.+description:         +    Draw and update graphs in real time with OpenGL. Suitable for displaying large amounts of frequently changing data. Line graphs and waterfall plots are supported, as well as axis drawing.+    .+    See <https://github.com/adamwalker/dynamic-graph> for examples of the graphs it can produce.+    .+    To get started, see "Graphics.DynamicGraph.Window"  license:             BSD3 license-file:        LICENSE author:              Adam Walker@@ -16,17 +18,17 @@ build-type:          Simple -- extra-source-files:   cabal-version:       >=1.10-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+data-files:          shaders/line.vert, shaders/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.TextureLine, Graphics.DynamicGraph.Waterfall, Graphics.DynamicGraph.Util, Graphics.DynamicGraph.FillLine, Graphics.DynamicGraph.Axis, Graphics.DynamicGraph.RenderCairo, Graphics.DynamicGraph.ColorMaps+  exposed-modules:     Graphics.DynamicGraph.Line, Graphics.DynamicGraph.Waterfall, Graphics.DynamicGraph.Util, Graphics.DynamicGraph.FillLine, Graphics.DynamicGraph.Axis, Graphics.DynamicGraph.RenderCairo, Graphics.DynamicGraph.ColorMaps, Graphics.DynamicGraph.Window   -- 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.9, transformers >=0.3 && <0.5, either >=4.1 && <4.4, pipes, pango, cairo, colour, bytestring, deepseq+  build-depends:       base >=4.6 && <4.8, GLFW-b >=1.4 && <1.5, OpenGL >=2.9 && <2.13, GLUtil >=0.7 && <0.9, transformers >=0.3 && <0.5, either >=4.1 && <4.4, pipes >=4.1 && <4.2, pango >=0.13 && <0.14, cairo >=0.13 && <0.14, colour >=2.3 && <2.4, bytestring >=0.10 && <0.11, deepseq >=1.3 && <1.5   -- hs-source-dirs:         default-language:    Haskell2010   other-modules:       Paths_dynamic_graph

@@ -0,0 +1,6 @@+#version 110++void main() {+    gl_FragColor   = vec4(0, 0, 1, 0);+}+

@@ -0,0 +1,9 @@+#version 110++attribute float coord;+uniform sampler2D texture;++void main(){+    float y     = (texture2D(texture, vec2((coord + 1.0)/2.0, 0)).r - 0.5) * 2.0;+    gl_Position = vec4(coord, y, 0, 1);+}

@@ -1,6 +0,0 @@-#version 110--void main() {-    gl_FragColor   = vec4(0, 0, 1, 0);-}-

@@ -1,9 +0,0 @@-#version 110--attribute float coord;-uniform sampler2D texture;--void main(){-    float y     = (texture2D(texture, vec2((coord + 1.0)/2.0, 0)).r - 0.5) * 2.0;-    gl_Position = vec4(coord, y, 0, 1);-}