TextureBuffer-based ring buffer.

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")