path: root/PointPrimitiveRing.hs

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