Point primitive stream based ring buffer.

3 files changed, 263 insertions, 26 deletions

diff --git a/MeshSketch.hs b/MeshSketch.hs
index 16c8284..0b3cd05 100644
--- a/MeshSketch.hs
+++ b/MeshSketch.hs
@@ -48,7 +48,7 @@ import LoadMesh
 import InfinitePlane
 import MtlParser (ObjMaterial(..))
 import Matrix
-import TextureBufferRing
+import PointPrimitiveRing
 
 
 prettyDebug :: GL.DebugMessage -> String
@@ -96,6 +96,8 @@ data Camera = Camera
     , camScreenToWorld :: Maybe (Matrix Float)
     }
 
+camPos c = camTarget c - scale (camDistance c) (camDirection c)
+
 initCamera :: Camera
 initCamera = Camera
     { camHeightAngle = pi/6
@@ -251,7 +253,7 @@ new = do
           defObjectArray "plane" Triangles $ do
             "position"  @: Attribute_V4F
           defObjectArray "Points" Points $ do
-            "position"  @: Attribute_Float
+            "position"  @: Attribute_V3F
           defUniforms $ do
             "PointBuffer"     @: FTextureBuffer
             "CubeMap"         @: FTextureCube
@@ -309,7 +311,8 @@ onRealize mesh pipeline schema mm = do
         , EventMaskScrollMask
         , EventMaskKeyPressMask -- , EventMaskKeyReleaseMask
         ]
-    _ <- on w #event  $ onEvent  w r
+    _ <- on w #event  $ \ev -> do gLAreaMakeCurrent w
+                                  onEvent w r ev
     _ <- on w #render $ onRender w r
     _ <- on w #resize $ onResize w r
     writeIORef (mmRealized mm) $ Just r
@@ -444,8 +447,11 @@ onEvent w realized ev = do
                         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)
+                        let d = camPos cam + computeDirection cam h k
+                        -- pushBack (stRingBuffer st) (d!0) (d!1) (d!2)
+                        pushBack (stRingBuffer st) (2 * realToFrac h/camWidth cam - 1) (1 - 2 * realToFrac k/camHeight cam) 1 -- (d!0) (d!1) (d!2)
+                        Just win <- getWidgetWindow w
+                        windowInvalidateRect win Nothing False
                         put (etype,(h,k),d)
                 _ -> do
                     mev <- get ev #motion
@@ -463,8 +469,11 @@ onEvent w realized ev = do
                     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)
+                    let d = camPos cam + computeDirection cam h k
+                    -- pushBack (stRingBuffer st) (d!0) (d!1) (d!2)
+                    pushBack (stRingBuffer st) (2 * realToFrac h/camWidth cam - 1) (1 - 2 * realToFrac k/camHeight cam) 1 -- (d!0) (d!1) (d!2)
+                    Just win <- getWidgetWindow w
+                    windowInvalidateRect win Nothing False
                     put (etype,(h,k),d)
                 _ -> do
                     bev <- get ev #button
@@ -484,8 +493,10 @@ onEvent w realized ev = do
                     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)
+                    let d = camPos cam + computeDirection cam h k
+                    pushBack (stRingBuffer st) (2 * realToFrac h/camWidth cam - 1) (1 - 2 * realToFrac k/camHeight cam) 1 -- (d!0) (d!1) (d!2)
+                    Just win <- getWidgetWindow w
+                    windowInvalidateRect win Nothing False
                 _ -> do
                     bev <- get ev #button
                     h <- get bev #x
