1 files changed, 239 insertions, 0 deletions

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