diff --git a/Graphics/DynamicGraph/Axis.hs b/Graphics/DynamicGraph/Axis.hs --- a/Graphics/DynamicGraph/Axis.hs +++ b/Graphics/DynamicGraph/Axis.hs @@ -17,7 +17,7 @@ makeLayout :: PangoContext -> String -> Render (PangoLayout, PangoRectangle) makeLayout ctx text = liftIO $ do layout <- layoutEmpty ctx - layoutSetMarkup layout text + layoutSetMarkup layout text :: IO String (_, rect) <- layoutGetExtents layout return (layout, rect) @@ -64,10 +64,10 @@ stroke gridXCoords :: Double -> Double -> Double -> Double -> Double -> [Double] -gridXCoords width offset leftMargin rightMargin spacing = takeWhile (< (width - rightMargin)) $ iterate (+ spacing) (offset + leftMargin) +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) +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 diff --git a/Graphics/DynamicGraph/FillLine.hs b/Graphics/DynamicGraph/FillLine.hs --- a/Graphics/DynamicGraph/FillLine.hs +++ b/Graphics/DynamicGraph/FillLine.hs @@ -19,6 +19,7 @@ import Foreign.Marshal.Array import Control.Concurrent import Control.Concurrent.MVar +import Data.IORef import Pipes @@ -35,22 +36,27 @@ The fill is drawn with a vertical gradient defined by @colorMap@. -} -filledLineWindow :: IsPixelData a => Int -> Int -> Int -> [GLfloat] -> EitherT String IO (a -> IO ()) +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] @@ -65,7 +71,14 @@ join $ lift $ takeMVar completion - return $ replaceMVar mv + 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 diff --git a/Graphics/DynamicGraph/TextureLine.hs b/Graphics/DynamicGraph/TextureLine.hs --- a/Graphics/DynamicGraph/TextureLine.hs +++ b/Graphics/DynamicGraph/TextureLine.hs @@ -21,6 +21,7 @@ import Foreign.Marshal.Array import Control.Concurrent import Control.Concurrent.MVar +import Data.IORef import Pipes @@ -38,17 +39,21 @@ 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 (a -> IO ()) +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" @@ -57,6 +62,7 @@ (renderFunc :: a -> IO ()) <- lift $ renderTextureLine samples xResolution return $ forever $ do + pollEvents dat <- takeMVar mv makeContextCurrent (Just win) clear [ColorBuffer] @@ -71,7 +77,14 @@ join $ lift $ takeMVar completion - return $ replaceMVar mv + 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 diff --git a/Graphics/DynamicGraph/Waterfall.hs b/Graphics/DynamicGraph/Waterfall.hs --- a/Graphics/DynamicGraph/Waterfall.hs +++ b/Graphics/DynamicGraph/Waterfall.hs @@ -22,6 +22,7 @@ import Control.Monad.Trans.Either import Foreign.Storable import Foreign.Marshal.Array +import Data.IORef import Pipes @@ -60,23 +61,30 @@ 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 (a -> IO ()) +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 = (<-<) renderPipe $ forever $ do + let thePipe = forever $ do + lift $ pollEvents dat <- lift $ takeMVar mv lift $ makeContextCurrent (Just win) + lift $ pollEvents yield dat lift $ swapBuffers win - return $ runEffect thePipe + return $ runEffect $ thePipe >-> renderPipe case res of Left err -> replaceMVar completion $ left err @@ -86,7 +94,14 @@ join $ lift $ takeMVar completion - return $ \x -> replaceMVar mv x + 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 diff --git a/dynamic-graph.cabal b/dynamic-graph.cabal --- a/dynamic-graph.cabal +++ b/dynamic-graph.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: dynamic-graph -version: 0.1.0.3 +version: 0.1.0.4 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. license: BSD3 @@ -24,7 +24,7 @@ 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, pango, cairo, colour, bytestring, deepseq + 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 -- hs-source-dirs: default-language: Haskell2010 other-modules: Paths_dynamic_graph