diff --git a/PointPrimitiveRing.hs b/PointPrimitiveRing.hs
new file mode 100644
index 0000000..bd9a15b
--- /dev/null
+++ b/PointPrimitiveRing.hs
@@ -0,0 +1,239 @@
+{-# LANGUAGE LambdaCase, RecordWildCards #-}
+module PointPrimitiveRing where
+
+import Control.Monad
+import Data.Foldable
+import Data.Int
+import Data.IORef
+import Data.Maybe
+import Data.Word
+import qualified Data.Map.Strict as Map
+import qualified Data.Vector as V
+         ;import Data.Vector as V ((!),(//))
+import Foreign.C.Types (CPtrdiff)
+import Foreign.Marshal
+import Foreign.Ptr
+import Foreign.Storable
+
+import LambdaCube.GL      as LC
+import LambdaCube.GL.Data -- (uploadCubeMapToGPU,uploadTextureBufferToGPU,updateTextureBuffer)
+import LambdaCube.GL.Mesh as LC
+import LambdaCube.GL.Type
+import LambdaCube.IR      as LC
+import LambdaCube.GL.Util
+import LambdaCube.GL.Input.Type
+import LambdaCube.GL.Input hiding (createObjectCommands)
+
+import Graphics.GL.Core33
+
+data Ring = Ring
+    { rBufferObject :: Word32
+    , rStorage      :: GLStorage
+    , rObject       :: Object
+    , rSize         :: IORef CPtrdiff
+    , rStart        :: IORef CPtrdiff
+    , ringCapacity  :: CPtrdiff
+    }
+
+addToObjectArray :: GLStorage
+                        -> String   -- ^ Slot name for a PrimitiveStream.
+                        -> [String] -- ^ Uniform names.  IORefs will be put in 'objUniSetup'.
+                        -> GPUData
+                        -> IO Object
+addToObjectArray input slotName objUniNames (GPUData prim streams indices _) = do
+    let ObjectArraySchema _ slotStreams = fromMaybe (error $ "addMeshToObjectArray - missing object array: " ++ slotName)
+                                                    $ Map.lookup slotName $! objectArrays $! schema input
+    addObject input slotName prim indices (Map.intersection streams slotStreams) objUniNames
+
+setUniformCommand :: (String -> GLUniform)
+                               -> (String,GLint)
+                               -> GLObjectCommand
+setUniformCommand ulookup (n,i) = GLSetUniform i (ulookup n)
+
+bindTextureCommand :: (String -> IORef GLint)
+                   -> (String -> GLUniform)
+                   -> String
+                   -> GLObjectCommand
+bindTextureCommand tlookup ulookup n = GLBindTexture (inputTypeToTextureTarget $ uniInputType u) (tlookup n) u
+ where
+    u = ulookup n
+    uniInputType (GLTypedUniform ty _) = unwitnessType ty
+    uniInputType (GLUniform r)         = objectType r
+
+
+lookupOrLookup :: (Ord k, Show k) => String -> Map.Map k a -> Map.Map k a -> k -> a
+lookupOrLookup callsite objUnis topUnis n = Map.findWithDefault (topUni n) n objUnis
+ where
+    topUni n = Map.findWithDefault (error $ "internal error ("++callsite++"): " ++ show n) n topUnis
+
+
+classifyStreamType :: StreamType -> ( GLint
+                                    , GLuint -> GLuint -> GLint -> GLenum -> Ptr () -> GLObjectCommand)
+classifyStreamType = \case
+    Attribute_Word   -> ( 1 , GLSetVertexAttribIArray )
+    Attribute_V2U    -> ( 2 , GLSetVertexAttribIArray )
+    Attribute_V3U    -> ( 3 , GLSetVertexAttribIArray )
+    Attribute_V4U    -> ( 4 , GLSetVertexAttribIArray )
+    Attribute_Int    -> ( 1 , GLSetVertexAttribIArray )
+    Attribute_V2I    -> ( 2 , GLSetVertexAttribIArray )
+    Attribute_V3I    -> ( 3 , GLSetVertexAttribIArray )
+    Attribute_V4I    -> ( 4 , GLSetVertexAttribIArray )
+    Attribute_Float  -> ( 1  , GLSetVertexAttribArray )
+    Attribute_V2F    -> ( 2  , GLSetVertexAttribArray )
+    Attribute_V3F    -> ( 3  , GLSetVertexAttribArray )
+    Attribute_V4F    -> ( 4  , GLSetVertexAttribArray )
+    Attribute_M22F   -> ( 4  , GLSetVertexAttribArray )
+    Attribute_M23F   -> ( 6  , GLSetVertexAttribArray )
+    Attribute_M24F   -> ( 8  , GLSetVertexAttribArray )
+    Attribute_M32F   -> ( 6  , GLSetVertexAttribArray )
+    Attribute_M33F   -> ( 9  , GLSetVertexAttribArray )
+    Attribute_M34F   -> ( 12 , GLSetVertexAttribArray )
+    Attribute_M42F   -> ( 8  , GLSetVertexAttribArray )
+    Attribute_M43F   -> ( 12 , GLSetVertexAttribArray )
+    Attribute_M44F   -> ( 16 , GLSetVertexAttribArray )
+
+drawElementsCommand :: GLenum -> IndexStream Buffer -> GLObjectCommand
+drawElementsCommand prim (IndexStream (Buffer arrs bo) arrIdx start idxCount)
+        = GLDrawElements prim (fromIntegral idxCount) idxType bo ptr
+ where
+    ArrayDesc arrType arrLen arrOffs arrSize = arrs ! arrIdx
+    idxType = arrayTypeToGLType arrType
+    ptr    = intPtrToPtr $! fromIntegral (arrOffs + start * sizeOfArrayType arrType)
+
+objectDrawStyle :: (GLsizei -> [(GLint,GLsizei)]) -- ^ mask, normally \x -> [(0,x)]
+                    -> Object
+                    -> Either [(GLint,GLsizei)] (IndexStream Buffer)
+objectDrawStyle streamMask obj = case objIndices obj of
+    Nothing -> Left $ let cnt = head [c | Stream _ _ _ _ c <- Map.elems (objAttributes obj)]
+                       in streamMask $ fromIntegral cnt
+    Just idxStream -> Right idxStream
+
+
+createObjectCommands :: Map.Map String (IORef GLint) -> Map.Map String GLUniform -> Object -> GLProgram -> [GLObjectCommand]
+createObjectCommands texUnitMap topUnis obj prg =
+    createObjectCommands_ (objectEnvironment texUnitMap topUnis obj (pure . ((,) 0))) prg
+
+createObjectCommands_ :: ObjectEnvironment -> GLProgram -> [GLObjectCommand]
+createObjectCommands_ ObjectEnvironment{..} prg = concat
+    [ map (setUniformCommand ulookup)          $ Map.toList (inputUniforms prg)
+    , map (bindTextureCommand tlookup ulookup) $ toList (inputTextureUniforms prg)
+    , map (setVertexAttribCommmand alookup)    $ Map.elems (inputStreams prg)
+    , case envDrawStyle of
+        Left ranges   -> map (uncurry $ GLDrawArrays envPrim) ranges
+        Right indexed -> pure $ drawElementsCommand envPrim indexed
+    ]
+
+data ObjectEnvironment = ObjectEnvironment
+    { envPrim      :: GLenum
+    , envDrawStyle :: Either [(GLint,GLsizei)] (IndexStream Buffer)
+    , tlookup      :: String -> IORef GLint
+    , ulookup      :: String -> GLUniform
+    , alookup      :: String -> Stream Buffer
+    }
+
+objectEnvironment :: Map.Map String (IORef GLint)
+                     -> Map.Map String GLUniform
+                     -> Object
+                     -> (GLsizei -> [(GLint, GLsizei)])
+                     -> ObjectEnvironment
+objectEnvironment texUnitMap topUnis obj streamMask = ObjectEnvironment
+    { envPrim      = primitiveToGLType $ objPrimitive obj
+    , envDrawStyle = objectDrawStyle streamMask obj
+    , tlookup      = \n -> Map.findWithDefault (error $ "missing texture unit: " ++ show n) n texUnitMap
+    , ulookup      = lookupOrLookup "missing uniform: " (objUniSetup obj) topUnis
+    , alookup      = \n -> Map.findWithDefault (error $ "missing attribute: " ++ n) n $ objAttributes obj
+    }
+
+
+setVertexAttribCommmand :: (t -> Stream Buffer) -> (GLuint, t) -> GLObjectCommand
+setVertexAttribCommmand alookup (i,name) = case alookup name of
+    Stream ty (Buffer arrs bo) arrIdx start len -> mkAttrCmd i bo n (arrayTypeToGLType arrType) (intPtrToPtr $! offset)
+      where
+        (n, mkAttrCmd) = classifyStreamType ty
+        ArrayDesc arrType arrLen arrOffs arrSize = arrs ! arrIdx
+        offset = fromIntegral (arrOffs + start * fromIntegral n * sizeOfArrayType arrType)
+
+    -- constant generic attribute
+    constAttr -> GLSetVertexAttrib i constAttr
+
+updateCommands :: GLStorage
+                  -> Object
+                  -> (GLsizei -> [(GLint,GLsizei)])
+                  -> IO Object
+updateCommands input obj mask = do
+    let cmdsRef = objCommands obj :: IORef (V.Vector (V.Vector [GLObjectCommand]))
+        slotIdx = objSlot obj :: Int
+    ppls <- readIORef $ pipelines input
+    cmds <- V.forM (ppls :: V.Vector (Maybe GLRenderer)) $ \mp -> case mp of
+        Nothing -> return V.empty
+        Just p  -> do
+            let env = objectEnvironment (glTexUnitMapping p) (uniformSetup input) obj mask
+            Just ic <- readIORef $ glInput p
+            case icSlotMapInputToPipeline ic ! slotIdx of
+                Nothing         -> return V.empty -- this slot is not used in that pipeline
+                Just pSlotIdx   -> do
+                    let emptyV = V.replicate (V.length $ glPrograms p) []
+                    return $ emptyV // [(prgIdx,createObjectCommands_ env (glPrograms p ! prgIdx))
+                                        | prgIdx <- glSlotPrograms p ! pSlotIdx]
+    writeIORef cmdsRef cmds
+    return obj
+
+newRing :: GLStorage -> Int -> IO Ring
+newRing storage sz = do
+    bo <- alloca $! \pbo -> glGenBuffers 1 pbo >> peek pbo
+    glBindBuffer GL_ARRAY_BUFFER bo
+    let bufsize = 3 * fromIntegral sz
+        byteCount = 4 * bufsize
+    glBufferData GL_ARRAY_BUFFER byteCount nullPtr GL_DYNAMIC_DRAW
+    glBindBuffer GL_ARRAY_BUFFER 0
+    startRef <- newIORef 0
+    sizeRef <- newIORef 0
+    let buffer = Buffer (V.singleton $ ArrayDesc ArrFloat (fromIntegral bufsize) 0 (fromIntegral byteCount))
+                        bo
+        gd = GPUData PointList (Map.singleton "position" $ Stream Attribute_V3F buffer 0 0 sz) Nothing [buffer]
+    obj <- addToObjectArray storage "Points" [] gd
+    readIORef (objCommands obj) >>= mapM_ print
+        -- [[GLSetUniform 0 GLUniform M44F,GLSetVertexAttribArray 0 5 3 5126 0x0000000000000000,GLDrawArrays 0 0 1],[],[],[]]
+    let r = Ring
+            { rBufferObject = bo
+            , rStorage      = storage
+            , rObject       = obj
+            , rSize         = sizeRef
+            , rStart        = startRef
+            , ringCapacity  = bufsize
+            }
+    updateRingCommands r
+    return r
+
+updateRingCommands :: Ring -> IO ()
+updateRingCommands r = do
+    start <- fmap (fromIntegral . (`div` 3)) $ readIORef $ rStart r
+    size  <- fmap (fromIntegral . (`div` 3)) $ readIORef $ rSize r
+    let mask 0   = []
+        mask cnt = if start + size < cnt
+                    then [(start,size)]
+                    else [(0,start + size - cnt), (start,cnt-start)]
+    updateCommands (rStorage r) (rObject r) mask
+    readIORef (objCommands $ rObject r) >>= mapM_ print
+    return ()
+
+pushBack :: Ring -> Float -> Float -> Float -> IO ()
+pushBack r x y z = allocaArray 3 $ \ptr -> do
+    pokeElemOff ptr 0 x
+    pokeElemOff ptr 1 y
+    pokeElemOff ptr 2 z
+    start <- readIORef $ rStart r
+    writeIORef (rStart r) (mod (start + 3) (ringCapacity r))
+    glBindBuffer GL_ARRAY_BUFFER (rBufferObject r)
+    glBufferSubData GL_ARRAY_BUFFER (4*start) (4*3) ptr
+    glBindBuffer GL_ARRAY_BUFFER 0
+    glFlush
+    glFinish
+    sz <- readIORef (rSize r)
+    putStrLn $ "pushBack "++show (sz,start,(x,y,z))
+    when (sz < ringCapacity r) $ do
+        writeIORef (rSize r) (sz + 3)
+    updateRingCommands r
+
+updateRingUniforms :: GLStorage -> Ring -> IO ()
+updateRingUniforms _ _ = return ()
diff --git a/hello_obj2.lc b/hello_obj2.lc
index 8e9bbe0..1181943 100644
--- a/hello_obj2.lc
+++ b/hello_obj2.lc
@@ -19,8 +19,7 @@ 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)
+          (points :: PrimitiveStream Point ((Vec 3 Float)))
 
     = imageFrame (emptyDepthImage 1, emptyColorImage (V4 0 0 0.4 1))
   `overlay`
@@ -46,23 +45,12 @@ makeFrame (cubemap :: TextureCube)
                                 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
+      points
+    & mapPrimitives (\((p)) -> let p' = point p -- coordmap cam $ point 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)
@@ -86,6 +74,5 @@ main = renderFrame $
              (Texture2DSlot "diffuseTexture")
              (fetch "objects" (Attribute "position", Attribute "normal", Attribute "uvw"))
              (fetch "plane"   ((Attribute "position")))
-             (Uniform "PointsMax")
-             (Uniform "PointsStart")
+             (fetch "Points" ((Attribute "position")))