From 07ea0fe2a37cab1e549c084f31d231632857b99f Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Tue, 14 May 2019 13:32:37 -0400 Subject: TextureBuffer-based ring buffer. --- MeshSketch.hs | 182 +++++++++++++++++++++++++++++++++++++++++++++------------- hello_obj2.lc | 32 +++++++++++ 2 files changed, 173 insertions(+), 41 deletions(-) diff --git a/MeshSketch.hs b/MeshSketch.hs index b84cd7e..9425890 100644 --- a/MeshSketch.hs +++ b/MeshSketch.hs @@ -16,6 +16,8 @@ import Data.Text (Text) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import qualified Data.Vector as V +import Foreign.Marshal.Array +import Foreign.Storable import GI.Gdk import GI.Gdk.Objects import GI.GLib.Constants @@ -30,9 +32,12 @@ import Control.Exception import LambdaCube.GL as LC import LambdaCube.IR as LC import LambdaCube.Gtk -import LambdaCube.GL.Data (uploadCubeMapToGPU) -import LambdaCube.GL.Type (TextureCubeData(..)) +import LambdaCube.GL.Data (uploadCubeMapToGPU,uploadTextureBufferToGPU,updateTextureBuffer) +import LambdaCube.GL.Type (TextureCubeData(..),Object(..)) -- import Text.Show.Pretty (ppShow) +import qualified Graphics.Rendering.OpenGL as GL +import Data.Char +import Text.Printf import CubeMap import GLWidget (nullableContext, withCurrentGL) @@ -44,6 +49,27 @@ import InfinitePlane import MtlParser (ObjMaterial(..)) import Matrix + +prettyDebug :: GL.DebugMessage -> String +prettyDebug (GL.DebugMessage src typ (GL.DebugMessageID mid) severity msg) = unwords ws + where + ws = [wsrc,wtyp,wmid,wseverity,msg] + -- DebugSourceShaderCompiler DebugTypeOther 1 DebugSeverityNotification + wsrc = filter isUpper $ drop 11 $ show src + wtyp = take 2 $ drop 9 $ show typ + wmid = printf "%03i" mid + wseverity = drop 13 $ show severity + +setupGLDebugging :: IO () +setupGLDebugging = do + let pdebug m@(GL.DebugMessage src typ mid severity msg) = do + putStrLn (">> " ++ prettyDebug m) + GL.debugOutput GL.$= GL.Enabled + GL.debugOutputSynchronous GL.$= GL.Enabled + GL.debugMessageControl (GL.MessageGroup Nothing Nothing Nothing) GL.$= GL.Enabled + GL.debugMessageCallback GL.$= Just pdebug + + -- State created by uploadState. data State = State { stAnimator :: Animator @@ -53,6 +79,8 @@ data State = State , stSkybox :: IORef Int , stSkyTexture :: IORef TextureCubeData , stDragFrom :: IORef (Maybe (Vector Float,Camera)) + , stRingBuffer :: Ring + , stPenDown :: IORef Bool } data Camera = Camera @@ -111,6 +139,49 @@ mkFullscreenToggle w = do if b then windowFullscreen w else windowUnfullscreen w +data Ring = Ring + { ringMax :: Int + , ringTexture :: TextureBufferData + , ringStart :: IO Int + , ringSize :: IO Int + , pushBack :: Float -> Float -> Float -> IO () + , popFront :: IO () + } + +newRing :: GLStorage -> Int -> IO Ring +newRing storage cnt = do + let ringCapacity = cnt * 3 + tbo <- uploadTextureBufferToGPU ringCapacity + p <- uploadMeshToGPU Mesh + { mAttributes = Map.singleton "position" $ A_Float $ V.fromList + $ replicate ringCapacity 0.0 + , mPrimitive = P_Points + } + obj <- addMeshToObjectArray storage "Points" [] p + LC.updateUniforms storage $ do + "PointBuffer" @= return tbo + rstart <- newIORef 0 + rsize <- newIORef 0 + return Ring + { ringMax = cnt * 3 + , ringTexture = tbo + , ringStart = readIORef rstart + , ringSize = readIORef rsize + , pushBack = \x y z -> do + start <- readIORef rstart + allocaArray 3 $ \ptr -> do + pokeElemOff ptr 0 x + pokeElemOff ptr 1 y + pokeElemOff ptr 2 z + updateTextureBuffer tbo start 3 ptr + writeIORef rstart (mod (start + 3) ringCapacity) + sz <- readIORef rsize + putStrLn $ "pushBack "++show (sz,start,(x,y,z)) + when (sz < ringCapacity) $ do + writeIORef rsize (sz + 3) + , popFront = modifyIORef' rsize $ \s -> if s > 3 then s - 3 else 0 + } + uploadState :: IsWidget glarea => MeshData -> glarea -> GLStorage -> IO State uploadState obj glarea storage = do -- load OBJ geometry and material descriptions @@ -122,6 +193,8 @@ uploadState obj glarea storage = do -- grid plane uploadMeshToGPU xzplane >>= addMeshToObjectArray storage "plane" [] + ring <- newRing storage 100 + -- setup FrameClock w <- toWidget glarea tm <- newAnimator w @@ -146,6 +219,7 @@ uploadState obj glarea storage = do LC.addMeshToObjectArray storage "SkyCube" [] mi drag <- newIORef Nothing + pendown <- newIORef False let st = State { stAnimator = tm @@ -155,6 +229,8 @@ uploadState obj glarea storage = do , stSkybox = skybox , stSkyTexture = skytex , stDragFrom = drag + , stRingBuffer = ring + , stPenDown = pendown } -- _ <- addAnimation tm (whirlingCamera st) @@ -187,6 +263,8 @@ setUniforms gl storage st = do LC.updateUniforms storage $ do "CameraPosition" @= return (pos :: Vector Float) "ViewProjection" @= return (mvp :: Matrix Float) + "PointsStart" @= fmap (fromIntegral :: Int -> Int32) (ringStart $ stRingBuffer st) + "PointsMax" @= return (fromIntegral (ringMax $ stRingBuffer st) :: Int32) data MeshSketch = MeshSketch { mmWidget :: GLArea @@ -214,10 +292,15 @@ new = do "uvw" @: Attribute_V3F defObjectArray "plane" Triangles $ do "position" @: Attribute_V4F + defObjectArray "Points" Points $ do + "position" @: Attribute_Float defUniforms $ do + "PointBuffer" @: FTextureBuffer "CubeMap" @: FTextureCube "CameraPosition" @: V3F "ViewProjection" @: M44F + "PointsMax" @: Int + "PointsStart" @: Int "diffuseTexture" @: FTexture2D "diffuseColor" @: V4F return $ (,) <$> mobj <*> mpipeline @@ -248,6 +331,7 @@ onUnrealize mm = do onRealize :: MeshData -> Pipeline -> PipelineSchema -> MeshSketch -> IO () onRealize mesh pipeline schema mm = do onUnrealize mm + setupGLDebugging storage <- LC.allocStorage schema renderer <- LC.allocRenderer pipeline compat <- LC.setStorage renderer storage -- check schema compatibility @@ -298,6 +382,8 @@ onResize glarea realized w h = do } LC.setScreenSize (stStorage realized) wd ht) +-- This computes a point in world coordinates on the view screen if +-- we assume the camera is located at the origin. computeDirection :: Camera -> Double -> Double -> Vector Float computeDirection cam h k = let d̂ = camDirection cam -- forward @@ -392,49 +478,63 @@ onEvent w realized ev = do case etype of EventTypeMotionNotify -> do - mev <- get ev #motion - h <- get mev #x - k <- get mev #y - {- - cam <- readIORef (stCamera st) - {- - let o = fromList [ camWidth cam / 2, camHeight cam / 2 ] - r = camHeight cam / (2 * sin (camHeight cam / 2)) - - c = fromList [realToFrac h, realToFrac k] - o :: Vector Float - d = realToFrac $ norm_2 c - τ = asin (d / r) -- angle from center - axis = fromList [c!1, - (c!0)] :: Vector Float - -} - let d̂ = camDirection cam -- forward - û = camUp cam -- upward - r̂ = d̂ `cross` û -- rightward - x_r = realToFrac h - (camWidth cam / 2) - x_u = (camHeight cam / 2) - realToFrac k - x_d = (camHeight cam / 2) / tan (camHeightAngle cam / 2) - x = fromList [x_r,x_u,x_d] - -} - - updateCameraRotation w st h k - return () + case inputSource of + Just InputSourcePen -> do + isDown <- readIORef (stPenDown st) + when isDown $ do + mev <- get ev #motion + h <- get mev #x + k <- get mev #y + cam <- readIORef (stCamera st) + let d = computeDirection cam h k + pushBack (stRingBuffer st) (d!0) (d!1) (d!2) + put (etype,(h,k),d) + _ -> do + mev <- get ev #motion + h <- get mev #x + k <- get mev #y + put (h,k) + updateCameraRotation w st h k + return () EventTypeButtonPress -> do - bev <- get ev #button - h <- get bev #x - k <- get bev #y - cam <- readIORef (stCamera st) - let d = computeDirection cam h k - writeIORef (stDragFrom st) $ Just (d,cam) - put (etype,(h,k),d) - return () + case inputSource of + Just InputSourcePen -> do + writeIORef (stPenDown st) True + bev <- get ev #button + h <- get bev #x + k <- get bev #y + cam <- readIORef (stCamera st) + let d = computeDirection cam h k + pushBack (stRingBuffer st) (d!0) (d!1) (d!2) + put (etype,(h,k),d) + _ -> do + bev <- get ev #button + h <- get bev #x + k <- get bev #y + cam <- readIORef (stCamera st) + let d = computeDirection cam h k + writeIORef (stDragFrom st) $ Just (d,cam) + put (etype,(h,k),d) + return () EventTypeButtonRelease -> do - bev <- get ev #button - h <- get bev #x - k <- get bev #y - updateCameraRotation w st h k - sanitizeCamera st - writeIORef (stDragFrom st) Nothing + case inputSource of + Just InputSourcePen -> do + writeIORef (stPenDown st) False + bev <- get ev #button + h <- get bev #x + k <- get bev #y + cam <- readIORef (stCamera st) + let d = computeDirection cam h k + pushBack (stRingBuffer st) (d!0) (d!1) (d!2) + _ -> do + bev <- get ev #button + h <- get bev #x + k <- get bev #y + updateCameraRotation w st h k + sanitizeCamera st + writeIORef (stDragFrom st) Nothing EventTypeScroll -> do sev <- get ev #scroll diff --git a/hello_obj2.lc b/hello_obj2.lc index 991c3c2..8e9bbe0 100644 --- a/hello_obj2.lc +++ b/hello_obj2.lc @@ -19,6 +19,8 @@ makeFrame (cubemap :: TextureCube) (texture :: Texture) (prims :: PrimitiveStream Triangle (Vec 4 Float, Vec 3 Float, Vec 3 Float)) (plane :: PrimitiveStream Triangle ((Vec 4 Float))) + (pointsMax :: Int) + (pointsStart :: Int) = imageFrame (emptyDepthImage 1, emptyColorImage (V4 0 0 0.4 1)) `overlay` @@ -43,6 +45,34 @@ makeFrame (cubemap :: TextureCube) r = V4 1 1 1 0 *! (max c%x c%y) in ((r + V4 0 0 0 (0.8)))) & accumulateWith (DepthOp Less True, ColorOp blendplane (V4 True True True True)) + `overlay` + zipCount (fetch "Points" ((Attribute "position")) :: PrimitiveStream Point ((Float))) + & mapPrimitives (\(n,_) -> {- let nn = 0.2 * fromInt n :: Float + p = V4 nn nn nn 1 + p' = coordmap cam p + in (p', V4 1 1 0 1 :: Vec 4 Float)) -} + let i = mod (n + pointsStart) pointsMax + t = TextureBufferSlot "PointBuffer" + p = V4 (textureBuffer t i) + (textureBuffer t (i+1)) + (textureBuffer t (i+2)) + 1 + p' = coordmap cam p + in (p', V4 1 1 0 1 :: Vec 4 Float)) + + & renderPoints cam + + +renderPoints :: + Mat 4 4 Float + -> PrimitiveStream Point (Vec 4 Float, Vec 4 Float) + -> ( (FragmentOperation Depth, FragmentOperation (Color (VecScalar 4 Float))) + , FragmentStream 1 ((Vec 4 Float)) ) +renderPoints cam points = + points + & rasterizePrimitives (PointCtx (PointSize 10.0) 1.0 LowerLeft) ((Flat)) + & mapFragments (\((c)) -> ((c))) + & accumulateWith (DepthOp Always False, ColorOp NoBlending (V4 True True True True)) textureCubeSlot s = TextureCubeSlot s @@ -56,4 +86,6 @@ main = renderFrame $ (Texture2DSlot "diffuseTexture") (fetch "objects" (Attribute "position", Attribute "normal", Attribute "uvw")) (fetch "plane" ((Attribute "position"))) + (Uniform "PointsMax") + (Uniform "PointsStart") -- cgit v1.2.3