From ff4225d80e15b86bd8de11390442381a5c437ce4 Mon Sep 17 00:00:00 2001 From: Anthony Cowley Date: Wed, 7 Nov 2012 13:53:57 -0500 Subject: [PATCH] Added a ground plane grid visualization. --- src/Main.hs | 15 ++++++--- src/PointsGL.hs | 6 +++- src/VizMarkers.hs | 86 +++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 102 insertions(+), 5 deletions(-) create mode 100644 src/VizMarkers.hs diff --git a/src/Main.hs b/src/Main.hs index 4043287..87a35cb 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -18,6 +18,7 @@ import Linear.V4 import Linear.Vector import qualified PCD.Data as PCD import PointsGL +import VizMarkers import MyPaths import HeatPalette import FrameGrabber @@ -75,7 +76,8 @@ bool _ f False = f data ShaderArgs = ShaderArgs { camMat :: UniformLocation , heatTex :: UniformLocation - , vertexPos :: AttribLocation } + , vertexPos :: AttribLocation + , cloudProg :: Program } initShader :: IO ShaderArgs initShader = do vs <- loadShader =<< getDataFileName "etc/cloud.vert" @@ -85,6 +87,7 @@ initShader = do vs <- loadShader =<< getDataFileName "etc/cloud.vert" ShaderArgs <$> get (uniformLocation p "cam") <*> get (uniformLocation p "heat") <*> get (attribLocation p "vertexCoord") + <*> pure p buildMat :: Float -> Float -> Float -> M44 Float buildMat s near far = V4 (set _x s 0) @@ -98,13 +101,14 @@ setup scale ptFile = do clearColor $= Color4 1 1 1 0 depthFunc $= Just Lequal vertexProgramPointSize $= Enabled pointSmooth $= Enabled - textureFunction $= Decal + --textureFunction $= Decal lighting $= Disabled s <- initShader activeTexture $= TextureUnit 0 - uniform (heatTex s) $= Index1 (0::GLuint) + uniform (heatTex s) $= Index1 (0::GLint) (heatVec, t) <- heatTexture 1024 let ext = takeExtension ptFile + gp <- groundPlane 5 0.1 v <- case () of _ | ext == ".pcd" -> PCD.loadXyz ptFile >>= \v' -> @@ -120,7 +124,10 @@ setup scale ptFile = do clearColor $= Color4 1 1 1 0 let m = uniformMat (camMat s) proj = buildMat scale 0.01 100.0 drawPoints <- prepPoints v (vertexPos s) - let draw c = do m $= (toList . fmap (toList . fmap realToFrac) $ + let draw c = do gp Z (V3 1 0 0) (fmap (fmap realToFrac) $ + proj !*! toMatrix c) + currentProgram $= Just (cloudProg s) + m $= (toList . fmap (toList . fmap realToFrac) $ proj !*! toMatrix c) activeTexture $= TextureUnit 0 uniform (heatTex s) $= Index1 (0::GLuint) diff --git a/src/PointsGL.hs b/src/PointsGL.hs index d53a156..cb2d0c4 100644 --- a/src/PointsGL.hs +++ b/src/PointsGL.hs @@ -12,9 +12,13 @@ prepPoints v vertexPos = let iv = V.enumFromN 0 (V.length v) :: V.Vector Word32 ib <- fromVector ArrayBuffer iv bindBuffer ArrayBuffer $= Just vb + bindBuffer ElementArrayBuffer $= Just ib vertexAttribArray vertexPos $= Enabled vertexAttribPointer vertexPos $= (ToFloat, VertexArrayDescriptor 3 Float 0 offset0) - return $ do bindBuffer ElementArrayBuffer $= Just ib + return $ do bindBuffer ArrayBuffer $= Just vb + --bindBuffer ElementArrayBuffer $= Just ib + vertexAttribPointer vertexPos $= + (ToFloat, VertexArrayDescriptor 3 Float 0 offset0) drawElements Points (fromIntegral $ V.length v) UnsignedInt offset0 diff --git a/src/VizMarkers.hs b/src/VizMarkers.hs new file mode 100644 index 0000000..fe33511 --- /dev/null +++ b/src/VizMarkers.hs @@ -0,0 +1,86 @@ +{-# OPTIONS_GHC -Wall #-} +module VizMarkers where +import Control.Exception (SomeException, catch) +import Data.Foldable (toList) +import Graphics.GLUtil +import Graphics.Rendering.OpenGL +import Linear.V2 +import Linear.V3 +import Linear.Matrix +import MyPaths +import System.Exit (exitWith, ExitCode(..)) + +data EuclideanGround = X | Y | Z deriving (Eq,Ord,Show,Enum) + +enumToGL :: Enum a => a -> GLint +enumToGL = fromIntegral . fromEnum + +toGLMat :: Real a => M44 a -> [[GLfloat]] +toGLMat = toList . fmap (toList . fmap realToFrac) + +initGroundShader :: IO (EuclideanGround -> V3 GLfloat -> M44 GLfloat -> IO ()) +initGroundShader = do let giveUp :: SomeException -> IO a + giveUp _ = {-shutdown >>-} exitWith (ExitFailure 1) + bindBuffer ArrayBuffer $= Nothing + currentProgram $= Nothing + vs <- (loadShader =<< getDataFileName "etc/GroundPlane.vert") + `catch` giveUp + fs <- (loadShader =<< getDataFileName "etc/GroundPlane.frag") + `catch` giveUp + p <- linkShaderProgram [vs] [fs] `catch` giveUp + pos <- get $ attribLocation p "vertexCoord" + cam <- get $ uniformLocation p "cam" + plane <- get $ uniformLocation p "euclideanGround" + wireColor <- get $ uniformLocation p "wireColor" + let mat = uniformMat cam + vec = uniformVec wireColor + vad = VertexArrayDescriptor 2 Float 0 offset0 + vertexAttribArray pos $= Enabled + vertexAttribPointer pos $= (ToFloat, vad) + return $ \whichPlane col proj -> + do currentProgram $= Just p + vertexAttribPointer pos $= (ToFloat, vad) + uniform plane $= Index1 (enumToGL whichPlane) + mat $= toList (fmap toList proj) + vec $= toList col + +checkErrors :: IO () +checkErrors = get errors >>= aux + where aux [] = return () + aux x = print x >> exitWith (ExitFailure 1) + +-- |@groundPlane gridSize cellSize@ prepares an action for drawing a +-- wireframe ground plane, centered at the origin, consisting of +-- @gridSize@ squares with side length @cellSize@ extending off in +-- each direction. +groundPlane :: Int -> GLfloat -> + IO (EuclideanGround -> V3 GLfloat -> M44 GLfloat -> IO ()) +groundPlane n sz = do vb <- makeBuffer ArrayBuffer (horizontals ++ verts) + putStrLn $ (show (length (horizontals++verts))) ++ " vs "++ + (show (8*(n+1)))++" vs "++show (length indices) + print (horizontals++verts) + bindBuffer ArrayBuffer $= Just vb + shader <- initGroundShader + eb <- makeBuffer ElementArrayBuffer indices + bindBuffer ElementArrayBuffer $= Just eb + let go whichPlane col proj = + do bindBuffer ArrayBuffer $= Just vb + --bindBuffer ElementArrayBuffer $= Just eb + shader whichPlane col proj + drawElements Lines (8*(fromIntegral n+1)) + UnsignedInt offset0 + return go + where extent = fromIntegral n * sz + horizontals = concatMap (\z -> let z' = fromIntegral z * sz + in [ V2 (-extent) z' + , V2 extent z' + , V2 (-extent) (-z') + , V2 extent (-z') ]) + [0 .. n] + verts = concatMap (\x -> let x' = fromIntegral x * sz + in [ V2 x' (-extent) + , V2 x' extent + , V2 (-x') (-extent) + , V2 (-x') extent ]) + [0 .. n] + indices = [(0::GLuint)..8 * (fromIntegral n + 1)-1]