summaryrefslogtreecommitdiff
path: root/PointPrimitiveRing.hs
diff options
context:
space:
mode:
Diffstat (limited to 'PointPrimitiveRing.hs')
-rw-r--r--PointPrimitiveRing.hs172
1 files changed, 11 insertions, 161 deletions
diff --git a/PointPrimitiveRing.hs b/PointPrimitiveRing.hs
index ff55df5..10040d5 100644
--- a/PointPrimitiveRing.hs
+++ b/PointPrimitiveRing.hs
@@ -24,10 +24,12 @@ import LambdaCube.GL.Util
24import LambdaCube.GL.Input.Type 24import LambdaCube.GL.Input.Type
25import LambdaCube.GL.Input hiding (createObjectCommands) 25import LambdaCube.GL.Input hiding (createObjectCommands)
26 26
27import Graphics.GL.Core33 27-- import Graphics.GL.Core33
28
29import MaskableStream
28 30
29data Ring = Ring 31data Ring = Ring
30 { rBufferObject :: Word32 32 { rBufferObject :: Buffer
31 , rStorage :: GLStorage 33 , rStorage :: GLStorage
32 , rObject :: Object 34 , rObject :: Object
33 , rSize :: IORef CPtrdiff -- Current count of Floats in the ring buffer. 35 , rSize :: IORef CPtrdiff -- Current count of Floats in the ring buffer.
@@ -35,172 +37,22 @@ data Ring = Ring
35 , ringCapacity :: CPtrdiff -- Maximum number of floats in buffer. 37 , ringCapacity :: CPtrdiff -- Maximum number of floats in buffer.
36 } 38 }
37 39
38addToObjectArray :: GLStorage
39 -> String -- ^ Slot name for a PrimitiveStream.
40 -> [String] -- ^ Uniform names. IORefs will be put in 'objUniSetup'.
41 -> GPUData
42 -> IO Object
43addToObjectArray input slotName objUniNames (GPUData prim streams indices _) = do
44 let ObjectArraySchema _ slotStreams = fromMaybe (error $ "addMeshToObjectArray - missing object array: " ++ slotName)
45 $ Map.lookup slotName $! objectArrays $! schema input
46 addObject input slotName prim indices (Map.intersection streams slotStreams) objUniNames
47
48setUniformCommand :: (String -> GLUniform)
49 -> (String,GLint)
50 -> GLObjectCommand
51setUniformCommand ulookup (n,i) = GLSetUniform i (ulookup n)
52
53bindTextureCommand :: (String -> IORef GLint)
54 -> (String -> GLUniform)
55 -> String
56 -> GLObjectCommand
57bindTextureCommand tlookup ulookup n = GLBindTexture (inputTypeToTextureTarget $ uniInputType u) (tlookup n) u
58 where
59 u = ulookup n
60 uniInputType (GLTypedUniform ty _) = unwitnessType ty
61 uniInputType (GLUniform r) = objectType r
62
63
64lookupOrLookup :: (Ord k, Show k) => String -> Map.Map k a -> Map.Map k a -> k -> a
65lookupOrLookup callsite objUnis topUnis n = Map.findWithDefault (topUni n) n objUnis
66 where
67 topUni n = Map.findWithDefault (error $ "internal error ("++callsite++"): " ++ show n) n topUnis
68
69
70classifyStreamType :: StreamType -> ( GLint
71 , GLuint -> GLuint -> GLint -> GLenum -> Ptr () -> GLObjectCommand)
72classifyStreamType = \case
73 Attribute_Word -> ( 1 , GLSetVertexAttribIArray )
74 Attribute_V2U -> ( 2 , GLSetVertexAttribIArray )
75 Attribute_V3U -> ( 3 , GLSetVertexAttribIArray )
76 Attribute_V4U -> ( 4 , GLSetVertexAttribIArray )
77 Attribute_Int -> ( 1 , GLSetVertexAttribIArray )
78 Attribute_V2I -> ( 2 , GLSetVertexAttribIArray )
79 Attribute_V3I -> ( 3 , GLSetVertexAttribIArray )
80 Attribute_V4I -> ( 4 , GLSetVertexAttribIArray )
81 Attribute_Float -> ( 1 , GLSetVertexAttribArray )
82 Attribute_V2F -> ( 2 , GLSetVertexAttribArray )
83 Attribute_V3F -> ( 3 , GLSetVertexAttribArray )
84 Attribute_V4F -> ( 4 , GLSetVertexAttribArray )
85 Attribute_M22F -> ( 4 , GLSetVertexAttribArray )
86 Attribute_M23F -> ( 6 , GLSetVertexAttribArray )
87 Attribute_M24F -> ( 8 , GLSetVertexAttribArray )
88 Attribute_M32F -> ( 6 , GLSetVertexAttribArray )
89 Attribute_M33F -> ( 9 , GLSetVertexAttribArray )
90 Attribute_M34F -> ( 12 , GLSetVertexAttribArray )
91 Attribute_M42F -> ( 8 , GLSetVertexAttribArray )
92 Attribute_M43F -> ( 12 , GLSetVertexAttribArray )
93 Attribute_M44F -> ( 16 , GLSetVertexAttribArray )
94
95drawElementsCommand :: GLenum -> IndexStream Buffer -> GLObjectCommand
96drawElementsCommand prim (IndexStream (Buffer arrs bo) arrIdx start idxCount)
97 = GLDrawElements prim (fromIntegral idxCount) idxType bo ptr
98 where
99 ArrayDesc arrType arrLen arrOffs arrSize = arrs ! arrIdx
100 idxType = arrayTypeToGLType arrType
101 ptr = intPtrToPtr $! fromIntegral (arrOffs + start * sizeOfArrayType arrType)
102
103objectDrawStyle :: (GLsizei -> [(GLint,GLsizei)]) -- ^ mask, normally \x -> [(0,x)]
104 -> Object
105 -> Either [(GLint,GLsizei)] (IndexStream Buffer)
106objectDrawStyle streamMask obj = case objIndices obj of
107 Nothing -> Left $ let cnt = head [c | Stream _ _ _ _ c <- Map.elems (objAttributes obj)]
108 in streamMask $ fromIntegral cnt
109 Just idxStream -> Right idxStream
110
111
112createObjectCommands :: Map.Map String (IORef GLint) -> Map.Map String GLUniform -> Object -> GLProgram -> [GLObjectCommand]
113createObjectCommands texUnitMap topUnis obj prg =
114 createObjectCommands_ (objectEnvironment texUnitMap topUnis obj (pure . ((,) 0))) prg
115
116createObjectCommands_ :: ObjectEnvironment -> GLProgram -> [GLObjectCommand]
117createObjectCommands_ ObjectEnvironment{..} prg = concat
118 [ map (setUniformCommand ulookup) $ Map.toList (inputUniforms prg)
119 , map (bindTextureCommand tlookup ulookup) $ toList (inputTextureUniforms prg)
120 , map (setVertexAttribCommmand alookup) $ Map.elems (inputStreams prg)
121 , case envDrawStyle of
122 Left ranges -> map (uncurry $ GLDrawArrays envPrim) ranges
123 Right indexed -> pure $ drawElementsCommand envPrim indexed
124 ]
125
126data ObjectEnvironment = ObjectEnvironment
127 { envPrim :: GLenum
128 , envDrawStyle :: Either [(GLint,GLsizei)] (IndexStream Buffer)
129 , tlookup :: String -> IORef GLint
130 , ulookup :: String -> GLUniform
131 , alookup :: String -> Stream Buffer
132 }
133
134objectEnvironment :: Map.Map String (IORef GLint)
135 -> Map.Map String GLUniform
136 -> Object
137 -> (GLsizei -> [(GLint, GLsizei)])
138 -> ObjectEnvironment
139objectEnvironment texUnitMap topUnis obj streamMask = ObjectEnvironment
140 { envPrim = primitiveToGLType $ objPrimitive obj
141 , envDrawStyle = objectDrawStyle streamMask obj
142 , tlookup = \n -> Map.findWithDefault (error $ "missing texture unit: " ++ show n) n texUnitMap
143 , ulookup = lookupOrLookup "missing uniform: " (objUniSetup obj) topUnis
144 , alookup = \n -> Map.findWithDefault (error $ "missing attribute: " ++ n) n $ objAttributes obj
145 }
146
147
148setVertexAttribCommmand :: (t -> Stream Buffer) -> (GLuint, t) -> GLObjectCommand
149setVertexAttribCommmand alookup (i,name) = case alookup name of
150 Stream ty (Buffer arrs bo) arrIdx start len -> mkAttrCmd i bo n (arrayTypeToGLType arrType) (intPtrToPtr $! offset)
151 where
152 (n, mkAttrCmd) = classifyStreamType ty
153 ArrayDesc arrType arrLen arrOffs arrSize = arrs ! arrIdx
154 offset = fromIntegral (arrOffs + start * fromIntegral n * sizeOfArrayType arrType)
155
156 -- constant generic attribute
157 constAttr -> GLSetVertexAttrib i constAttr
158
159updateCommands :: GLStorage
160 -> Object
161 -> (GLsizei -> [(GLint,GLsizei)])
162 -> IO Object
163updateCommands input obj mask = do
164 let cmdsRef = objCommands obj :: IORef (V.Vector (V.Vector [GLObjectCommand]))
165 slotIdx = objSlot obj :: Int
166 ppls <- readIORef $ pipelines input
167 cmds <- V.forM (ppls :: V.Vector (Maybe GLRenderer)) $ \mp -> case mp of
168 Nothing -> return V.empty
169 Just p -> do
170 let env = objectEnvironment (glTexUnitMapping p) (uniformSetup input) obj mask
171 Just ic <- readIORef $ glInput p
172 case icSlotMapInputToPipeline ic ! slotIdx of
173 Nothing -> return V.empty -- this slot is not used in that pipeline
174 Just pSlotIdx -> do
175 let emptyV = V.replicate (V.length $ glPrograms p) []
176 return $ emptyV // [(prgIdx,createObjectCommands_ env (glPrograms p ! prgIdx))
177 | prgIdx <- glSlotPrograms p ! pSlotIdx]
178 writeIORef cmdsRef cmds
179 return obj
180
181newRing :: GLStorage -> Int -> IO Ring 40newRing :: GLStorage -> Int -> IO Ring
182newRing storage sz = do 41newRing storage sz = do
183 bo <- alloca $! \pbo -> glGenBuffers 1 pbo >> peek pbo
184 glBindBuffer GL_ARRAY_BUFFER bo
185 let bufsize = 3 * fromIntegral sz
186 byteCount = 4 * bufsize
187 glBufferData GL_ARRAY_BUFFER byteCount nullPtr GL_DYNAMIC_DRAW
188 glBindBuffer GL_ARRAY_BUFFER 0
189 startRef <- newIORef 0 42 startRef <- newIORef 0
190 sizeRef <- newIORef 0 43 sizeRef <- newIORef 0
191 let buffer = Buffer (V.singleton $ ArrayDesc ArrFloat (fromIntegral bufsize) 0 (fromIntegral byteCount)) 44 gd <- uploadDynamicBuffer sz "position"
192 bo
193 gd = GPUData PointList (Map.singleton "position" $ Stream Attribute_V3F buffer 0 0 sz) Nothing [buffer]
194 obj <- addToObjectArray storage "Points" [] gd 45 obj <- addToObjectArray storage "Points" [] gd
195 readIORef (objCommands obj) >>= mapM_ print 46 readIORef (objCommands obj) >>= mapM_ print
196 -- [[GLSetUniform 0 GLUniform M44F,GLSetVertexAttribArray 0 5 3 5126 0x0000000000000000,GLDrawArrays 0 0 1],[],[],[]] 47 -- [[GLSetUniform 0 GLUniform M44F,GLSetVertexAttribArray 0 5 3 5126 0x0000000000000000,GLDrawArrays 0 0 1],[],[],[]]
197 let r = Ring 48 let bo = streamBuffer $ dStreams gd Map.! "position"
49 r = Ring
198 { rBufferObject = bo 50 { rBufferObject = bo
199 , rStorage = storage 51 , rStorage = storage
200 , rObject = obj 52 , rObject = obj
201 , rSize = sizeRef 53 , rSize = sizeRef
202 , rStart = startRef 54 , rStart = startRef
203 , ringCapacity = bufsize 55 , ringCapacity = 3 * fromIntegral sz
204 } 56 }
205 updateRingCommands r 57 updateRingCommands r
206 return r 58 return r
@@ -224,11 +76,9 @@ pushBack r x y z = allocaArray 3 $ \ptr -> do
224 pokeElemOff ptr 2 z 76 pokeElemOff ptr 2 z
225 start <- readIORef $ rStart r 77 start <- readIORef $ rStart r
226 writeIORef (rStart r) (mod (start + 3) (ringCapacity r)) 78 writeIORef (rStart r) (mod (start + 3) (ringCapacity r))
227 glBindBuffer GL_ARRAY_BUFFER (rBufferObject r) 79 incrementalUpdateBuffer (rBufferObject r) (4*start) (4*3) ptr
228 glBufferSubData GL_ARRAY_BUFFER (4*start) (4*3) ptr 80 -- glFlush
229 glBindBuffer GL_ARRAY_BUFFER 0 81 -- glFinish
230 glFlush
231 glFinish
232 sz <- readIORef (rSize r) 82 sz <- readIORef (rSize r)
233 putStrLn $ "pushBack "++show (sz,start,(x,y,z)) 83 putStrLn $ "pushBack "++show (sz,start,(x,y,z))
234 when (sz < ringCapacity r) $ do 84 when (sz < ringCapacity r) $ do
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-02 00:07:39 +0000