{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Graphics.Liveplot.Line where
import Data.Vinyl
import Graphics.GLUtil
import Graphics.Rendering.OpenGL
import Graphics.VinylGL
import Linear (V1(..))
import Control.Concurrent.STM
import Graphics.Liveplot.Shaders
import Graphics.Liveplot.Types
type XPos = '("xCoord", V1 GLfloat)
xcoord :: SField XPos
xcoord = SField
monoTex :: Int -> IO TextureObject
monoTex len = do
t <- freshTextureFloat len 1 TexMono
textureFilter Texture2D $= ((Linear', Nothing), Linear')
texture2DWrap $= (Repeated, ClampToEdge)
return t
line :: GraphInfo -> IO (Maybe [GLfloat] -> GraphInfo -> IO ())
line gi =
do s <- uncurry simpleShaderProgramBS lineShaders
let nsamples = graph_samples gi
xResolution = graph_resolution gi
pResolution = graph_points gi
isamples = fromIntegral nsamples
xCoords :: [GLfloat]
xCoords = take xResolution $ iterate (+ 2 / fromIntegral xResolution) (-1)
_pointCoords :: [GLfloat]
_pointCoords = take pResolution $ iterate (+ 2 / fromIntegral pResolution) (-1)
yCoords :: [GLfloat]
yCoords = replicate nsamples 0
vb <- bufferVertices . map (xcoord =:) $ V1 <$> xCoords
t <- monoTex nsamples
reloadTexture t (TexInfo isamples 1 TexMono yCoords)
currentProgram $= Just (program s)
setUniforms s (texSampler =: 0)
pointsVAO <- makeVAO $ do enableVertices' s vb
bindVertices vb
linesVAO <- makeVAO $ do enableVertices' s vb
bindVertices vb
return $ \d GraphInfo{..} -> do
currentProgram $= Just (program s)
setUniforms s graph_appinfo
let withVP = withVP' graph_viewport graph_scale graph_offset
case d of
Just dat -> reloadTexture t (TexInfo isamples 1 TexMono dat)
Nothing -> return ()
withVP $ withVAO linesVAO . withTextures2D [t] $
drawArrays LineStrip 0 (fromIntegral xResolution)
withVP $ withVAO pointsVAO . withTextures2D [t] $
drawArrays Points 0 (fromIntegral pResolution)
where
texSampler = SField :: SField '("tex", GLint)
withVP' (Position x y, Size w h) (xsc, ysc) (xoff, yoff) = withViewport
(Position (x + (fromIntegral yoff) * w')
(y + (fromIntegral xoff) * h'))
(Size w' h')
where
w' = floor $ fromIntegral w / ysc
h' = floor $ fromIntegral h / xsc
instance Plottable GLfloat where
initplot gi = do
tvar <- atomically $ newTVar Nothing
draw <- line gi
return (tvar, bufferTVar (graph_name gi) (graph_samples gi) tvar, draw)