lambdacube-gl 0.2.2 → 0.5.2.4
raw patch · 31 files changed
Files
- CHANGELOG.md +19/−0
- LICENSE +22/−20
- examples/Hello.hs +101/−0
- examples/HelloEmbedded.hs +103/−0
- examples/HelloOBJ.hs +156/−0
- examples/MtlParser.hs +74/−0
- examples/cube.mtl +13/−0
- examples/cube.obj +47/−0
- examples/hello.json +1/−0
- examples/hello.lc +16/−0
- examples/hello_obj.json +1/−0
- examples/hello_obj.lc +18/−0
- examples/logo.png binary
- lambdacube-gl.cabal +134/−75
- src/LambdaCube/GL.hs +105/−0
- src/LambdaCube/GL/Backend.hs +898/−0
- src/LambdaCube/GL/Data.hs +107/−0
- src/LambdaCube/GL/Input.hs +435/−0
- src/LambdaCube/GL/Mesh.hs +118/−0
- src/LambdaCube/GL/Type.hs +519/−0
- src/LambdaCube/GL/Util.hs +756/−0
- src/lib/LambdaCube/GL.hs +0/−297
- src/lib/LambdaCube/GL/Backend.hs +0/−427
- src/lib/LambdaCube/GL/Compile.hs +0/−589
- src/lib/LambdaCube/GL/Data.hs +0/−336
- src/lib/LambdaCube/GL/GLSLCodeGen.hs +0/−867
- src/lib/LambdaCube/GL/Mesh.hs +0/−229
- src/lib/LambdaCube/GL/Type.hs +0/−476
- src/lib/LambdaCube/GL/Util.hs +0/−990
- testclient/TestData.hs +242/−0
- testclient/client.hs +191/−0
+ CHANGELOG.md view
@@ -0,0 +1,19 @@+# 0.5.2.3++- fix: [Render to texture is broken](https://github.com/lambdacube3d/lambdacube-gl/issues/5)+++# 0.5.2.2++- update time version constraint+++# 0.5.2.0++- minor optimization: less draw calls by grouping and state tracking+- expose `sortSlotObjects` to control the object's render order+++# 0.5.1.2++- relax base version constraint: >=4.7 && <5
LICENSE view
@@ -1,28 +1,30 @@-Copyright (c) 2009-2013, Csaba Hruska+Copyright (c) 2015, Csaba Hruska, Peter Divianszky+ All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: -1. Redistributions of source code must retain the above copyright notice,- this list of conditions and the following disclaimer.+ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer. -2. Redistributions in binary form must reproduce the above copyright- notice, this list of conditions and the following disclaimer in the- documentation and/or other materials provided with the distribution.+ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution. -3. Neither the name of the author nor the names of its contributors may be- used to endorse or promote products derived from this software without- specific prior written permission.+ * Neither the name of Csaba Hruska, Peter Divianszky nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission. -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"-AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE-IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE-ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE-LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR-CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF-SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS-INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN-CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)-ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE-POSSIBILITY OF SUCH DAMAGE.+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ examples/Hello.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE PackageImports, LambdaCase, OverloadedStrings #-}+import "GLFW-b" Graphics.UI.GLFW as GLFW+import qualified Data.Map as Map+import qualified Data.Vector as V++import LambdaCube.GL as LambdaCubeGL -- renderer+import LambdaCube.GL.Mesh as LambdaCubeGL++import Codec.Picture as Juicy++import Data.Aeson+import qualified Data.ByteString as SB++----------------------------------------------------+-- See: http://lambdacube3d.com/getting-started+----------------------------------------------------++main :: IO ()+main = do+ Just pipelineDesc <- decodeStrict <$> SB.readFile "hello.json"++ win <- initWindow "LambdaCube 3D DSL Hello World" 640 640++ -- setup render data+ let inputSchema = makeSchema $ do+ defObjectArray "objects" Triangles $ do+ "position" @: Attribute_V2F+ "uv" @: Attribute_V2F+ defUniforms $ do+ "time" @: Float+ "diffuseTexture" @: FTexture2D++ storage <- LambdaCubeGL.allocStorage inputSchema++ -- upload geometry to GPU and add to pipeline input+ LambdaCubeGL.uploadMeshToGPU triangleA >>= LambdaCubeGL.addMeshToObjectArray storage "objects" []+ LambdaCubeGL.uploadMeshToGPU triangleB >>= LambdaCubeGL.addMeshToObjectArray storage "objects" []++ -- load image and upload texture+ Right img <- Juicy.readImage "logo.png"+ textureData <- LambdaCubeGL.uploadTexture2DToGPU img++ -- allocate GL pipeline+ renderer <- LambdaCubeGL.allocRenderer pipelineDesc+ LambdaCubeGL.setStorage renderer storage >>= \case -- check schema compatibility+ Just err -> putStrLn err+ Nothing -> loop+ where loop = do+ -- update graphics input+ GLFW.getWindowSize win >>= \(w,h) -> LambdaCubeGL.setScreenSize storage (fromIntegral w) (fromIntegral h)+ LambdaCubeGL.updateUniforms storage $ do+ "diffuseTexture" @= return textureData+ "time" @= do+ Just t <- GLFW.getTime+ return (realToFrac t :: Float)+ -- render+ LambdaCubeGL.renderFrame renderer+ GLFW.swapBuffers win+ GLFW.pollEvents++ let keyIsPressed k = fmap (==KeyState'Pressed) $ GLFW.getKey win k+ escape <- keyIsPressed Key'Escape+ if escape then return () else loop++ LambdaCubeGL.disposeRenderer renderer+ LambdaCubeGL.disposeStorage storage+ GLFW.destroyWindow win+ GLFW.terminate++-- geometry data: triangles+triangleA :: LambdaCubeGL.Mesh+triangleA = Mesh+ { mAttributes = Map.fromList+ [ ("position", A_V2F $ V.fromList [V2 1 1, V2 1 (-1), V2 (-1) (-1)])+ , ("uv", A_V2F $ V.fromList [V2 1 1, V2 0 1, V2 0 0])+ ]+ , mPrimitive = P_Triangles+ }++triangleB :: LambdaCubeGL.Mesh+triangleB = Mesh+ { mAttributes = Map.fromList+ [ ("position", A_V2F $ V.fromList [V2 1 1, V2 (-1) (-1), V2 (-1) 1])+ , ("uv", A_V2F $ V.fromList [V2 1 1, V2 0 0, V2 1 0])+ ]+ , mPrimitive = P_Triangles+ }++initWindow :: String -> Int -> Int -> IO Window+initWindow title width height = do+ GLFW.init+ GLFW.defaultWindowHints+ mapM_ GLFW.windowHint+ [ WindowHint'ContextVersionMajor 3+ , WindowHint'ContextVersionMinor 3+ , WindowHint'OpenGLProfile OpenGLProfile'Core+ , WindowHint'OpenGLForwardCompat True+ ]+ Just win <- GLFW.createWindow width height title Nothing Nothing+ GLFW.makeContextCurrent $ Just win+ return win
+ examples/HelloEmbedded.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE PackageImports, LambdaCase, OverloadedStrings #-}+import "GLFW-b" Graphics.UI.GLFW as GLFW+import qualified Data.Map as Map+import qualified Data.Vector as V++import LambdaCube.GL as LambdaCubeGL -- renderer+import LambdaCube.GL.Mesh as LambdaCubeGL++import Codec.Picture as Juicy++import LambdaCube.Compiler as LambdaCube -- compiler++----------------------------------------------------+-- See: http://lambdacube3d.com/getting-started+----------------------------------------------------++main :: IO ()+main = do+ -- compile hello.lc to graphics pipeline description+ pipelineDesc <- LambdaCube.compileMain ["."] OpenGL33 "hello.lc" >>= \case+ Left err -> fail $ "compile error:\n" ++ ppShow err+ Right pd -> return pd++ win <- initWindow "LambdaCube 3D DSL Hello World" 640 640++ -- setup render data+ let inputSchema = makeSchema $ do+ defObjectArray "objects" Triangles $ do+ "position" @: Attribute_V2F+ "uv" @: Attribute_V2F+ defUniforms $ do+ "time" @: Float+ "diffuseTexture" @: FTexture2D++ storage <- LambdaCubeGL.allocStorage inputSchema++ -- upload geometry to GPU and add to pipeline input+ LambdaCubeGL.uploadMeshToGPU triangleA >>= LambdaCubeGL.addMeshToObjectArray storage "objects" []+ LambdaCubeGL.uploadMeshToGPU triangleB >>= LambdaCubeGL.addMeshToObjectArray storage "objects" []++ -- load image and upload texture+ Right img <- Juicy.readImage "logo.png"+ textureData <- LambdaCubeGL.uploadTexture2DToGPU img++ -- allocate GL pipeline+ renderer <- LambdaCubeGL.allocRenderer pipelineDesc+ LambdaCubeGL.setStorage renderer storage >>= \case -- check schema compatibility+ Just err -> putStrLn err+ Nothing -> loop+ where loop = do+ -- update graphics input+ GLFW.getWindowSize win >>= \(w,h) -> LambdaCubeGL.setScreenSize storage (fromIntegral w) (fromIntegral h)+ LambdaCubeGL.updateUniforms storage $ do+ "diffuseTexture" @= return textureData+ "time" @= do+ Just t <- GLFW.getTime+ return (realToFrac t :: Float)+ -- render+ LambdaCubeGL.renderFrame renderer+ GLFW.swapBuffers win+ GLFW.pollEvents++ let keyIsPressed k = fmap (==KeyState'Pressed) $ GLFW.getKey win k+ escape <- keyIsPressed Key'Escape+ if escape then return () else loop++ LambdaCubeGL.disposeRenderer renderer+ LambdaCubeGL.disposeStorage storage+ GLFW.destroyWindow win+ GLFW.terminate++-- geometry data: triangles+triangleA :: LambdaCubeGL.Mesh+triangleA = Mesh+ { mAttributes = Map.fromList+ [ ("position", A_V2F $ V.fromList [V2 1 1, V2 1 (-1), V2 (-1) (-1)])+ , ("uv", A_V2F $ V.fromList [V2 1 1, V2 0 1, V2 0 0])+ ]+ , mPrimitive = P_Triangles+ }++triangleB :: LambdaCubeGL.Mesh+triangleB = Mesh+ { mAttributes = Map.fromList+ [ ("position", A_V2F $ V.fromList [V2 1 1, V2 (-1) (-1), V2 (-1) 1])+ , ("uv", A_V2F $ V.fromList [V2 1 1, V2 0 0, V2 1 0])+ ]+ , mPrimitive = P_Triangles+ }++initWindow :: String -> Int -> Int -> IO Window+initWindow title width height = do+ GLFW.init+ GLFW.defaultWindowHints+ mapM_ GLFW.windowHint+ [ WindowHint'ContextVersionMajor 3+ , WindowHint'ContextVersionMinor 3+ , WindowHint'OpenGLProfile OpenGLProfile'Core+ , WindowHint'OpenGLForwardCompat True+ ]+ Just win <- GLFW.createWindow width height title Nothing Nothing+ GLFW.makeContextCurrent $ Just win+ return win
+ examples/HelloOBJ.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE PackageImports, LambdaCase, OverloadedStrings, RecordWildCards #-}+import System.Environment+import "GLFW-b" Graphics.UI.GLFW as GLFW+import Data.Text (unpack,Text)+import Data.List (groupBy,nub)+import Data.Maybe+import Control.Monad+import Data.Map (Map)+import qualified Data.Map as Map+import qualified Data.Vector as V+import qualified Data.ByteString as SB++import LambdaCube.GL as LambdaCubeGL -- renderer+import LambdaCube.GL.Mesh as LambdaCubeGL++import Codec.Picture as Juicy+import Data.Aeson+import Codec.Wavefront++import MtlParser++----------------------------------------------------+-- See: http://lambdacube3d.com/getting-started+----------------------------------------------------++objToMesh :: WavefrontOBJ -> [(Mesh,Maybe Text)]+objToMesh WavefrontOBJ{..} = [(toMesh faceGroup, elMtl . head $ faceGroup) | faceGroup <- faces] where+ faces = groupBy (\a b -> elMtl a == elMtl b) (V.toList objFaces)+ toMesh l = Mesh+ { mAttributes = Map.fromList+ [ ("position", A_V4F position)+ , ("normal", A_V3F normal)+ , ("uvw", A_V3F texcoord)+ ]+ , mPrimitive = P_Triangles+ } where+ triangulate (Triangle a b c) = [a,b,c]+ triangulate (Quad a b c d) = [a,b,c, c,d,a]+ triangulate (Face a b c l) = a : b : c : concatMap (\(x,y) -> [a,x,y]) (zip (c:l) l) -- should work for convex polygons without holes+ defaultPosition = Location 0 0 0 0+ defaultNormal = Normal 0 0 0+ defaultTexCoord = TexCoord 0 0 0+ v !- i = v V.!? (i-1)+ toVertex FaceIndex{..} = ( let Location x y z w = fromMaybe defaultPosition (objLocations !- faceLocIndex) in V4 x y z w+ , let Normal x y z = fromMaybe defaultNormal ((objNormals !-) =<< faceNorIndex) in V3 x y z+ , let TexCoord x y z = fromMaybe defaultTexCoord ((objTexCoords !-) =<< faceTexCoordIndex) in V3 x y z+ )+ (position,normal,texcoord) = V.unzip3 . V.concat . map (V.fromList . map toVertex . triangulate . elValue) $ l+++loadOBJ :: String -> IO (Either String ([(Mesh,Maybe Text)],MtlLib))+loadOBJ fname = fromFile fname >>= \case -- load geometry+ Left err -> putStrLn err >> return (Left err)+ Right obj@WavefrontOBJ{..} -> do+ -- load materials+ mtlLib <- mconcat . V.toList <$> mapM (readMtl . unpack) objMtlLibs+ return $ Right (objToMesh obj,mtlLib)++loadOBJToGPU :: String -> IO (Either String ([(GPUMesh, Maybe Text)], MtlLib))+loadOBJToGPU fname = loadOBJ fname >>= \case+ Left err -> return $ Left err+ Right (subModels,mtlLib) -> do+ gpuSubModels <- forM subModels $ \(mesh,mat) -> LambdaCubeGL.uploadMeshToGPU mesh >>= \a -> return (a,mat)+ return $ Right (gpuSubModels,mtlLib)++uploadMtlLib :: MtlLib -> IO (Map Text (ObjMaterial,TextureData))+uploadMtlLib mtlLib = do+ -- collect used textures+ let usedTextures = nub . concatMap (maybeToList . mtl_map_Kd) $ Map.elems mtlLib+ whiteImage = Juicy.ImageRGB8 $ Juicy.generateImage (\_ _ -> Juicy.PixelRGB8 255 255 255) 1 1+ checkerImage = Juicy.ImageRGB8 $ Juicy.generateImage (\x y -> if mod (x + y) 2 == 0 then Juicy.PixelRGB8 0 0 0 else Juicy.PixelRGB8 255 255 0) 2 2+ checkerTex <- LambdaCubeGL.uploadTexture2DToGPU checkerImage+ -- load images and upload to gpu+ textureLib <- forM (Map.fromList $ zip usedTextures usedTextures) $ \fname -> Juicy.readImage fname >>= \case+ Left err -> putStrLn err >> return checkerTex+ Right img -> LambdaCubeGL.uploadTexture2DToGPU img+ whiteTex <- LambdaCubeGL.uploadTexture2DToGPU whiteImage+ -- pair textures and materials+ return $ (\a -> (a, maybe whiteTex (fromMaybe checkerTex . flip Map.lookup textureLib) . mtl_map_Kd $ a)) <$> mtlLib++addOBJToObjectArray :: GLStorage -> String -> [(GPUMesh, Maybe Text)] -> Map Text (ObjMaterial,TextureData) -> IO [LambdaCubeGL.Object]+addOBJToObjectArray storage slotName objMesh mtlLib = forM objMesh $ \(mesh,mat) -> do+ obj <- LambdaCubeGL.addMeshToObjectArray storage slotName ["diffuseTexture","diffuseColor"] mesh -- diffuseTexture and diffuseColor values can change on each model+ case mat >>= flip Map.lookup mtlLib of+ Nothing -> return ()+ Just (ObjMaterial{..},t) -> LambdaCubeGL.updateObjectUniforms obj $ do+ "diffuseTexture" @= return t -- set model's diffuse texture+ "diffuseColor" @= let (r,g,b) = mtl_Kd in return (V4 r g b mtl_Tr)+ return obj++main :: IO ()+main = do+ Just pipelineDesc <- decodeStrict <$> SB.readFile "hello_obj.json"++ win <- initWindow "LambdaCube 3D DSL OBJ viewer" 640 640++ -- setup render data+ let inputSchema = makeSchema $ do+ defObjectArray "objects" Triangles $ do+ "position" @: Attribute_V4F+ "normal" @: Attribute_V3F+ "uvw" @: Attribute_V3F+ defUniforms $ do+ "time" @: Float+ "diffuseTexture" @: FTexture2D+ "diffuseColor" @: V4F++ storage <- LambdaCubeGL.allocStorage inputSchema++ objName <- head . (++ ["cube.obj"]) <$> getArgs+ -- load OBJ geometry and material descriptions+ Right (objMesh,mtlLib) <- loadOBJToGPU objName+ -- load materials textures+ gpuMtlLib <- uploadMtlLib mtlLib+ -- add OBJ to pipeline input+ addOBJToObjectArray storage "objects" objMesh gpuMtlLib++ -- allocate GL pipeline+ renderer <- LambdaCubeGL.allocRenderer pipelineDesc+ LambdaCubeGL.setStorage renderer storage >>= \case -- check schema compatibility+ Just err -> putStrLn err+ Nothing -> loop+ where loop = do+ -- update graphics input+ GLFW.getWindowSize win >>= \(w,h) -> LambdaCubeGL.setScreenSize storage (fromIntegral w) (fromIntegral h)+ LambdaCubeGL.updateUniforms storage $ do+ "time" @= do+ Just t <- GLFW.getTime+ return (realToFrac t :: Float)+ -- render+ LambdaCubeGL.renderFrame renderer+ GLFW.swapBuffers win+ GLFW.pollEvents++ let keyIsPressed k = fmap (==KeyState'Pressed) $ GLFW.getKey win k+ escape <- keyIsPressed Key'Escape+ if escape then return () else loop++ LambdaCubeGL.disposeRenderer renderer+ LambdaCubeGL.disposeStorage storage+ GLFW.destroyWindow win+ GLFW.terminate++initWindow :: String -> Int -> Int -> IO Window+initWindow title width height = do+ GLFW.init+ GLFW.defaultWindowHints+ mapM_ GLFW.windowHint+ [ WindowHint'ContextVersionMajor 3+ , WindowHint'ContextVersionMinor 3+ , WindowHint'OpenGLProfile OpenGLProfile'Core+ , WindowHint'OpenGLForwardCompat True+ ]+ Just win <- GLFW.createWindow width height title Nothing Nothing+ GLFW.makeContextCurrent $ Just win+ return win
+ examples/MtlParser.hs view
@@ -0,0 +1,74 @@+module MtlParser+ ( ObjMaterial (..)+ , MtlLib+ , parseMtl+ , readMtl+ ) where++import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe+import Control.Monad.State.Strict+import Control.Monad.Writer+import Data.Text (pack,Text)++type Vec3 = (Float,Float,Float)++type MtlLib = Map Text ObjMaterial++data ObjMaterial+ = ObjMaterial+ { mtl_Name :: Text+ , mtl_Ka :: Vec3 -- ambient color+ , mtl_Kd :: Vec3 -- diffuse color+ , mtl_Ks :: Vec3 -- specular color+ , mtl_illum :: Int+ , mtl_Tr :: Float -- transparency+ , mtl_Ns :: Float -- specular exponent+ , mtl_map_Kd :: Maybe String -- diffuse texture file name+ }+ deriving (Eq,Show)++newMaterial name = ObjMaterial+ { mtl_Name = name+ , mtl_Ka = (1, 1, 1)+ , mtl_Kd = (1, 1, 1)+ , mtl_Ks = (0, 0, 0)+ , mtl_illum = 1+ , mtl_Tr = 1+ , mtl_Ns = 0+ , mtl_map_Kd = Nothing+ }++type Mtl = WriterT [ObjMaterial] (State (Maybe ObjMaterial))++readMaybe :: Read a => String -> Maybe a+readMaybe s = case reads s of+ [(val, "")] -> Just val+ _ -> Nothing++readVec3 :: String -> String -> String -> Maybe Vec3+readVec3 r g b = (,,) <$> readMaybe r <*> readMaybe g <*> readMaybe b++setAttr = modify' . fmap+addMaterial = gets maybeToList >>= tell++parseLine :: String -> Mtl ()+parseLine s = case words $ takeWhile (/='#') s of+ ["newmtl",name] -> do+ addMaterial+ put $ Just $ newMaterial $ pack name+ ["map_Kd",textureName] -> setAttr (\s -> s {mtl_map_Kd = Just textureName})+ ["Ka",r,g,b] | Just rgb <- readVec3 r g b -> setAttr (\s -> s {mtl_Ka = rgb})+ ["Kd",r,g,b] | Just rgb <- readVec3 r g b -> setAttr (\s -> s {mtl_Kd = rgb})+ ["Ks",r,g,b] | Just rgb <- readVec3 r g b -> setAttr (\s -> s {mtl_Ks = rgb})+ ["illum",a] | Just v <- readMaybe a -> setAttr (\s -> s {mtl_illum = v})+ ["Tr",a] | Just v <- readMaybe a -> setAttr (\s -> s {mtl_Tr = v})+ ["Ns",a] | Just v <- readMaybe a -> setAttr (\s -> s {mtl_Ns = v})+ _ -> return ()++parseMtl :: String -> MtlLib+parseMtl src = Map.fromList [(mtl_Name m,m) | m <- evalState (execWriterT (mapM_ parseLine (lines src) >> addMaterial)) Nothing]++readMtl :: String -> IO MtlLib+readMtl fname = parseMtl <$> readFile fname
+ examples/cube.mtl view
@@ -0,0 +1,13 @@+newmtl material0+ Ns 10.0000+ Ni 1.5000+ d 1.0000+ Tr 0.0000+ Tf 1.0000 1.0000 1.0000 + illum 2+ Ka 0.0000 0.0000 0.0000+ Kd 0.5880 0.5880 0.5880+ Ks 0.0000 0.0000 0.0000+ Ke 0.0000 0.0000 0.0000+ map_Ka logo.png+ map_Kd logo.png
+ examples/cube.obj view
@@ -0,0 +1,47 @@+# cube.obj+#++o cube+mtllib cube.mtl++v -0.500000 -0.500000 0.500000+v 0.500000 -0.500000 0.500000+v -0.500000 0.500000 0.500000+v 0.500000 0.500000 0.500000+v -0.500000 0.500000 -0.500000+v 0.500000 0.500000 -0.500000+v -0.500000 -0.500000 -0.500000+v 0.500000 -0.500000 -0.500000++vt 0.000000 0.000000+vt 1.000000 0.000000+vt 0.000000 1.000000+vt 1.000000 1.000000++vn 0.000000 0.000000 1.000000+vn 0.000000 1.000000 0.000000+vn 0.000000 0.000000 -1.000000+vn 0.000000 -1.000000 0.000000+vn 1.000000 0.000000 0.000000+vn -1.000000 0.000000 0.000000++g cube+usemtl material0+s 1+f 1/1/1 2/2/1 3/3/1+f 3/3/1 2/2/1 4/4/1+s 2+f 3/1/2 4/2/2 5/3/2+f 5/3/2 4/2/2 6/4/2+s 3+f 5/4/3 6/3/3 7/2/3+f 7/2/3 6/3/3 8/1/3+s 4+f 7/1/4 8/2/4 1/3/4+f 1/3/4 8/2/4 2/4/4+s 5+f 2/1/5 8/2/5 4/3/5+f 4/3/5 8/2/5 6/4/5+s 6+f 7/1/6 1/2/6 5/3/6+f 5/3/6 1/2/6 3/4/6
+ examples/hello.json view
@@ -0,0 +1,1 @@+{"textures":[],"commands":[{"tag":"SetRenderTarget","arg0":0},{"tag":"ClearRenderTarget","arg0":[{"tag":"ClearImage","clearValue":{"tag":"VV4F","arg0":{"w":1,"z":0.4,"x":0.0,"y":0.0}},"imageSemantic":{"tag":"Color"}}]},{"tag":"SetProgram","arg0":0},{"tag":"SetSamplerUniform","arg0":"diffuseTexture","arg1":0},{"tag":"SetRasterContext","arg0":{"arg3":{"tag":"LastVertex"},"tag":"TriangleCtx","arg0":{"tag":"CullNone"},"arg1":{"tag":"PolygonFill"},"arg2":{"tag":"NoOffset"}}},{"tag":"SetAccumulationContext","arg0":{"accViewportName":null,"tag":"AccumulationContext","accOperations":[{"tag":"ColorOp","arg0":{"tag":"NoBlending"},"arg1":{"tag":"VV4B","arg0":{"w":true,"z":true,"x":true,"y":true}}}]}},{"tag":"RenderSlot","arg0":0}],"slots":[{"tag":"Slot","slotPrimitive":{"tag":"Triangles"},"slotStreams":{"uv":{"tag":"V2F"},"position":{"tag":"V2F"}},"slotName":"objects","slotUniforms":{"time":{"tag":"Float"},"diffuseTexture":{"tag":"FTexture2D"}},"slotPrograms":[0]}],"programs":[{"programInTextures":{"diffuseTexture":{"tag":"FTexture2D"}},"tag":"Program","programOutput":[{"tag":"Parameter","ty":{"tag":"V4F"},"name":"f0"}],"programStreams":{"vi2":{"tag":"Parameter","ty":{"tag":"V2F"},"name":"uv"},"vi1":{"tag":"Parameter","ty":{"tag":"V2F"},"name":"position"}},"fragmentShader":"#version 330 core\nvec4 texture2D(sampler2D s\n ,vec2 uv) {\n return texture(s,uv);\n}\nuniform sampler2D diffuseTexture;\nsmooth in vec2 vo1;\nout vec4 f0;\nvoid main() {\n f0 = texture2D (diffuseTexture\n ,vo1);\n}","vertexShader":"#version 330 core\nvec4 texture2D(sampler2D s\n ,vec2 uv) {\n return texture(s,uv);\n}\nuniform float time;\nin vec2 vi1;\nin vec2 vi2;\nsmooth out vec2 vo1;\nmat4 rotMatrixZ(float z0) {\n return mat4 (vec4 (cos (z0)\n ,sin (z0)\n ,0.0\n ,0.0)\n ,vec4 ((0.0) - (sin (z0))\n ,cos (z0)\n ,0.0\n ,0.0)\n ,vec4 (0.0,0.0,1.0,0.0)\n ,vec4 (0.0,0.0,0.0,1.0));\n}\nvoid main() {\n gl_Position = (rotMatrixZ\n (time)) * (vec4 ((vi1).x\n ,(vi1).y\n ,-1.0\n ,1.0));\n vo1 = vi2;\n}","geometryShader":null,"programUniforms":{"time":{"tag":"Float"},"diffuseTexture":{"tag":"FTexture2D"}}}],"samplers":[],"tag":"Pipeline","backend":{"tag":"OpenGL33"},"streams":[],"targets":[{"tag":"RenderTarget","renderTargets":[{"tag":"TargetItem","targetSemantic":{"tag":"Color"},"targetRef":{"tag":"Framebuffer","arg0":{"tag":"Color"}}}]}],"info":"generated by lambdacube-compiler 0.5.0.0"}
+ examples/hello.lc view
@@ -0,0 +1,16 @@+makeFrame (time :: Float)+ (texture :: Texture)+ (prims :: PrimitiveStream Triangle (Vec 2 Float, Vec 2 Float))++ = imageFrame ((emptyColorImage (V4 0 0 0.4 1)))+ `overlay`+ prims+ & mapPrimitives (\(p,uv) -> (rotMatrixZ time *. (V4 p%x p%y (-1) 1), uv))+ & rasterizePrimitives (TriangleCtx CullNone PolygonFill NoOffset LastVertex) ((Smooth))+ & mapFragments (\((uv)) -> ((texture2D (Sampler PointFilter MirroredRepeat texture) uv)))+ & accumulateWith ((ColorOp NoBlending (V4 True True True True)))++main = renderFrame $+ makeFrame (Uniform "time")+ (Texture2DSlot "diffuseTexture")+ (fetch "objects" (Attribute "position", Attribute "uv"))
+ examples/hello_obj.json view
@@ -0,0 +1,1 @@+{"textures":[],"commands":[{"tag":"SetRenderTarget","arg0":0},{"tag":"ClearRenderTarget","arg0":[{"tag":"ClearImage","clearValue":{"tag":"VFloat","arg0":1},"imageSemantic":{"tag":"Depth"}},{"tag":"ClearImage","clearValue":{"tag":"VV4F","arg0":{"w":1,"z":0.4,"x":0.0,"y":0.0}},"imageSemantic":{"tag":"Color"}}]},{"tag":"SetProgram","arg0":0},{"tag":"SetSamplerUniform","arg0":"diffuseTexture","arg1":1},{"tag":"SetRasterContext","arg0":{"arg3":{"tag":"LastVertex"},"tag":"TriangleCtx","arg0":{"tag":"CullBack","arg0":{"tag":"CCW"}},"arg1":{"tag":"PolygonFill"},"arg2":{"tag":"NoOffset"}}},{"tag":"SetAccumulationContext","arg0":{"accViewportName":null,"tag":"AccumulationContext","accOperations":[{"tag":"DepthOp","arg0":{"tag":"Less"},"arg1":true},{"tag":"ColorOp","arg0":{"tag":"NoBlending"},"arg1":{"tag":"VV4B","arg0":{"w":true,"z":true,"x":true,"y":true}}}]}},{"tag":"RenderSlot","arg0":0}],"slots":[{"tag":"Slot","slotPrimitive":{"tag":"Triangles"},"slotStreams":{"normal":{"tag":"V3F"},"uvw":{"tag":"V3F"},"position":{"tag":"V4F"}},"slotName":"objects","slotUniforms":{"time":{"tag":"Float"},"diffuseColor":{"tag":"V4F"},"diffuseTexture":{"tag":"FTexture2D"}},"slotPrograms":[0]}],"programs":[{"programInTextures":{"diffuseTexture":{"tag":"FTexture2D"}},"tag":"Program","programOutput":[{"tag":"Parameter","ty":{"tag":"V4F"},"name":"f0"}],"programStreams":{"vi3":{"tag":"Parameter","ty":{"tag":"V3F"},"name":"uvw"},"vi2":{"tag":"Parameter","ty":{"tag":"V3F"},"name":"normal"},"vi1":{"tag":"Parameter","ty":{"tag":"V4F"},"name":"position"}},"fragmentShader":"#version 330 core\nvec4 texture2D(sampler2D s,vec2 uv) {\n return texture(s,uv);\n}\nuniform vec4 diffuseColor;\nuniform sampler2D diffuseTexture;\nsmooth in vec2 vo1;\nout vec4 f0;\nvoid main() {\n f0 = (diffuseColor) * (texture2D (diffuseTexture,vo1));\n}","vertexShader":"#version 330 core\nvec4 texture2D(sampler2D s,vec2 uv) {\n return texture(s,uv);\n}\nuniform float time;\nin vec4 vi1;\nin vec3 vi2;\nin vec3 vi3;\nsmooth out vec2 vo1;\nvec4 ext0_Float_3(vec3 z0) {\n return vec4 ((z0).x,(z0).y,(z0).z,0.0);\n}\nvec3 neg_VecSFloat3(vec3 z0) {\n return - (z0);\n}\nmat4 translateBefore4(vec3 z0) {\n return mat4 (vec4 (1.0,0.0,0.0,0.0)\n ,vec4 (0.0,1.0,0.0,0.0)\n ,vec4 (0.0,0.0,1.0,0.0)\n ,vec4 ((z0).x,(z0).y,(z0).z,1.0));\n}\nmat4 lookat(vec3 z0,vec3 z1,vec3 z2) {\n return (transpose (mat4 (ext0_Float_3 (normalize (cross (z2\n ,normalize ((z0) - (z1)))))\n ,ext0_Float_3 (cross (normalize ((z0) - (z1))\n ,normalize (cross (z2,normalize ((z0) - (z1))))))\n ,ext0_Float_3 (normalize ((z0) - (z1)))\n ,vec4 (0.0,0.0,0.0,1.0)))) * (translateBefore4 (neg_VecSFloat3 (z0)));\n}\nmat4 perspective(float z0,float z1,float z2,float z3) {\n return mat4 (vec4 (((2.0) * (z0)) / (((z3) * ((z0) * (tan\n ((z2) / (2.0))))) - ((0.0) - ((z3) * ((z0) * (tan ((z2) / (2.0)))))))\n ,0.0\n ,0.0\n ,0.0)\n ,vec4 (0.0\n ,((2.0) * (z0)) / (((z0) * (tan ((z2) / (2.0)))) - ((0.0) - ((z0) * (tan\n ((z2) / (2.0))))))\n ,0.0\n ,0.0)\n ,vec4 ((((z3) * ((z0) * (tan ((z2) / (2.0))))) + ((0.0) - ((z3) * ((z0) * (tan\n ((z2) / (2.0))))))) / (((z3) * ((z0) * (tan\n ((z2) / (2.0))))) - ((0.0) - ((z3) * ((z0) * (tan ((z2) / (2.0)))))))\n ,(((z0) * (tan ((z2) / (2.0)))) + ((0.0) - ((z0) * (tan\n ((z2) / (2.0)))))) / (((z0) * (tan ((z2) / (2.0)))) - ((0.0) - ((z0) * (tan\n ((z2) / (2.0))))))\n ,(0.0) - (((z1) + (z0)) / ((z1) - (z0)))\n ,-1.0)\n ,vec4 (0.0,0.0,(0.0) - ((((2.0) * (z1)) * (z0)) / ((z1) - (z0))),0.0));\n}\nmat4 rotMatrixX(float z0) {\n return mat4 (vec4 (1.0,0.0,0.0,0.0)\n ,vec4 (0.0,cos (z0),sin (z0),0.0)\n ,vec4 (0.0,(0.0) - (sin (z0)),cos (z0),0.0)\n ,vec4 (0.0,0.0,0.0,1.0));\n}\nmat4 rotMatrixZ(float z0) {\n return mat4 (vec4 (cos (z0),sin (z0),0.0,0.0)\n ,vec4 ((0.0) - (sin (z0)),cos (z0),0.0,0.0)\n ,vec4 (0.0,0.0,1.0,0.0)\n ,vec4 (0.0,0.0,0.0,1.0));\n}\nvoid main() {\n gl_Position = (perspective (0.1,100.0,45.0,1.0)) * ((lookat (vec3 (0.0,0.0,5.0)\n ,vec3 (0.0,0.0,0.0)\n ,vec3 (0.0,1.0,0.0))) * ((rotMatrixX (time)) * ((rotMatrixZ (time)) * (vi1))));\n vo1 = vec2 ((vi3).x,(1.0) - ((vi3).y));\n}","geometryShader":null,"programUniforms":{"time":{"tag":"Float"},"diffuseColor":{"tag":"V4F"},"diffuseTexture":{"tag":"FTexture2D"}}}],"samplers":[],"tag":"Pipeline","backend":{"tag":"OpenGL33"},"streams":[],"targets":[{"tag":"RenderTarget","renderTargets":[{"tag":"TargetItem","targetSemantic":{"tag":"Depth"},"targetRef":{"tag":"Framebuffer","arg0":{"tag":"Depth"}}},{"tag":"TargetItem","targetSemantic":{"tag":"Color"},"targetRef":{"tag":"Framebuffer","arg0":{"tag":"Color"}}}]}],"info":"generated by lambdacube-compiler 0.6.0.0"}
+ examples/hello_obj.lc view
@@ -0,0 +1,18 @@+makeFrame (time :: Float)+ (color :: Vec 4 Float)+ (texture :: Texture)+ (prims :: PrimitiveStream Triangle (Vec 4 Float, Vec 3 Float, Vec 3 Float))++ = imageFrame (emptyDepthImage 1, emptyColorImage (V4 0 0 0.4 1))+ `overlay`+ prims+ & mapPrimitives (\(p,n,uvw) -> (perspective 0.1 100 45 1 *. lookat (V3 0 0 5) (V3 0 0 0) (V3 0 1 0) *. rotMatrixX time *. rotMatrixZ time *. p, V2 uvw%x (1 - uvw%y) ))+ & rasterizePrimitives (TriangleCtx CullBack PolygonFill NoOffset LastVertex) ((Smooth))+ & mapFragments (\((uv)) -> ((color * texture2D (Sampler PointFilter MirroredRepeat texture) uv )))+ & accumulateWith (DepthOp Less True, ColorOp NoBlending (V4 True True True True))++main = renderFrame $+ makeFrame (Uniform "time")+ (Uniform "diffuseColor")+ (Texture2DSlot "diffuseTexture")+ (fetch "objects" (Attribute "position", Attribute "normal", Attribute "uvw"))
+ examples/logo.png view
binary file changed (absent → 126891 bytes)
lambdacube-gl.cabal view
@@ -1,82 +1,141 @@-Name: lambdacube-gl-Version: 0.2.2-Cabal-Version: >= 1.10-Build-Type: Simple-License: BSD3-License-File: LICENSE-Author: Csaba Hruska, Gergely Patai-Maintainer: csaba (dot) hruska (at) gmail (dot) com-Stability: experimental-Homepage: http://www.haskell.org/haskellwiki/LambdaCubeEngine-Bug-Reports: https://github.com/csabahruska/lc-dsl/issues-Category: Graphics-Tested-With: GHC == 7.8.3-Synopsis: OpenGL backend for LambdaCube graphics language (main package)-Description:- LambdaCube 3D is a domain specific language and library that makes- it possible to program GPUs in a purely functional style.- Programming with LambdaCube constitutes of composing a data-flow- description, which is compiled into a specialised library. The- language provides a uniform way to define shaders and compositor- chains by treating both streams and framebuffers as first-class- values.- .- As a user of the library you only need to import the "LambdaCube.GL" and- "LambdaCube.GL.Mesh" modules. You should check out the pointers at <http://lambdacube3d.wordpress.com/getting-started/>- to understand the principle behind the library, and also have a good look- at the @lambdacube-samples@ package.+name: lambdacube-gl+version: 0.5.2.4+synopsis: OpenGL 3.3 Core Profile backend for LambdaCube 3D+description: OpenGL 3.3 Core Profile backend for LambdaCube 3D+homepage: http://lambdacube3d.com+license: BSD3+license-file: LICENSE+author: Csaba Hruska, Peter Divianszky+maintainer: csaba.hruska@gmail.com+-- copyright: +category: Graphics+build-type: Simple -Library- default-language: Haskell2010- hs-source-dirs: src/lib- Build-Depends: - base >=4.7 && <5,- binary >=0.7 && <0.8,- bytestring >=0.10 && <0.11,- containers >=0.5 && <0.6,- mtl >=2.2 && <2.3,- vector >=0.10 && <0.11,- prettyclass >=1.0 && <1.1,+extra-source-files: CHANGELOG.md+ examples/Hello.hs+ examples/HelloEmbedded.hs+ examples/HelloOBJ.hs+ examples/MtlParser.hs+ examples/hello.json+ examples/hello.lc+ examples/hello_obj.json+ examples/hello_obj.lc+ examples/logo.png+ examples/cube.obj+ examples/cube.mtl - bytestring-trie >=0.2 && <0.3,- OpenGLRaw >=1.5 && <1.6,- bitmap >= 0.0.2 && <0.0.3,- language-glsl >=0.2 && <0.3,+cabal-version: >=1.10 - lambdacube-core == 0.2.0,- lambdacube-edsl == 0.2.0+Flag example+ Description: Build with example+ Default: False - Exposed-modules:- LambdaCube.GL- LambdaCube.GL.Mesh+Flag testclient+ Description: Build with backend test client+ Default: False - other-modules:- LambdaCube.GL.Backend- LambdaCube.GL.Compile- LambdaCube.GL.Data- LambdaCube.GL.GLSLCodeGen- LambdaCube.GL.Type- LambdaCube.GL.Util+source-repository head+ type: git+ location: https://github.com/lambdacube3d/lambdacube-gl - GHC-options:--- -Werror- -Wall- -fno-warn-missing-signatures- -fno-warn-name-shadowing- -fno-warn-orphans- -fno-warn-unused-binds- -fno-warn-unused-do-bind- -fspec-constr-count=10- -funbox-strict-fields- -O2--- for profiling--- -auto-all--- -caf-all+library+ exposed-modules:+ LambdaCube.GL+ LambdaCube.GL.Backend+ LambdaCube.GL.Data+ LambdaCube.GL.Input+ LambdaCube.GL.Mesh+ LambdaCube.GL.Type+ LambdaCube.GL.Util+ -- other-modules:+ -- other-extensions:+ build-depends:+ base >=4.7 && <5,+ containers >=0.5 && <0.6,+ mtl >=2.2 && <2.3,+ bytestring >=0.10 && <0.11,+ vector >=0.11 && <0.12,+ vector-algorithms >=0.7 && <0.8,+ JuicyPixels >=3.2.7 && <3.3,+ OpenGLRaw >=3.1 && <4,+ lambdacube-ir == 0.3.*+ hs-source-dirs: src+ default-language: Haskell2010 - default-extensions:- DataKinds- DeriveDataTypeable- OverloadedStrings- ParallelListComp- ScopedTypeVariables- TupleSections+executable lambdacube-gl-hello+ if flag(example)+ Buildable: True+ else+ Buildable: False++ hs-source-dirs: examples+ main-is: Hello.hs+ default-language: Haskell2010++ -- CAUTION: When the build-depends change, please bump the git submodule in lambdacube-docker repository+ build-depends:+ base < 5,+ containers >=0.5 && <0.6,+ bytestring >=0.10 && <0.11,+ vector >=0.11 && <0.12,+ JuicyPixels >=3.2 && <3.3,+ aeson >= 0.9 && <1,+ GLFW-b >= 1.4 && <1.5,+ lambdacube-gl,+ lambdacube-ir == 0.3.*++executable lambdacube-gl-hello-obj+ if flag(example)+ Buildable: True+ else+ Buildable: False++ hs-source-dirs: examples+ main-is: HelloOBJ.hs+ default-language: Haskell2010++ -- CAUTION: When the build-depends change, please bump the git submodule in lambdacube-docker repository+ build-depends:+ base < 5,+ containers >=0.5 && <0.6,+ mtl >=2.2 && <2.3,+ text >= 1.2 && <1.3,+ bytestring >=0.10 && <0.11,+ vector >=0.11 && <0.12,+ JuicyPixels >=3.2 && <3.3,+ aeson >= 0.9 && <1,+ GLFW-b >= 1.4 && <1.5,+ wavefront >= 0.7 && <1,+ lambdacube-gl,+ lambdacube-ir == 0.3.*++executable lambdacube-gl-test-client+ if flag(testclient)+ Buildable: True+ else+ Buildable: False++ hs-source-dirs: testclient+ main-is: client.hs+ default-language: Haskell2010++ other-modules: TestData++ -- CAUTION: When the build-depends change, please bump the git submodule in lambdacube-docker repository+ build-depends:+ base < 5,+ containers >=0.5 && <0.6,+ text >= 1.2 && <1.3,+ time >= 1.5 && <1.7,+ exceptions >= 0.8 && <0.9,+ bytestring >=0.10 && <0.11,+ base64-bytestring >=1 && <1.1,+ vector >=0.11 && <0.12,+ JuicyPixels >=3.2 && <3.3,+ aeson >= 0.9 && <1,+ websockets >= 0.9 && <1,+ network >= 2.6 && <2.7,+ OpenGLRaw >=3.1 && <4,+ GLFW-b >= 1.4 && <1.5,+ lambdacube-gl,+ lambdacube-ir == 0.3.*
+ src/LambdaCube/GL.hs view
@@ -0,0 +1,105 @@+module LambdaCube.GL (+ -- Schema+ module LambdaCube.PipelineSchema,+ -- IR+ V2(..),V3(..),V4(..),+ -- Array, Buffer, Texture+ Array(..),+ ArrayType(..),+ Buffer,+ BufferSetter,+ IndexStream(..),+ Stream(..),+ StreamSetter,+ FetchPrimitive(..),+ InputType(..),+ Primitive(..),+ SetterFun,+ TextureData,+ InputSetter(..),+ fromStreamType,+ sizeOfArrayType,+ toStreamType,+ compileBuffer,+ disposeBuffer,+ updateBuffer,+ bufferSize,+ arraySize,+ arrayType,+ uploadTexture2DToGPU,+ uploadTexture2DToGPU',+ disposeTexture,++ -- GL: Renderer, Storage, Object+ GLUniformName,+ GLRenderer,+ GLStorage,+ Object,+ schema,+ schemaFromPipeline,+ allocRenderer,+ disposeRenderer,+ setStorage,+ renderFrame,+ allocStorage,+ disposeStorage,+ uniformSetter,+ addObject,+ removeObject,+ enableObject,+ setObjectOrder,+ objectUniformSetter,+ setScreenSize,+ sortSlotObjects,++ uniformBool,+ uniformV2B,+ uniformV3B,+ uniformV4B,++ uniformWord,+ uniformV2U,+ uniformV3U,+ uniformV4U,++ uniformInt,+ uniformV2I,+ uniformV3I,+ uniformV4I,++ uniformFloat,+ uniformV2F,+ uniformV3F,+ uniformV4F,++ uniformM22F,+ uniformM23F,+ uniformM24F,+ uniformM32F,+ uniformM33F,+ uniformM34F,+ uniformM42F,+ uniformM43F,+ uniformM44F,++ uniformFTexture2D,++ -- schema builder utility functions+ (@:),+ defObjectArray,+ defUniforms,+ makeSchema,++ (@=),+ updateUniforms,+ updateObjectUniforms+) where++import LambdaCube.GL.Type+import LambdaCube.GL.Backend+import LambdaCube.GL.Data+import LambdaCube.GL.Input+import LambdaCube.IR+import LambdaCube.Linear+import LambdaCube.PipelineSchema+import LambdaCube.PipelineSchemaUtil
+ src/LambdaCube/GL/Backend.hs view
@@ -0,0 +1,898 @@+{-# LANGUAGE TupleSections, MonadComprehensions, RecordWildCards, LambdaCase, FlexibleContexts #-}+module LambdaCube.GL.Backend where++import Control.Applicative+import Control.Monad+import Control.Monad.State.Strict+import Data.Maybe+import Data.Bits+import Data.IORef+import Data.IntMap (IntMap)+import Data.Maybe (isNothing,fromJust)+import Data.Map (Map)+import Data.Set (Set)+import Data.Vector (Vector,(!),(//))+import qualified Data.Foldable as F+import qualified Data.IntMap as IntMap+import qualified Data.Map as Map+import qualified Data.List as L+import qualified Data.Set as Set+import qualified Data.Vector as V+import qualified Data.Vector.Storable as SV++import Graphics.GL.Core33+import Foreign+import Foreign.C.String++-- LC IR imports+import LambdaCube.PipelineSchema+import LambdaCube.Linear+import LambdaCube.IR hiding (streamType)+import qualified LambdaCube.IR as IR++import LambdaCube.GL.Type+import LambdaCube.GL.Util++import LambdaCube.GL.Data+import LambdaCube.GL.Input++setupRasterContext :: RasterContext -> IO ()+setupRasterContext = cvt+ where+ cff :: FrontFace -> GLenum+ cff CCW = GL_CCW+ cff CW = GL_CW++ setProvokingVertex :: ProvokingVertex -> IO ()+ setProvokingVertex pv = glProvokingVertex $ case pv of+ FirstVertex -> GL_FIRST_VERTEX_CONVENTION+ LastVertex -> GL_LAST_VERTEX_CONVENTION++ setPointSize :: PointSize -> IO ()+ setPointSize ps = case ps of+ ProgramPointSize -> glEnable GL_PROGRAM_POINT_SIZE+ PointSize s -> do+ glDisable GL_PROGRAM_POINT_SIZE+ glPointSize $ realToFrac s++ cvt :: RasterContext -> IO ()+ cvt (PointCtx ps fts sc) = do+ setPointSize ps+ glPointParameterf GL_POINT_FADE_THRESHOLD_SIZE (realToFrac fts)+ glPointParameterf GL_POINT_SPRITE_COORD_ORIGIN $ realToFrac $ case sc of+ LowerLeft -> GL_LOWER_LEFT+ UpperLeft -> GL_UPPER_LEFT++ cvt (LineCtx lw pv) = do+ glLineWidth (realToFrac lw)+ setProvokingVertex pv++ cvt (TriangleCtx cm pm po pv) = do+ -- cull mode+ case cm of+ CullNone -> glDisable GL_CULL_FACE+ CullFront f -> do+ glEnable GL_CULL_FACE+ glCullFace GL_FRONT+ glFrontFace $ cff f+ CullBack f -> do+ glEnable GL_CULL_FACE+ glCullFace GL_BACK+ glFrontFace $ cff f++ -- polygon mode+ case pm of+ PolygonPoint ps -> do+ setPointSize ps+ glPolygonMode GL_FRONT_AND_BACK GL_POINT+ PolygonLine lw -> do+ glLineWidth (realToFrac lw)+ glPolygonMode GL_FRONT_AND_BACK GL_LINE+ PolygonFill -> glPolygonMode GL_FRONT_AND_BACK GL_FILL++ -- polygon offset+ glDisable GL_POLYGON_OFFSET_POINT+ glDisable GL_POLYGON_OFFSET_LINE+ glDisable GL_POLYGON_OFFSET_FILL+ case po of+ NoOffset -> return ()+ Offset f u -> do+ glPolygonOffset (realToFrac f) (realToFrac u)+ glEnable $ case pm of+ PolygonPoint _ -> GL_POLYGON_OFFSET_POINT+ PolygonLine _ -> GL_POLYGON_OFFSET_LINE+ PolygonFill -> GL_POLYGON_OFFSET_FILL++ -- provoking vertex+ setProvokingVertex pv++setupAccumulationContext :: AccumulationContext -> IO ()+setupAccumulationContext (AccumulationContext n ops) = cvt ops+ where+ cvt :: [FragmentOperation] -> IO ()+ cvt (StencilOp a b c : DepthOp f m : xs) = do+ -- TODO+ cvtC 0 xs+ cvt (StencilOp a b c : xs) = do+ -- TODO+ cvtC 0 xs+ cvt (DepthOp df dm : xs) = do+ -- TODO+ glDisable GL_STENCIL_TEST+ case df == Always && dm == False of+ True -> glDisable GL_DEPTH_TEST+ False -> do+ glEnable GL_DEPTH_TEST+ glDepthFunc $! comparisonFunctionToGLType df+ glDepthMask (cvtBool dm)+ cvtC 0 xs+ cvt xs = do + glDisable GL_DEPTH_TEST+ glDisable GL_STENCIL_TEST+ cvtC 0 xs++ cvtC :: Int -> [FragmentOperation] -> IO ()+ cvtC i (ColorOp b m : xs) = do+ -- TODO+ case b of+ NoBlending -> do+ -- FIXME: requires GL 3.1+ --glDisablei GL_BLEND $ fromIntegral GL_DRAW_BUFFER0 + fromIntegral i+ glDisable GL_BLEND -- workaround+ glDisable GL_COLOR_LOGIC_OP+ BlendLogicOp op -> do+ glDisable GL_BLEND+ glEnable GL_COLOR_LOGIC_OP+ glLogicOp $ logicOperationToGLType op+ Blend cEq aEq scF dcF saF daF (V4 r g b a) -> do+ glDisable GL_COLOR_LOGIC_OP+ -- FIXME: requires GL 3.1+ --glEnablei GL_BLEND $ fromIntegral GL_DRAW_BUFFER0 + fromIntegral i+ glEnable GL_BLEND -- workaround+ glBlendEquationSeparate (blendEquationToGLType cEq) (blendEquationToGLType aEq)+ glBlendFuncSeparate (blendingFactorToGLType scF) (blendingFactorToGLType dcF)+ (blendingFactorToGLType saF) (blendingFactorToGLType daF)+ glBlendColor (realToFrac r) (realToFrac g) (realToFrac b) (realToFrac a)+ let cvt True = 1+ cvt False = 0+ (mr,mg,mb,ma) = case m of+ VBool r -> (cvt r, 1, 1, 1)+ VV2B (V2 r g) -> (cvt r, cvt g, 1, 1)+ VV3B (V3 r g b) -> (cvt r, cvt g, cvt b, 1)+ VV4B (V4 r g b a) -> (cvt r, cvt g, cvt b, cvt a)+ _ -> (1,1,1,1)+ glColorMask mr mg mb ma+ cvtC (i + 1) xs+ cvtC _ [] = return ()++ cvtBool :: Bool -> GLboolean+ cvtBool True = 1+ cvtBool False = 0++clearRenderTarget :: [ClearImage] -> IO ()+clearRenderTarget values = do+ let setClearValue (m,i) value = case value of+ ClearImage Depth (VFloat v) -> do+ glDepthMask 1+ glClearDepth $ realToFrac v+ return (m .|. GL_DEPTH_BUFFER_BIT, i)+ ClearImage Stencil (VWord v) -> do+ glClearStencil $ fromIntegral v+ return (m .|. GL_STENCIL_BUFFER_BIT, i)+ ClearImage Color c -> do+ let (r,g,b,a) = case c of+ VFloat r -> (realToFrac r, 0, 0, 1)+ VV2F (V2 r g) -> (realToFrac r, realToFrac g, 0, 1)+ VV3F (V3 r g b) -> (realToFrac r, realToFrac g, realToFrac b, 1)+ VV4F (V4 r g b a) -> (realToFrac r, realToFrac g, realToFrac b, realToFrac a)+ _ -> (0,0,0,1)+ glColorMask 1 1 1 1+ glClearColor r g b a+ return (m .|. GL_COLOR_BUFFER_BIT, i+1)+ _ -> error "internal error (clearRenderTarget)"+ (mask,_) <- foldM setClearValue (0,0) values+ glClear $ fromIntegral mask+++printGLStatus = checkGL >>= print+printFBOStatus = checkFBO >>= print++compileProgram :: Program -> IO GLProgram+compileProgram p = do+ po <- glCreateProgram+ --putStrLn $ "compile program: " ++ show po+ let createAndAttach src t = do+ o <- glCreateShader t+ compileShader o [src]+ glAttachShader po o+ --putStr " + compile shader source: " >> printGLStatus+ return o++ objs <- sequence $ createAndAttach (vertexShader p) GL_VERTEX_SHADER : createAndAttach (fragmentShader p) GL_FRAGMENT_SHADER : case geometryShader p of+ Nothing -> []+ Just s -> [createAndAttach s GL_GEOMETRY_SHADER]++ forM_ (zip (V.toList $ programOutput p) [0..]) $ \(Parameter n t,i) -> withCString n $ \pn -> do+ --putStrLn ("variable " ++ show n ++ " attached to color number #" ++ show i)+ glBindFragDataLocation po i $ castPtr pn+ --putStr " + setup shader output mapping: " >> printGLStatus++ glLinkProgram po+ log <- printProgramLog po++ -- check link status+ status <- glGetProgramiv1 GL_LINK_STATUS po+ when (status /= fromIntegral GL_TRUE) $ fail $ unlines ["link program failed:",log]++ -- check program input+ (uniforms,uniformsType) <- queryUniforms po+ (attributes,attributesType) <- queryStreams po+ --print uniforms+ --print attributes+ let lcUniforms = (programUniforms p) `Map.union` (programInTextures p)+ lcStreams = fmap ty (programStreams p)+ check a m = and $ map go $ Map.toList m+ where go (k,b) = case Map.lookup k a of+ Nothing -> False+ Just x -> x == b+ unless (check lcUniforms uniformsType) $ fail $ unlines+ [ "shader program uniform input mismatch!"+ , "expected: " ++ show lcUniforms+ , "actual: " ++ show uniformsType+ ]+ unless (check lcStreams attributesType) $ fail $ "shader program stream input mismatch! " ++ show (attributesType,lcStreams)+ -- the public (user) pipeline and program input is encoded by the objectArrays, therefore the programs does not distinct the render and slot textures input+ let inUniNames = programUniforms p+ inUniforms = L.filter (\(n,v) -> Map.member n inUniNames) $ Map.toList $ uniforms+ inTextureNames = programInTextures p+ inTextures = L.filter (\(n,v) -> Map.member n inTextureNames) $ Map.toList $ uniforms+ texUnis = [n | (n,_) <- inTextures, Map.member n (programUniforms p)]+ let prgInTextures = Map.keys inTextureNames+ uniInTextures = map fst inTextures+ {-+ unless (S.fromList prgInTextures == S.fromList uniInTextures) $ fail $ unlines+ [ "shader program uniform texture input mismatch!"+ , "expected: " ++ show prgInTextures+ , "actual: " ++ show uniInTextures+ , "vertex shader:"+ , vertexShader p+ , "geometry shader:"+ , fromMaybe "" (geometryShader p)+ , "fragment shader:"+ , fragmentShader p+ ]+ -}+ --putStrLn $ "uniTrie: " ++ show (Map.keys uniTrie)+ --putStrLn $ "inUniNames: " ++ show inUniNames+ --putStrLn $ "inUniforms: " ++ show inUniforms+ --putStrLn $ "inTextureNames: " ++ show inTextureNames+ --putStrLn $ "inTextures: " ++ show inTextures+ --putStrLn $ "texUnis: " ++ show texUnis+ let valA = Map.toList $ attributes+ valB = Map.toList $ programStreams p+ --putStrLn "------------"+ --print $ Map.toList $ attributes+ --print $ Map.toList $ programStreams p+ let lcStreamName = fmap name (programStreams p)+ return $ GLProgram+ { shaderObjects = objs+ , programObject = po+ , inputUniforms = Map.fromList inUniforms+ , inputTextures = Map.fromList inTextures+ , inputTextureUniforms = Set.fromList $ texUnis+ , inputStreams = Map.fromList [(n,(idx, attrName)) | (n,idx) <- Map.toList $ attributes, let attrName = fromMaybe (error $ "missing attribute: " ++ n) $ Map.lookup n lcStreamName]+ }++compileRenderTarget :: Vector TextureDescriptor -> Vector GLTexture -> RenderTarget -> IO GLRenderTarget+compileRenderTarget texs glTexs (RenderTarget targets) = do+ let isFB (Framebuffer _) = True+ isFB _ = False+ images = [img | TargetItem _ (Just img) <- V.toList targets]+ case all isFB images of+ True -> do+ let bufs = [cvt img | TargetItem Color img <- V.toList targets]+ cvt a = case a of+ Nothing -> GL_NONE+ Just (Framebuffer Color) -> GL_BACK_LEFT+ _ -> error "internal error (compileRenderTarget)!"+ return $ GLRenderTarget+ { framebufferObject = 0+ , framebufferDrawbuffers = Just bufs+ }+ False -> do+ when (any isFB images) $ fail "internal error (compileRenderTarget)!"+ fbo <- alloca $! \pbo -> glGenFramebuffers 1 pbo >> peek pbo+ glBindFramebuffer GL_DRAW_FRAMEBUFFER fbo+ {-+ void glFramebufferTexture1D(GLenum target, GLenum attachment, GLenum textarget, GLuint texture, GLint level);+ GL_TEXTURE_1D+ void glFramebufferTexture2D(GLenum target, GLenum attachment, GLenum textarget, GLuint texture, GLint level);+ GL_TEXTURE_2D+ GL_TEXTURE_RECTANGLE+ GL_TEXTURE_CUBE_MAP_POSITIVE_X+ GL_TEXTURE_CUBE_MAP_POSITIVE_Y+ GL_TEXTURE_CUBE_MAP_POSITIVE_Z+ GL_TEXTURE_CUBE_MAP_NEGATIVE_X+ GL_TEXTURE_CUBE_MAP_NEGATIVE_Y+ GL_TEXTURE_CUBE_MAP_NEGATIVE_Z+ GL_TEXTURE_2D_MULTISAMPLE+ void glFramebufferTextureLayer(GLenum target, GLenum attachment, GLuint texture, GLint level, GLint layer);+ void glFramebufferRenderbuffer(GLenum target, GLenum attachment, GLenum renderbuffertarget, GLuint renderbuffer);+ void glFramebufferTexture(GLenum target, GLenum attachment, GLuint texture, GLint level);+ -}+ let attach attachment (TextureImage texIdx level (Just layer)) =+ glFramebufferTextureLayer GL_DRAW_FRAMEBUFFER attachment (glTextureTarget $ glTexs ! texIdx) (fromIntegral level) (fromIntegral layer)+ attach attachment (TextureImage texIdx level Nothing) = do+ let glTex = glTexs ! texIdx+ tex = texs ! texIdx+ txLevel = fromIntegral level+ txTarget = glTextureTarget glTex+ txObj = glTextureObject glTex+ attachArray = glFramebufferTexture GL_DRAW_FRAMEBUFFER attachment txObj txLevel+ attach2D = glFramebufferTexture2D GL_DRAW_FRAMEBUFFER attachment txTarget txObj txLevel+ case textureType tex of+ Texture1D _ n+ | n > 1 -> attachArray+ | otherwise -> glFramebufferTexture1D GL_DRAW_FRAMEBUFFER attachment txTarget txObj txLevel+ Texture2D _ n+ | n > 1 -> attachArray+ | otherwise -> attach2D+ Texture3D _ -> attachArray+ TextureCube _ -> attachArray+ TextureRect _ -> attach2D+ Texture2DMS _ n _ _+ | n > 1 -> attachArray+ | otherwise -> attach2D+ TextureBuffer _ -> fail "internalError (compileRenderTarget/TextureBuffer)!"+ + go a (TargetItem Stencil (Just img)) = do+ fail "Stencil support is not implemented yet!"+ return a+ go a (TargetItem Depth (Just img)) = do+ attach GL_DEPTH_ATTACHMENT img+ return a+ go (bufs,colorIdx) (TargetItem Color (Just img)) = do+ let attachment = GL_COLOR_ATTACHMENT0 + fromIntegral colorIdx+ attach attachment img+ return (attachment : bufs, colorIdx + 1)+ go (bufs,colorIdx) (TargetItem Color Nothing) = return (GL_NONE : bufs, colorIdx + 1)+ go a _ = return a+ (bufs,_) <- foldM go ([],0) targets+ withArray (reverse bufs) $ glDrawBuffers (fromIntegral $ length bufs)+ return $ GLRenderTarget+ { framebufferObject = fbo+ , framebufferDrawbuffers = Nothing+ }++compileStreamData :: StreamData -> IO GLStream+compileStreamData s = do+ let withV w a f = w a (\p -> f $ castPtr p)+ let compileAttr (VFloatArray v) = Array ArrFloat (V.length v) (withV (SV.unsafeWith . V.convert) v)+ compileAttr (VIntArray v) = Array ArrInt32 (V.length v) (withV (SV.unsafeWith . V.convert) v)+ compileAttr (VWordArray v) = Array ArrWord32 (V.length v) (withV (SV.unsafeWith . V.convert) v)+ --TODO: compileAttr (VBoolArray v) = Array ArrWord32 (length v) (withV withArray v)+ (indexMap,arrays) = unzip [((n,i),compileAttr d) | (i,(n,d)) <- zip [0..] $ Map.toList $ streamData s]+ getLength n = l `div` c+ where+ l = case Map.lookup n $ IR.streamData s of+ Just (VFloatArray v) -> V.length v+ Just (VIntArray v) -> V.length v+ Just (VWordArray v) -> V.length v+ _ -> error "compileStreamData - getLength"+ c = case Map.lookup n $ IR.streamType s of+ Just Bool -> 1+ Just V2B -> 2+ Just V3B -> 3+ Just V4B -> 4+ Just Word -> 1+ Just V2U -> 2+ Just V3U -> 3+ Just V4U -> 4+ Just Int -> 1+ Just V2I -> 2+ Just V3I -> 3+ Just V4I -> 4+ Just Float -> 1+ Just V2F -> 2+ Just V3F -> 3+ Just V4F -> 4+ Just M22F -> 4+ Just M23F -> 6+ Just M24F -> 8+ Just M32F -> 6+ Just M33F -> 9+ Just M34F -> 12+ Just M42F -> 8+ Just M43F -> 12+ Just M44F -> 16+ _ -> error "compileStreamData - getLength element count"+ buffer <- compileBuffer arrays+ cmdRef <- newIORef []+ let toStream (n,i) = (n,Stream+ { streamType = fromMaybe (error $ "missing attribute: " ++ n) $ toStreamType =<< Map.lookup n (IR.streamType s)+ , streamBuffer = buffer+ , streamArrIdx = i+ , streamStart = 0+ , streamLength = getLength n+ })+ return $ GLStream+ { glStreamCommands = cmdRef+ , glStreamPrimitive = case streamPrimitive s of+ Points -> PointList+ Lines -> LineList+ Triangles -> TriangleList+ LinesAdjacency -> LineListAdjacency+ TrianglesAdjacency -> TriangleListAdjacency+ , glStreamAttributes = Map.fromList $ map toStream indexMap+ , glStreamProgram = V.head $ streamPrograms s+ }++createStreamCommands :: Map String (IORef GLint) -> Map String GLUniform -> Map String (Stream Buffer) -> Primitive -> GLProgram -> [GLObjectCommand]+createStreamCommands texUnitMap topUnis attrs primitive prg = streamUniCmds ++ streamCmds ++ [drawCmd]+ where+ -- object draw command+ drawCmd = GLDrawArrays prim 0 (fromIntegral count)+ where+ prim = primitiveToGLType primitive+ count = head [c | Stream _ _ _ _ c <- Map.elems attrs]++ -- object uniform commands+ -- texture slot setup commands+ streamUniCmds = uniCmds ++ texCmds+ where+ uniCmds = [GLSetUniform i u | (n,i) <- uniMap, let u = topUni n]+ uniMap = Map.toList $ inputUniforms prg+ topUni n = Map.findWithDefault (error "internal error (createStreamCommands)!") n topUnis+ texUnis = Set.toList $ inputTextureUniforms prg+ texCmds = [ GLBindTexture (inputTypeToTextureTarget $ uniInputType u) texUnit u+ | n <- texUnis+ , let u = topUni n+ , let texUnit = Map.findWithDefault (error "internal error (createStreamCommands - Texture Unit)") n texUnitMap+ ]+ uniInputType (GLUniform ty _) = ty++ -- object attribute stream commands+ streamCmds = [attrCmd i s | (i,name) <- Map.elems attrMap, let s = fromMaybe (error $ "missing attribute: " ++ name) $ Map.lookup name attrs]+ where + attrMap = inputStreams prg+ attrCmd i s = case s of+ Stream ty (Buffer arrs bo) arrIdx start len -> case ty of+ Attribute_Word -> setIntAttrib 1+ Attribute_V2U -> setIntAttrib 2+ Attribute_V3U -> setIntAttrib 3+ Attribute_V4U -> setIntAttrib 4+ Attribute_Int -> setIntAttrib 1+ Attribute_V2I -> setIntAttrib 2+ Attribute_V3I -> setIntAttrib 3+ Attribute_V4I -> setIntAttrib 4+ Attribute_Float -> setFloatAttrib 1+ Attribute_V2F -> setFloatAttrib 2+ Attribute_V3F -> setFloatAttrib 3+ Attribute_V4F -> setFloatAttrib 4+ Attribute_M22F -> setFloatAttrib 4+ Attribute_M23F -> setFloatAttrib 6+ Attribute_M24F -> setFloatAttrib 8+ Attribute_M32F -> setFloatAttrib 6+ Attribute_M33F -> setFloatAttrib 9+ Attribute_M34F -> setFloatAttrib 12+ Attribute_M42F -> setFloatAttrib 8+ Attribute_M43F -> setFloatAttrib 12+ Attribute_M44F -> setFloatAttrib 16+ where+ setFloatAttrib n = GLSetVertexAttribArray i bo n glType (ptr n)+ setIntAttrib n = GLSetVertexAttribIArray i bo n glType (ptr n)+ ArrayDesc arrType arrLen arrOffs arrSize = arrs ! arrIdx+ glType = arrayTypeToGLType arrType+ ptr compCnt = intPtrToPtr $! fromIntegral (arrOffs + start * fromIntegral compCnt * sizeOfArrayType arrType)++ -- constant generic attribute+ constAttr -> GLSetVertexAttrib i constAttr++allocRenderer :: Pipeline -> IO GLRenderer+allocRenderer p = do+ smps <- V.mapM compileSampler $ samplers p+ texs <- V.mapM compileTexture $ textures p+ trgs <- V.mapM (compileRenderTarget (textures p) texs) $ targets p+ prgs <- V.mapM compileProgram $ programs p+ -- texture unit mapping ioref trie+ -- texUnitMapRefs :: Map UniformName (IORef TextureUnit)+ texUnitMapRefs <- Map.fromList <$> mapM (\k -> (k,) <$> newIORef 0) (Set.toList $ Set.fromList $ concat $ V.toList $ V.map (Map.keys . programInTextures) $ programs p)+ let st = execState (mapM_ (compileCommand texUnitMapRefs smps texs trgs prgs) (V.toList $ commands p)) initCGState+ input <- newIORef Nothing+ -- default Vertex Array Object+ vao <- alloca $! \pvao -> glGenVertexArrays 1 pvao >> peek pvao+ strs <- V.mapM compileStreamData $ streams p+ drawContextRef <- newIORef $ error "missing DrawContext"+ forceSetup <- newIORef True+ vertexBufferRef <- newIORef 0+ indexBufferRef <- newIORef 0+ drawCallCounterRef <- newIORef 0+ return $ GLRenderer+ { glPrograms = prgs+ , glTextures = texs+ , glSamplers = smps+ , glTargets = trgs+ , glCommands = reverse $ drawCommands st+ , glSlotPrograms = V.map (V.toList . slotPrograms) $ IR.slots p+ , glInput = input+ , glSlotNames = V.map slotName $ IR.slots p+ , glVAO = vao+ , glTexUnitMapping = texUnitMapRefs+ , glStreams = strs+ , glDrawContextRef = drawContextRef+ , glForceSetup = forceSetup+ , glVertexBufferRef = vertexBufferRef+ , glIndexBufferRef = indexBufferRef+ , glDrawCallCounterRef = drawCallCounterRef+ }++disposeRenderer :: GLRenderer -> IO ()+disposeRenderer p = do+ setStorage' p Nothing+ V.forM_ (glPrograms p) $ \prg -> do+ glDeleteProgram $ programObject prg+ mapM_ glDeleteShader $ shaderObjects prg+ let targets = glTargets p+ withArray (map framebufferObject $ V.toList targets) $ (glDeleteFramebuffers $ fromIntegral $ V.length targets)+ let textures = glTextures p+ withArray (map glTextureObject $ V.toList textures) $ (glDeleteTextures $ fromIntegral $ V.length textures)+ let samplers = glSamplers p+ withArray (map glSamplerObject $ V.toList samplers) $ (glDeleteSamplers . fromIntegral . V.length $ glSamplers p)+ with (glVAO p) $ (glDeleteVertexArrays 1)++{-+data ObjectArraySchema+ = ObjectArraySchema+ { primitive :: FetchPrimitive+ , attributes :: Trie StreamType+ }+ deriving Show++data PipelineSchema+ = PipelineSchema+ { objectArrays :: Trie ObjectArraySchema+ , uniforms :: Trie InputType+ }+ deriving Show+-}+isSubTrie :: (a -> a -> Bool) -> Map String a -> Map String a -> Bool+isSubTrie eqFun universe subset = and [isMember a (Map.lookup n universe) | (n,a) <- Map.toList subset]+ where+ isMember a Nothing = False+ isMember a (Just b) = eqFun a b++-- TODO: if there is a mismatch thow detailed error message in the excoeption, containing the missing attributes and uniforms+{-+ let sch = schema input+ forM_ uniformNames $ \n -> case Map.lookup n (uniforms sch) of+ Nothing -> throw $ userError $ "Unknown uniform: " ++ show n+ _ -> return ()+ case Map.lookup slotName (objectArrays sch) of+ Nothing -> throw $ userError $ "Unknown slot: " ++ show slotName+ Just (ObjectArraySchema sPrim sAttrs) -> do+ when (sPrim /= (primitiveToFetchPrimitive prim)) $ throw $ userError $+ "Primitive mismatch for slot (" ++ show slotName ++ ") expected " ++ show sPrim ++ " but got " ++ show prim+ let sType = fmap streamToStreamType attribs+ when (sType /= sAttrs) $ throw $ userError $ unlines $ + [ "Attribute stream mismatch for slot (" ++ show slotName ++ ") expected "+ , show sAttrs+ , " but got "+ , show sType+ ]+-}++setStorage :: GLRenderer -> GLStorage -> IO (Maybe String)+setStorage p input' = setStorage' p (Just input')++setStorage' :: GLRenderer -> Maybe GLStorage -> IO (Maybe String)+setStorage' p@GLRenderer{..} input' = do+ -- TODO: check matching input schema+ {-+ case input' of+ Nothing -> return ()+ Just input -> schemaFromPipeline p+ -}+ {-+ deletion:+ - remove pipeline's object commands from used objectArrays+ - remove pipeline from attached pipelines vector+ -}+ readIORef glInput >>= \case+ Nothing -> return ()+ Just InputConnection{..} -> do+ let slotRefs = slotVector icInput+ modifyIORef (pipelines icInput) $ \v -> v // [(icId,Nothing)]+ V.forM_ icSlotMapPipelineToInput $ \slotIdx -> do+ slot <- readIORef (slotRefs ! slotIdx)+ forM_ (objectMap slot) $ \obj -> do+ modifyIORef (objCommands obj) $ \v -> v // [(icId,V.empty)]+ {-+ addition:+ - get an id from pipeline input+ - add to attached pipelines+ - generate slot mappings+ - update used objectArrays, and generate object commands for objects in the related objectArrays+ -}+ case input' of+ Nothing -> writeIORef glInput Nothing >> return Nothing+ Just input -> do+ let pipelinesRef = pipelines input+ oldPipelineV <- readIORef pipelinesRef+ (idx,shouldExtend) <- case V.findIndex isNothing oldPipelineV of+ Nothing -> do+ -- we don't have empty space, hence we double the vector size+ let len = V.length oldPipelineV+ modifyIORef pipelinesRef $ \v -> (V.concat [v,V.replicate len Nothing]) // [(len,Just p)]+ return (len,Just len)+ Just i -> do+ modifyIORef pipelinesRef $ \v -> v // [(i,Just p)]+ return (i,Nothing)+ -- create input connection+ let sm = slotMap input+ pToI = [i | n <- glSlotNames, let i = fromMaybe (error $ "setStorage - missing object array: " ++ n) $ Map.lookup n sm]+ iToP = V.update (V.replicate (Map.size sm) Nothing) (V.imap (\i v -> (v, Just i)) pToI)+ writeIORef glInput $ Just $ InputConnection idx input pToI iToP++ -- generate object commands for related objectArrays+ {-+ for each slot in pipeline:+ map slot name to input slot name+ for each object:+ generate command program vector => for each dependent program:+ generate object commands+ -}+ let slotV = slotVector input+ progV = glPrograms+ --texUnitMap = glTexUnitMapping p+ topUnis = uniformSetup input+ emptyV = V.replicate (V.length progV) []+ extend v = case shouldExtend of+ Nothing -> v+ Just l -> V.concat [v,V.replicate l V.empty]+ V.forM_ (V.zip pToI glSlotPrograms) $ \(slotIdx,prgs) -> do+ slot <- readIORef $ slotV ! slotIdx+ forM_ (objectMap slot) $ \obj -> do+ let cmdV = emptyV // [(prgIdx,createObjectCommands glTexUnitMapping topUnis obj (progV ! prgIdx)) | prgIdx <- prgs]+ modifyIORef (objCommands obj) $ \v -> extend v // [(idx,cmdV)]+ -- generate stream commands+ V.forM_ glStreams $ \s -> do+ writeIORef (glStreamCommands s) $ createStreamCommands glTexUnitMapping topUnis (glStreamAttributes s) (glStreamPrimitive s) (progV ! glStreamProgram s)+ return Nothing+{-+ track state:+ - render target+ - binded textures+-}++{-+ render steps:+ - update uniforms+ - per uniform setup+ - buffer setup (one buffer per object, which has per at least one object uniform)+ - new command: set uniform buffer (binds uniform buffer to program's buffer slot)+ - render slot steps:+ - set uniform buffer or set uniforms separately+ - set vertex and index array+ - call draw command+-}+{-+ storage alternatives:+ - interleaved / separated+ - VAO or VBOs+-}+ {-+ strategy:+ step 1: generate commands for an object+ step 2: sort object merge and do optimization by filtering redundant commands+ -}+{-+ design:+ runtime eleminiation of redundant buffer bind commands and redundant texture bind commands+-}+{-+ track:+ buffer binding on various targets: GL_ARRAY_BUFFER, GL_ELEMENT_ARRAY_BUFFER+ glEnable/DisableVertexAttribArray+-}+renderSlot :: IORef Int -> IORef GLuint -> IORef GLuint -> [GLObjectCommand] -> IO ()+renderSlot glDrawCallCounterRef glVertexBufferRef glIndexBufferRef cmds = forM_ cmds $ \cmd -> do+ let setup ref v m = do+ old <- readIORef ref+ unless (old == v) $ do+ writeIORef ref v+ m++ case cmd of+ GLSetVertexAttribArray idx buf size typ ptr -> do+ setup glVertexBufferRef buf $ glBindBuffer GL_ARRAY_BUFFER buf+ glEnableVertexAttribArray idx+ glVertexAttribPointer idx size typ (fromIntegral GL_FALSE) 0 ptr+ GLSetVertexAttribIArray idx buf size typ ptr -> do+ setup glVertexBufferRef buf $ glBindBuffer GL_ARRAY_BUFFER buf+ glEnableVertexAttribArray idx+ glVertexAttribIPointer idx size typ 0 ptr+ GLDrawArrays mode first count -> glDrawArrays mode first count >> modifyIORef glDrawCallCounterRef succ+ GLDrawElements mode count typ buf indicesPtr -> do+ setup glIndexBufferRef buf $ glBindBuffer GL_ELEMENT_ARRAY_BUFFER buf+ glDrawElements mode count typ indicesPtr+ modifyIORef glDrawCallCounterRef succ+ GLSetUniform idx (GLUniform ty ref) -> setUniform idx ty ref+ GLBindTexture txTarget tuRef (GLUniform _ ref) -> do+ txObjVal <- readIORef ref+ -- HINT: ugly and hacky+ with txObjVal $ \txObjPtr -> do+ txObj <- peek $ castPtr txObjPtr :: IO GLuint+ texUnit <- readIORef tuRef+ glActiveTexture $ GL_TEXTURE0 + fromIntegral texUnit+ glBindTexture txTarget txObj+ --putStrLn $ "to texture unit " ++ show texUnit ++ " texture object " ++ show txObj+ GLSetVertexAttrib idx val -> do+ glDisableVertexAttribArray idx+ setVertexAttrib idx val+ --isOk <- checkGL+ --putStrLn $ isOk ++ " - " ++ show cmd++setupRenderTarget glInput GLRenderTarget{..} = do+ -- set target viewport+ ic' <- readIORef glInput+ case ic' of+ Nothing -> return ()+ Just ic -> do+ let input = icInput ic+ (w,h) <- readIORef $ screenSize input+ glViewport 0 0 (fromIntegral w) (fromIntegral h)+ -- TODO: set FBO target viewport+ glBindFramebuffer GL_DRAW_FRAMEBUFFER framebufferObject+ case framebufferDrawbuffers of+ Nothing -> return ()+ Just bl -> withArray bl $ glDrawBuffers (fromIntegral $ length bl)++setupDrawContext glForceSetup glDrawContextRef glInput new = do+ old <- readIORef glDrawContextRef+ writeIORef glDrawContextRef new+ force <- readIORef glForceSetup+ writeIORef glForceSetup False++ let setup :: Eq a => (GLDrawContext -> a) -> (a -> IO ()) -> IO ()+ setup f m = case force of+ True -> m $ f new+ False -> do+ let a = f new+ unless (a == f old) $ m a++ setup glRenderTarget $ setupRenderTarget glInput+ setup glRasterContext $ setupRasterContext+ setup glAccumulationContext setupAccumulationContext+ setup glProgram glUseProgram++ -- setup texture mapping+ setup glTextureMapping $ mapM_ $ \(textureUnit,GLTexture{..}) -> do+ glActiveTexture (GL_TEXTURE0 + fromIntegral textureUnit)+ glBindTexture glTextureTarget glTextureObject++ -- setup sampler mapping+ setup glSamplerMapping $ mapM_ $ \(textureUnit,GLSampler{..}) -> do+ glBindSampler (GL_TEXTURE0 + fromIntegral textureUnit) glSamplerObject++ -- setup sampler uniform mapping+ forM_ (glSamplerUniformMapping new) $ \(textureUnit,GLSamplerUniform{..}) -> do+ glUniform1i glUniformBinding (fromIntegral textureUnit)+ writeIORef glUniformBindingRef (fromIntegral textureUnit)++renderFrame :: GLRenderer -> IO ()+renderFrame GLRenderer{..} = do+ writeIORef glForceSetup True+ writeIORef glVertexBufferRef 0+ writeIORef glIndexBufferRef 0+ writeIORef glDrawCallCounterRef 0+ glBindVertexArray glVAO+ forM_ glCommands $ \cmd -> do+ case cmd of+ GLClearRenderTarget rt vals -> do+ setupRenderTarget glInput rt+ clearRenderTarget vals+ modifyIORef glDrawContextRef $ \ctx -> ctx {glRenderTarget = rt}++ GLRenderStream ctx streamIdx progIdx -> do+ setupDrawContext glForceSetup glDrawContextRef glInput ctx+ drawcmd <- readIORef (glStreamCommands $ glStreams ! streamIdx)+ renderSlot glDrawCallCounterRef glVertexBufferRef glIndexBufferRef drawcmd++ GLRenderSlot ctx slotIdx progIdx -> do+ input <- readIORef glInput+ case input of+ Nothing -> putStrLn "Warning: No pipeline input!" >> return ()+ Just ic -> do+ let draw setupDone obj = readIORef (objEnabled obj) >>= \case+ False -> return setupDone+ True -> do+ unless setupDone $ setupDrawContext glForceSetup glDrawContextRef glInput ctx+ drawcmd <- readIORef $ objCommands obj+ --putStrLn "Render object"+ renderSlot glDrawCallCounterRef glVertexBufferRef glIndexBufferRef ((drawcmd ! icId ic) ! progIdx)+ return True+ --putStrLn $ "Rendering " ++ show (V.length objs) ++ " objects"+ readIORef (slotVector (icInput ic) ! (icSlotMapPipelineToInput ic ! slotIdx)) >>= \case+ GLSlot _ objs Ordered -> foldM_ (\a -> draw a . snd) False objs+ GLSlot objMap _ _ -> foldM_ draw False objMap++ --isOk <- checkGL+ --putStrLn $ isOk ++ " - " ++ show cmd+ --readIORef glDrawCallCounterRef >>= \n -> putStrLn (show n ++ " draw calls")++data CGState+ = CGState+ { drawCommands :: [GLCommand]+ -- draw context data+ , rasterContext :: RasterContext+ , accumulationContext :: AccumulationContext+ , renderTarget :: GLRenderTarget+ , currentProgram :: ProgramName+ , samplerUniformMapping :: IntMap GLSamplerUniform+ , textureMapping :: IntMap GLTexture+ , samplerMapping :: IntMap GLSampler+ }++initCGState = CGState+ { drawCommands = mempty+ -- draw context data+ , rasterContext = error "compileCommand: missing RasterContext"+ , accumulationContext = error "compileCommand: missing AccumulationContext"+ , renderTarget = error "compileCommand: missing RenderTarget"+ , currentProgram = error "compileCommand: missing Program"+ , samplerUniformMapping = mempty+ , textureMapping = mempty+ , samplerMapping = mempty+ }++type CG a = State CGState a++emit :: GLCommand -> CG ()+emit cmd = modify $ \s -> s {drawCommands = cmd : drawCommands s}++drawContext programs = do+ GLProgram{..} <- (programs !) <$> gets currentProgram+ let f = take (Map.size inputTextures) . IntMap.toList+ GLDrawContext <$> gets rasterContext+ <*> gets accumulationContext+ <*> gets renderTarget+ <*> pure programObject+ <*> gets (f . textureMapping)+ <*> gets (f . samplerMapping)+ <*> gets (f . samplerUniformMapping)++compileCommand :: Map String (IORef GLint) -> Vector GLSampler -> Vector GLTexture -> Vector GLRenderTarget -> Vector GLProgram -> Command -> CG ()+compileCommand texUnitMap samplers textures targets programs cmd = case cmd of+ SetRasterContext rCtx -> modify $ \s -> s {rasterContext = rCtx}+ SetAccumulationContext aCtx -> modify $ \s -> s {accumulationContext = aCtx}+ SetRenderTarget rt -> modify $ \s -> s {renderTarget = targets ! rt}+ SetProgram p -> modify $ \s -> s {currentProgram = p}+ SetSamplerUniform n tu -> do+ p <- currentProgram <$> get+ case Map.lookup n (inputTextures $ programs ! p) of+ Nothing -> return () -- TODO: some drivers does heavy cross stage (vertex/fragment) dead code elimination; fail $ "internal error (SetSamplerUniform)! - " ++ show cmd+ Just i -> case Map.lookup n texUnitMap of+ Nothing -> fail $ "internal error (SetSamplerUniform - IORef)! - " ++ show cmd+ Just r -> modify $ \s -> s {samplerUniformMapping = IntMap.insert tu (GLSamplerUniform i r) $ samplerUniformMapping s}+ SetTexture tu t -> modify $ \s -> s {textureMapping = IntMap.insert tu (textures ! t) $ textureMapping s}+ SetSampler tu i -> modify $ \s -> s {samplerMapping = IntMap.insert tu (maybe (GLSampler 0) (samplers !) i) $ samplerMapping s}++ -- draw commands+ RenderSlot slot -> do+ p <- gets currentProgram+ ctx <- drawContext programs+ emit $ GLRenderSlot ctx slot p+ RenderStream stream -> do+ p <- gets currentProgram+ ctx <- drawContext programs+ emit $ GLRenderStream ctx stream p+ ClearRenderTarget vals -> do+ rt <- gets renderTarget+ emit $ GLClearRenderTarget rt $ V.toList vals+{-+ GenerateMipMap tu -> do+ tb <- textureBinding <$> get+ case IM.lookup tu tb of+ Nothing -> fail "internal error (GenerateMipMap)!"+ Just tex -> return $ GLGenerateMipMap (GL_TEXTURE0 + fromIntegral tu) (glTextureTarget tex)+-}
+ src/LambdaCube/GL/Data.hs view
@@ -0,0 +1,107 @@+module LambdaCube.GL.Data where++import Control.Applicative+import Control.Monad+import Data.IORef+import Data.List as L+import Data.Maybe+import Foreign +--import qualified Data.IntMap as IM+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.Vector as V+import qualified Data.Vector.Storable as SV++--import Control.DeepSeq++import Graphics.GL.Core33+import Data.Word+import Codec.Picture+import Codec.Picture.Types++import LambdaCube.GL.Type+import LambdaCube.GL.Util++-- Buffer+disposeBuffer :: Buffer -> IO ()+disposeBuffer (Buffer _ bo) = withArray [bo] $ glDeleteBuffers 1++compileBuffer :: [Array] -> IO Buffer+compileBuffer arrs = do+ let calcDesc (offset,setters,descs) (Array arrType cnt setter) =+ let size = cnt * sizeOfArrayType arrType+ in (size + offset, (offset,size,setter):setters, ArrayDesc arrType cnt offset size:descs)+ (bufSize,arrSetters,arrDescs) = foldl' calcDesc (0,[],[]) arrs+ bo <- alloca $! \pbo -> glGenBuffers 1 pbo >> peek pbo+ glBindBuffer GL_ARRAY_BUFFER bo+ glBufferData GL_ARRAY_BUFFER (fromIntegral bufSize) nullPtr GL_STATIC_DRAW+ forM_ arrSetters $! \(offset,size,setter) -> setter $! glBufferSubData GL_ARRAY_BUFFER (fromIntegral offset) (fromIntegral size)+ glBindBuffer GL_ARRAY_BUFFER 0+ return $! Buffer (V.fromList $! reverse arrDescs) bo++updateBuffer :: Buffer -> [(Int,Array)] -> IO ()+updateBuffer (Buffer arrDescs bo) arrs = do+ glBindBuffer GL_ARRAY_BUFFER bo+ forM arrs $ \(i,Array arrType cnt setter) -> do+ let ArrayDesc ty len offset size = arrDescs V.! i+ when (ty == arrType && cnt == len) $+ setter $! glBufferSubData GL_ARRAY_BUFFER (fromIntegral offset) (fromIntegral size)+ glBindBuffer GL_ARRAY_BUFFER 0++bufferSize :: Buffer -> Int+bufferSize = V.length . bufArrays++arraySize :: Buffer -> Int -> Int+arraySize buf arrIdx = arrLength $! bufArrays buf V.! arrIdx++arrayType :: Buffer -> Int -> ArrayType+arrayType buf arrIdx = arrType $! bufArrays buf V.! arrIdx++-- Texture+disposeTexture :: TextureData -> IO ()+disposeTexture (TextureData to) = withArray [to] $ glDeleteTextures 1++-- FIXME: Temporary implemenation+uploadTexture2DToGPU :: DynamicImage -> IO TextureData+uploadTexture2DToGPU = uploadTexture2DToGPU' True False True False++uploadTexture2DToGPU' :: Bool -> Bool -> Bool -> Bool -> DynamicImage -> IO TextureData+uploadTexture2DToGPU' isFiltered isSRGB isMip isClamped bitmap' = do+ let bitmap = case bitmap' of+ ImageRGB8 i@(Image w h _) -> bitmap'+ ImageRGBA8 i@(Image w h _) -> bitmap'+ ImageYCbCr8 i@(Image w h _) -> ImageRGB8 $ convertImage i+ di -> ImageRGBA8 $ convertRGBA8 di++ glPixelStorei GL_UNPACK_ALIGNMENT 1+ to <- alloca $! \pto -> glGenTextures 1 pto >> peek pto+ glBindTexture GL_TEXTURE_2D to+ let (width,height) = bitmapSize bitmap+ bitmapSize (ImageRGB8 (Image w h _)) = (w,h)+ bitmapSize (ImageRGBA8 (Image w h _)) = (w,h)+ bitmapSize _ = error "unsupported image type :("+ withBitmap (ImageRGB8 (Image w h v)) f = SV.unsafeWith v $ f (w,h) 3 0+ withBitmap (ImageRGBA8 (Image w h v)) f = SV.unsafeWith v $ f (w,h) 4 0+ withBitmap _ _ = error "unsupported image type :("+ texFilter = if isFiltered then GL_LINEAR else GL_NEAREST+ wrapMode = case isClamped of+ True -> GL_CLAMP_TO_EDGE+ False -> GL_REPEAT+ (minFilter,maxLevel) = case isFiltered && isMip of+ False -> (texFilter,0)+ True -> (GL_LINEAR_MIPMAP_LINEAR, floor $ log (fromIntegral $ max width height) / log 2)+ glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S $ fromIntegral wrapMode+ glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T $ fromIntegral wrapMode+ glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER $ fromIntegral minFilter+ glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER $ fromIntegral texFilter+ glTexParameteri GL_TEXTURE_2D GL_TEXTURE_BASE_LEVEL 0+ glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAX_LEVEL $ fromIntegral maxLevel+ withBitmap bitmap $ \(w,h) nchn 0 ptr -> do+ let internalFormat = fromIntegral $ if isSRGB then (if nchn == 3 then GL_SRGB8 else GL_SRGB8_ALPHA8) else (if nchn == 3 then GL_RGB8 else GL_RGBA8)+ dataFormat = fromIntegral $ case nchn of+ 3 -> GL_RGB+ 4 -> GL_RGBA+ _ -> error "unsupported texture format!"+ glTexImage2D GL_TEXTURE_2D 0 internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat GL_UNSIGNED_BYTE $ castPtr ptr+ when isMip $ glGenerateMipmap GL_TEXTURE_2D+ return $ TextureData to
+ src/LambdaCube/GL/Input.hs view
@@ -0,0 +1,435 @@+{-# LANGUAGE FlexibleContexts, TypeSynonymInstances, FlexibleInstances #-}+module LambdaCube.GL.Input where++import Control.Applicative+import Control.Exception+import Control.Monad+import Control.Monad.Writer+import Data.Maybe+import Data.IORef+import Data.Map (Map)+import Data.IntMap (IntMap)+import Data.Vector (Vector,(//),(!))+import Data.Word+import Data.String+import Foreign+import qualified Data.IntMap as IM+import qualified Data.Set as S+import qualified Data.Map as Map+import qualified Data.Vector as V+import qualified Data.Vector.Algorithms.Intro as I+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as SB++import Graphics.GL.Core33++import LambdaCube.IR as IR+import LambdaCube.Linear as IR+import LambdaCube.PipelineSchema+import LambdaCube.GL.Type as T+import LambdaCube.GL.Util++import qualified LambdaCube.IR as IR++schemaFromPipeline :: IR.Pipeline -> PipelineSchema+schemaFromPipeline a = PipelineSchema (Map.fromList sl) (foldl Map.union Map.empty ul)+ where+ (sl,ul) = unzip [( (sName,ObjectArraySchema sPrimitive (fmap cvt sStreams))+ , sUniforms+ )+ | IR.Slot sName sStreams sUniforms sPrimitive _ <- V.toList $ IR.slots a+ ]+ cvt a = case toStreamType a of+ Just v -> v+ Nothing -> error "internal error (schemaFromPipeline)"++mkUniform :: [(String,InputType)] -> IO (Map GLUniformName InputSetter, Map String GLUniform)+mkUniform l = do+ unisAndSetters <- forM l $ \(n,t) -> do+ (uni, setter) <- mkUniformSetter t+ return ((n,uni),(fromString n,setter))+ let (unis,setters) = unzip unisAndSetters+ return (Map.fromList setters, Map.fromList unis)++allocStorage :: PipelineSchema -> IO GLStorage+allocStorage sch = do+ let sm = Map.fromList $ zip (Map.keys $ objectArrays sch) [0..]+ len = Map.size sm+ (setters,unis) <- mkUniform $ Map.toList $ uniforms sch+ seed <- newIORef 0+ slotV <- V.replicateM len $ newIORef (GLSlot IM.empty V.empty Ordered)+ size <- newIORef (0,0)+ ppls <- newIORef $ V.singleton Nothing+ return $ GLStorage+ { schema = sch+ , slotMap = sm+ , slotVector = slotV+ , objSeed = seed+ , uniformSetter = setters+ , uniformSetup = unis+ , screenSize = size+ , pipelines = ppls+ }++disposeStorage :: GLStorage -> IO ()+disposeStorage _ = putStrLn "not implemented: disposeStorage"++-- object+addObject :: GLStorage -> String -> Primitive -> Maybe (IndexStream Buffer) -> Map String (Stream Buffer) -> [String] -> IO Object+addObject input slotName prim indices attribs uniformNames = do+ let sch = schema input+ forM_ uniformNames $ \n -> case Map.lookup n (uniforms sch) of+ Nothing -> fail $ "Unknown uniform: " ++ show n+ _ -> return ()+ case Map.lookup slotName (objectArrays sch) of+ Nothing -> fail $ "Unknown slot: " ++ show slotName+ Just (ObjectArraySchema sPrim sAttrs) -> do+ when (sPrim /= (primitiveToFetchPrimitive prim)) $ fail $+ "Primitive mismatch for slot (" ++ show slotName ++ ") expected " ++ show sPrim ++ " but got " ++ show prim+ let sType = fmap streamToStreamType attribs+ when (sType /= sAttrs) $ fail $ unlines $ + [ "Attribute stream mismatch for slot (" ++ show slotName ++ ") expected "+ , show sAttrs+ , " but got "+ , show sType+ ]+ + let slotIdx = case slotName `Map.lookup` slotMap input of+ Nothing -> error $ "internal error (slot index): " ++ show slotName+ Just i -> i+ seed = objSeed input+ order <- newIORef 0+ enabled <- newIORef True+ index <- readIORef seed+ modifyIORef seed (1+)+ (setters,unis) <- mkUniform [(n,t) | n <- uniformNames, let t = fromMaybe (error $ "missing uniform: " ++ n) $ Map.lookup n (uniforms sch)]+ cmdsRef <- newIORef (V.singleton V.empty)+ let obj = Object+ { objSlot = slotIdx+ , objPrimitive = prim+ , objIndices = indices+ , objAttributes = attribs+ , objUniSetter = setters+ , objUniSetup = unis+ , objOrder = order+ , objEnabled = enabled+ , objId = index+ , objCommands = cmdsRef+ }++ modifyIORef (slotVector input ! slotIdx) $ \(GLSlot objs _ _) -> GLSlot (IM.insert index obj objs) V.empty Generate++ -- generate GLObjectCommands for the new object+ {-+ foreach pipeline:+ foreach realted program:+ generate commands+ -}+ ppls <- readIORef $ pipelines input+ let topUnis = uniformSetup input+ cmds <- V.forM ppls $ \mp -> case mp of+ Nothing -> return V.empty+ Just p -> do+ Just ic <- readIORef $ glInput p+ case icSlotMapInputToPipeline ic ! slotIdx of+ Nothing -> do+ --putStrLn $ " ** slot is not used!"+ return V.empty -- this slot is not used in that pipeline+ Just pSlotIdx -> do+ --putStrLn "slot is used!" + --where+ let emptyV = V.replicate (V.length $ glPrograms p) []+ return $ emptyV // [(prgIdx,createObjectCommands (glTexUnitMapping p) topUnis obj (glPrograms p ! prgIdx))| prgIdx <- glSlotPrograms p ! pSlotIdx]+ writeIORef cmdsRef cmds+ return obj++removeObject :: GLStorage -> Object -> IO ()+removeObject p obj = modifyIORef (slotVector p ! objSlot obj) $ \(GLSlot objs _ _) -> GLSlot (IM.delete (objId obj) objs) V.empty Generate++enableObject :: Object -> Bool -> IO ()+enableObject obj b = writeIORef (objEnabled obj) b++setObjectOrder :: GLStorage -> Object -> Int -> IO ()+setObjectOrder p obj i = do+ writeIORef (objOrder obj) i+ modifyIORef (slotVector p ! objSlot obj) $ \(GLSlot objs sorted _) -> GLSlot objs sorted Reorder++objectUniformSetter :: Object -> Map GLUniformName InputSetter+objectUniformSetter = objUniSetter++setScreenSize :: GLStorage -> Word -> Word -> IO ()+setScreenSize p w h = writeIORef (screenSize p) (w,h)++sortSlotObjects :: GLStorage -> IO ()+sortSlotObjects p = V.forM_ (slotVector p) $ \slotRef -> do+ GLSlot objMap sortedV ord <- readIORef slotRef+ let cmpFun (a,_) (b,_) = a `compare` b+ doSort objs = do+ ordObjsM <- V.thaw objs+ I.sortBy cmpFun ordObjsM+ ordObjs <- V.freeze ordObjsM+ writeIORef slotRef (GLSlot objMap ordObjs Ordered)+ case ord of+ Ordered -> return ()+ Generate -> do+ objs <- V.forM (V.fromList $ IM.elems objMap) $ \obj -> do+ ord <- readIORef $ objOrder obj+ return (ord,obj)+ doSort objs+ Reorder -> do+ objs <- V.forM sortedV $ \(_,obj) -> do+ ord <- readIORef $ objOrder obj+ return (ord,obj)+ doSort objs++createObjectCommands :: Map String (IORef GLint) -> Map String GLUniform -> Object -> GLProgram -> [GLObjectCommand]+createObjectCommands texUnitMap topUnis obj prg = objUniCmds ++ objStreamCmds ++ [objDrawCmd]+ where+ -- object draw command+ objDrawCmd = case objIndices obj of+ Nothing -> GLDrawArrays prim 0 (fromIntegral count)+ Just (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)+ where+ objAttrs = objAttributes obj+ prim = primitiveToGLType $ objPrimitive obj+ count = head [c | Stream _ _ _ _ c <- Map.elems objAttrs]++ -- object uniform commands+ -- texture slot setup commands+ objUniCmds = uniCmds ++ texCmds+ where+ uniCmds = [GLSetUniform i u | (n,i) <- uniMap, let u = Map.findWithDefault (topUni n) n objUnis]+ uniMap = Map.toList $ inputUniforms prg+ topUni n = Map.findWithDefault (error $ "internal error (createObjectCommands): " ++ show n) n topUnis+ objUnis = objUniSetup obj+ texUnis = S.toList $ inputTextureUniforms prg+ texCmds = [ GLBindTexture (inputTypeToTextureTarget $ uniInputType u) texUnit u+ | n <- texUnis+ , let u = Map.findWithDefault (topUni n) n objUnis+ , let texUnit = Map.findWithDefault (error $ "internal error (createObjectCommands - Texture Unit): " ++ show n) n texUnitMap+ ]+ uniInputType (GLUniform ty _) = ty++ -- object attribute stream commands+ objStreamCmds = [attrCmd i s | (i,name) <- Map.elems attrMap, let s = fromMaybe (error $ "missing attribute: " ++ name) $ Map.lookup name objAttrs]+ where + attrMap = inputStreams prg+ objAttrs = objAttributes obj+ attrCmd i s = case s of+ Stream ty (Buffer arrs bo) arrIdx start len -> case ty of+ Attribute_Word -> setIntAttrib 1+ Attribute_V2U -> setIntAttrib 2+ Attribute_V3U -> setIntAttrib 3+ Attribute_V4U -> setIntAttrib 4+ Attribute_Int -> setIntAttrib 1+ Attribute_V2I -> setIntAttrib 2+ Attribute_V3I -> setIntAttrib 3+ Attribute_V4I -> setIntAttrib 4+ Attribute_Float -> setFloatAttrib 1+ Attribute_V2F -> setFloatAttrib 2+ Attribute_V3F -> setFloatAttrib 3+ Attribute_V4F -> setFloatAttrib 4+ Attribute_M22F -> setFloatAttrib 4+ Attribute_M23F -> setFloatAttrib 6+ Attribute_M24F -> setFloatAttrib 8+ Attribute_M32F -> setFloatAttrib 6+ Attribute_M33F -> setFloatAttrib 9+ Attribute_M34F -> setFloatAttrib 12+ Attribute_M42F -> setFloatAttrib 8+ Attribute_M43F -> setFloatAttrib 12+ Attribute_M44F -> setFloatAttrib 16+ where+ setFloatAttrib n = GLSetVertexAttribArray i bo n glType (ptr n)+ setIntAttrib n = GLSetVertexAttribIArray i bo n glType (ptr n)+ ArrayDesc arrType arrLen arrOffs arrSize = arrs ! arrIdx+ glType = arrayTypeToGLType arrType+ ptr compCnt = intPtrToPtr $! fromIntegral (arrOffs + start * fromIntegral compCnt * sizeOfArrayType arrType)++ -- constant generic attribute+ constAttr -> GLSetVertexAttrib i constAttr++nullSetter :: GLUniformName -> String -> a -> IO ()+nullSetter n t _ = return ()+--nullSetter n t _ = Prelude.putStrLn $ "WARNING: unknown uniform: " ++ show n ++ " :: " ++ t++uniformBool :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun Bool+uniformV2B :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun V2B+uniformV3B :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun V3B+uniformV4B :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun V4B++uniformWord :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun Word32+uniformV2U :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun V2U+uniformV3U :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun V3U+uniformV4U :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun V4U++uniformInt :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun Int32+uniformV2I :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun V2I+uniformV3I :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun V3I+uniformV4I :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun V4I++uniformFloat :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun Float+uniformV2F :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun V2F+uniformV3F :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun V3F+uniformV4F :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun V4F++uniformM22F :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun M22F+uniformM23F :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun M23F+uniformM24F :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun M24F+uniformM32F :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun M32F+uniformM33F :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun M33F+uniformM34F :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun M34F+uniformM42F :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun M42F+uniformM43F :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun M43F+uniformM44F :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun M44F++uniformFTexture2D :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun TextureData++uniformBool n is = case Map.lookup n is of+ Just (SBool fun) -> fun+ _ -> nullSetter n "Bool"++uniformV2B n is = case Map.lookup n is of+ Just (SV2B fun) -> fun+ _ -> nullSetter n "V2B"++uniformV3B n is = case Map.lookup n is of+ Just (SV3B fun) -> fun+ _ -> nullSetter n "V3B"++uniformV4B n is = case Map.lookup n is of+ Just (SV4B fun) -> fun+ _ -> nullSetter n "V4B"++uniformWord n is = case Map.lookup n is of+ Just (SWord fun) -> fun+ _ -> nullSetter n "Word"++uniformV2U n is = case Map.lookup n is of+ Just (SV2U fun) -> fun+ _ -> nullSetter n "V2U"++uniformV3U n is = case Map.lookup n is of+ Just (SV3U fun) -> fun+ _ -> nullSetter n "V3U"++uniformV4U n is = case Map.lookup n is of+ Just (SV4U fun) -> fun+ _ -> nullSetter n "V4U"++uniformInt n is = case Map.lookup n is of+ Just (SInt fun) -> fun+ _ -> nullSetter n "Int"++uniformV2I n is = case Map.lookup n is of+ Just (SV2I fun) -> fun+ _ -> nullSetter n "V2I"++uniformV3I n is = case Map.lookup n is of+ Just (SV3I fun) -> fun+ _ -> nullSetter n "V3I"++uniformV4I n is = case Map.lookup n is of+ Just (SV4I fun) -> fun+ _ -> nullSetter n "V4I"++uniformFloat n is = case Map.lookup n is of+ Just (SFloat fun) -> fun+ _ -> nullSetter n "Float"++uniformV2F n is = case Map.lookup n is of+ Just (SV2F fun) -> fun+ _ -> nullSetter n "V2F"++uniformV3F n is = case Map.lookup n is of+ Just (SV3F fun) -> fun+ _ -> nullSetter n "V3F"++uniformV4F n is = case Map.lookup n is of+ Just (SV4F fun) -> fun+ _ -> nullSetter n "V4F"++uniformM22F n is = case Map.lookup n is of+ Just (SM22F fun) -> fun+ _ -> nullSetter n "M22F"++uniformM23F n is = case Map.lookup n is of+ Just (SM23F fun) -> fun+ _ -> nullSetter n "M23F"++uniformM24F n is = case Map.lookup n is of+ Just (SM24F fun) -> fun+ _ -> nullSetter n "M24F"++uniformM32F n is = case Map.lookup n is of+ Just (SM32F fun) -> fun+ _ -> nullSetter n "M32F"++uniformM33F n is = case Map.lookup n is of+ Just (SM33F fun) -> fun+ _ -> nullSetter n "M33F"++uniformM34F n is = case Map.lookup n is of+ Just (SM34F fun) -> fun+ _ -> nullSetter n "M34F"++uniformM42F n is = case Map.lookup n is of+ Just (SM42F fun) -> fun+ _ -> nullSetter n "M42F"++uniformM43F n is = case Map.lookup n is of+ Just (SM43F fun) -> fun+ _ -> nullSetter n "M43F"++uniformM44F n is = case Map.lookup n is of+ Just (SM44F fun) -> fun+ _ -> nullSetter n "M44F"++uniformFTexture2D n is = case Map.lookup n is of+ Just (SFTexture2D fun) -> fun+ _ -> nullSetter n "FTexture2D"++type UniM = Writer [Map GLUniformName InputSetter -> IO ()]++class UniformSetter a where+ (@=) :: GLUniformName -> IO a -> UniM ()++setUniM setUni n act = tell [\s -> let f = setUni n s in f =<< act]++instance UniformSetter Bool where (@=) = setUniM uniformBool+instance UniformSetter V2B where (@=) = setUniM uniformV2B+instance UniformSetter V3B where (@=) = setUniM uniformV3B+instance UniformSetter V4B where (@=) = setUniM uniformV4B+instance UniformSetter Word32 where (@=) = setUniM uniformWord+instance UniformSetter V2U where (@=) = setUniM uniformV2U+instance UniformSetter V3U where (@=) = setUniM uniformV3U+instance UniformSetter V4U where (@=) = setUniM uniformV4U+instance UniformSetter Int32 where (@=) = setUniM uniformInt+instance UniformSetter V2I where (@=) = setUniM uniformV2I+instance UniformSetter V3I where (@=) = setUniM uniformV3I+instance UniformSetter V4I where (@=) = setUniM uniformV4I+instance UniformSetter Float where (@=) = setUniM uniformFloat+instance UniformSetter V2F where (@=) = setUniM uniformV2F+instance UniformSetter V3F where (@=) = setUniM uniformV3F+instance UniformSetter V4F where (@=) = setUniM uniformV4F+instance UniformSetter M22F where (@=) = setUniM uniformM22F+instance UniformSetter M23F where (@=) = setUniM uniformM23F+instance UniformSetter M24F where (@=) = setUniM uniformM24F+instance UniformSetter M32F where (@=) = setUniM uniformM32F+instance UniformSetter M33F where (@=) = setUniM uniformM33F+instance UniformSetter M34F where (@=) = setUniM uniformM34F+instance UniformSetter M42F where (@=) = setUniM uniformM42F+instance UniformSetter M43F where (@=) = setUniM uniformM43F+instance UniformSetter M44F where (@=) = setUniM uniformM44F+instance UniformSetter TextureData where (@=) = setUniM uniformFTexture2D++updateUniforms storage m = sequence_ l where+ setters = uniformSetter storage+ l = map ($ setters) $ execWriter m++updateObjectUniforms object m = sequence_ l where+ setters = objectUniformSetter object+ l = map ($ setters) $ execWriter m
+ src/LambdaCube/GL/Mesh.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE TupleSections, RecordWildCards #-}+module LambdaCube.GL.Mesh (+ addMeshToObjectArray,+ uploadMeshToGPU,+ disposeMesh,+ updateMesh,+ Mesh(..),+ MeshPrimitive(..),+ MeshAttribute(..),+ GPUMesh,+ meshData+) where++import Data.Maybe+import Control.Applicative+import Control.Monad+import Foreign.Ptr+import Data.Int+import Foreign.Storable+import Foreign.Marshal.Utils+import System.IO.Unsafe+import Data.Map (Map)+import qualified Data.Map as Map+import qualified Data.Vector as V+import qualified Data.Vector.Storable as SV+import qualified Data.Vector.Storable.Mutable as MV+import qualified Data.ByteString.Char8 as SB+import qualified Data.ByteString.Lazy as LB++import LambdaCube.GL+import LambdaCube.GL.Type as T+import LambdaCube.IR as IR+import LambdaCube.Linear as IR+import LambdaCube.Mesh++data GPUData+ = GPUData+ { dPrimitive :: Primitive+ , dStreams :: Map String (Stream Buffer)+ , dIndices :: Maybe (IndexStream Buffer)+ , dBuffers :: [Buffer]+ }++data GPUMesh+ = GPUMesh+ { meshData :: Mesh+ , gpuData :: GPUData+ }++addMeshToObjectArray :: GLStorage -> String -> [String] -> GPUMesh -> IO Object+addMeshToObjectArray input slotName objUniNames (GPUMesh _ (GPUData prim streams indices _)) = do+ -- select proper attributes+ let (ObjectArraySchema slotPrim slotStreams) = fromMaybe (error $ "addMeshToObjectArray - missing object array: " ++ slotName) $ Map.lookup slotName $! objectArrays $! schema input+ filterStream n _ = Map.member n slotStreams+ addObject input slotName prim indices (Map.filterWithKey filterStream streams) objUniNames++withV w a f = w a (\p -> f $ castPtr p)++meshAttrToArray :: MeshAttribute -> Array+meshAttrToArray (A_Float v) = Array ArrFloat (1 * V.length v) $ withV SV.unsafeWith $ V.convert v+meshAttrToArray (A_V2F v) = Array ArrFloat (2 * V.length v) $ withV SV.unsafeWith $ V.convert v+meshAttrToArray (A_V3F v) = Array ArrFloat (3 * V.length v) $ withV SV.unsafeWith $ V.convert v+meshAttrToArray (A_V4F v) = Array ArrFloat (4 * V.length v) $ withV SV.unsafeWith $ V.convert v+meshAttrToArray (A_M22F v) = Array ArrFloat (4 * V.length v) $ withV SV.unsafeWith $ V.convert v+meshAttrToArray (A_M33F v) = Array ArrFloat (9 * V.length v) $ withV SV.unsafeWith $ V.convert v+meshAttrToArray (A_M44F v) = Array ArrFloat (16 * V.length v) $ withV SV.unsafeWith $ V.convert v+meshAttrToArray (A_Int v) = Array ArrInt32 (1 * V.length v) $ withV SV.unsafeWith $ V.convert v+meshAttrToArray (A_Word v) = Array ArrWord32 (1 * V.length v) $ withV SV.unsafeWith $ V.convert v++meshAttrToStream :: Buffer -> Int -> MeshAttribute -> Stream Buffer+meshAttrToStream b i (A_Float v) = Stream Attribute_Float b i 0 (V.length v)+meshAttrToStream b i (A_V2F v) = Stream Attribute_V2F b i 0 (V.length v)+meshAttrToStream b i (A_V3F v) = Stream Attribute_V3F b i 0 (V.length v)+meshAttrToStream b i (A_V4F v) = Stream Attribute_V4F b i 0 (V.length v)+meshAttrToStream b i (A_M22F v) = Stream Attribute_M22F b i 0 (V.length v)+meshAttrToStream b i (A_M33F v) = Stream Attribute_M33F b i 0 (V.length v)+meshAttrToStream b i (A_M44F v) = Stream Attribute_M44F b i 0 (V.length v)+meshAttrToStream b i (A_Int v) = Stream Attribute_Int b i 0 (V.length v)+meshAttrToStream b i (A_Word v) = Stream Attribute_Word b i 0 (V.length v)++updateMesh :: GPUMesh -> [(String,MeshAttribute)] -> Maybe MeshPrimitive -> IO ()+updateMesh (GPUMesh (Mesh dMA dMP) (GPUData _ dS dI _)) al mp = do+ -- check type match+ let arrayChk (Array t1 s1 _) (Array t2 s2 _) = t1 == t2 && s1 == s2+ ok = and [Map.member n dMA && arrayChk (meshAttrToArray a1) (meshAttrToArray a2) | (n,a1) <- al, let a2 = fromMaybe (error $ "missing mesh attribute: " ++ n) $ Map.lookup n dMA]+ if not ok then putStrLn "updateMesh: attribute mismatch!"+ else do+ forM_ al $ \(n,a) -> do+ case Map.lookup n dS of+ Just (Stream _ b i _ _) -> updateBuffer b [(i,meshAttrToArray a)]+ _ -> return ()+{-+ case mp of+ Nothing -> return ()+ Just p -> do+ let ok2 = case (dMP,p) of+ (Just (P_TriangleStripI v1, P_TriangleStripI v2) -> V.length v1 == V.length v2+ (P_TrianglesI v1, P_TrianglesI v2) -> V.length v1 == V.length v2+ (a,b) -> a == b+-}++uploadMeshToGPU :: Mesh -> IO GPUMesh+uploadMeshToGPU mesh@(Mesh attrs mPrim) = do+ let mkIndexBuf v = do+ iBuf <- compileBuffer [Array ArrWord32 (V.length v) $ withV SV.unsafeWith $ V.convert v]+ return $! Just $! IndexStream iBuf 0 0 (V.length v)+ vBuf <- compileBuffer [meshAttrToArray a | a <- Map.elems attrs]+ (indices,prim) <- case mPrim of+ P_Points -> return (Nothing,PointList)+ P_TriangleStrip -> return (Nothing,TriangleStrip)+ P_Triangles -> return (Nothing,TriangleList)+ P_TriangleStripI v -> (,TriangleStrip) <$> mkIndexBuf v+ P_TrianglesI v -> (,TriangleList) <$> mkIndexBuf v+ let streams = Map.fromList $! zipWith (\i (n,a) -> (n,meshAttrToStream vBuf i a)) [0..] (Map.toList attrs)+ return $! GPUMesh mesh (GPUData prim streams indices (vBuf:[iBuf | IndexStream iBuf _ _ _ <- maybeToList indices]))++disposeMesh :: GPUMesh -> IO ()+disposeMesh (GPUMesh _ GPUData{..}) = mapM_ disposeBuffer dBuffers
+ src/LambdaCube/GL/Type.hs view
@@ -0,0 +1,519 @@+{-# LANGUAGE ExistentialQuantification, FlexibleInstances, GeneralizedNewtypeDeriving, ScopedTypeVariables #-}+module LambdaCube.GL.Type where++import Data.IORef+import Data.Int+import Data.IntMap (IntMap)+import Data.Set (Set)+import Data.Map (Map)+import Data.Vector (Vector)+import Data.Word+import Foreign.Ptr+import Foreign.Storable+import Data.ByteString++import Graphics.GL.Core33++import LambdaCube.Linear+import LambdaCube.IR+import LambdaCube.PipelineSchema++type GLUniformName = ByteString++---------------+-- Input API --+---------------+{-+-- Buffer+ compileBuffer :: [Array] -> IO Buffer+ bufferSize :: Buffer -> Int+ arraySize :: Buffer -> Int -> Int+ arrayType :: Buffer -> Int -> ArrayType++-- Object+ addObject :: Renderer -> ByteString -> Primitive -> Maybe (IndexStream Buffer) -> Trie (Stream Buffer) -> [ByteString] -> IO Object+ removeObject :: Renderer -> Object -> IO ()+ objectUniformSetter :: Object -> Trie InputSetter+-}++data Buffer -- internal type+ = Buffer+ { bufArrays :: Vector ArrayDesc+ , bufGLObj :: GLuint+ }+ deriving (Show,Eq)++data ArrayDesc+ = ArrayDesc+ { arrType :: ArrayType+ , arrLength :: Int -- item count+ , arrOffset :: Int -- byte position in buffer+ , arrSize :: Int -- size in bytes+ }+ deriving (Show,Eq)++{-+ handles:+ uniforms+ textures+ buffers+ objects++ GLStorage can be attached to GLRenderer+-}++{-+ pipeline input:+ - independent from pipeline+ - per object features: enable/disable visibility, set render ordering+-}+data GLUniform = forall a. Storable a => GLUniform !InputType !(IORef a)++instance Show GLUniform where+ show (GLUniform t _) = "GLUniform " ++ show t++data OrderJob+ = Generate+ | Reorder+ | Ordered++data GLSlot+ = GLSlot+ { objectMap :: IntMap Object+ , sortedObjects :: Vector (Int,Object)+ , orderJob :: OrderJob+ }++data GLStorage+ = GLStorage+ { schema :: PipelineSchema+ , slotMap :: Map String SlotName+ , slotVector :: Vector (IORef GLSlot)+ , objSeed :: IORef Int+ , uniformSetter :: Map GLUniformName InputSetter+ , uniformSetup :: Map String GLUniform+ , screenSize :: IORef (Word,Word)+ , pipelines :: IORef (Vector (Maybe GLRenderer)) -- attached pipelines+ }++data Object -- internal type+ = Object+ { objSlot :: SlotName+ , objPrimitive :: Primitive+ , objIndices :: Maybe (IndexStream Buffer)+ , objAttributes :: Map String (Stream Buffer)+ , objUniSetter :: Map GLUniformName InputSetter+ , objUniSetup :: Map String GLUniform+ , objOrder :: IORef Int+ , objEnabled :: IORef Bool+ , objId :: Int+ , objCommands :: IORef (Vector (Vector [GLObjectCommand])) -- pipeline id, program name, commands+ }++--------------+-- Pipeline --+--------------++data GLProgram+ = GLProgram+ { shaderObjects :: [GLuint]+ , programObject :: GLuint+ , inputUniforms :: Map String GLint+ , inputTextures :: Map String GLint -- all input textures (render texture + uniform texture)+ , inputTextureUniforms :: Set String+ , inputStreams :: Map String (GLuint,String)+ }++data GLTexture+ = GLTexture+ { glTextureObject :: GLuint+ , glTextureTarget :: GLenum+ } deriving Eq++data InputConnection+ = InputConnection+ { icId :: Int -- identifier (vector index) for attached pipeline+ , icInput :: GLStorage+ , icSlotMapPipelineToInput :: Vector SlotName -- GLRenderer to GLStorage slot name mapping+ , icSlotMapInputToPipeline :: Vector (Maybe SlotName) -- GLStorage to GLRenderer slot name mapping+ }++data GLStream+ = GLStream+ { glStreamCommands :: IORef [GLObjectCommand]+ , glStreamPrimitive :: Primitive+ , glStreamAttributes :: Map String (Stream Buffer)+ , glStreamProgram :: ProgramName+ }++data GLRenderer+ = GLRenderer+ { glPrograms :: Vector GLProgram+ , glTextures :: Vector GLTexture+ , glSamplers :: Vector GLSampler+ , glTargets :: Vector GLRenderTarget+ , glCommands :: [GLCommand]+ , glSlotPrograms :: Vector [ProgramName] -- programs depend on a slot+ , glInput :: IORef (Maybe InputConnection)+ , glSlotNames :: Vector String+ , glVAO :: GLuint+ , glTexUnitMapping :: Map String (IORef GLint) -- maps texture uniforms to texture units+ , glStreams :: Vector GLStream+ , glDrawContextRef :: IORef GLDrawContext+ , glForceSetup :: IORef Bool+ , glVertexBufferRef :: IORef GLuint+ , glIndexBufferRef :: IORef GLuint+ , glDrawCallCounterRef :: IORef Int+ }++data GLSampler+ = GLSampler+ { glSamplerObject :: GLuint+ } deriving Eq++data GLRenderTarget+ = GLRenderTarget+ { framebufferObject :: GLuint+ , framebufferDrawbuffers :: Maybe [GLenum]+ } deriving Eq++type GLTextureUnit = Int+type GLUniformBinding = GLint++data GLSamplerUniform+ = GLSamplerUniform+ { glUniformBinding :: !GLUniformBinding+ , glUniformBindingRef :: IORef GLUniformBinding+ }++instance Eq GLSamplerUniform where+ a == b = glUniformBinding a == glUniformBinding b++data GLDrawContext+ = GLDrawContext+ { glRasterContext :: !RasterContext+ , glAccumulationContext :: !AccumulationContext+ , glRenderTarget :: !GLRenderTarget+ , glProgram :: !GLuint+ , glTextureMapping :: ![(GLTextureUnit,GLTexture)]+ , glSamplerMapping :: ![(GLTextureUnit,GLSampler)]+ , glSamplerUniformMapping :: ![(GLTextureUnit,GLSamplerUniform)]+ }++data GLCommand+ = GLRenderSlot !GLDrawContext !SlotName !ProgramName+ | GLRenderStream !GLDrawContext !StreamName !ProgramName+ | GLClearRenderTarget !GLRenderTarget ![ClearImage]++instance Show (IORef GLint) where+ show _ = "(IORef GLint)"++data GLObjectCommand+ = GLSetUniform !GLint !GLUniform+ | GLBindTexture !GLenum !(IORef GLint) !GLUniform -- binds the texture from the gluniform to the specified texture unit and target+ | GLSetVertexAttribArray !GLuint !GLuint !GLint !GLenum !(Ptr ()) -- index buffer size type pointer+ | GLSetVertexAttribIArray !GLuint !GLuint !GLint !GLenum !(Ptr ()) -- index buffer size type pointer+ | GLSetVertexAttrib !GLuint !(Stream Buffer) -- index value+ | GLDrawArrays !GLenum !GLint !GLsizei -- mode first count+ | GLDrawElements !GLenum !GLsizei !GLenum !GLuint !(Ptr ()) -- mode count type buffer indicesPtr+ deriving Show++type SetterFun a = a -> IO ()++-- user will provide scalar input data via this type+data InputSetter+ = SBool (SetterFun Bool)+ | SV2B (SetterFun V2B)+ | SV3B (SetterFun V3B)+ | SV4B (SetterFun V4B)+ | SWord (SetterFun Word32)+ | SV2U (SetterFun V2U)+ | SV3U (SetterFun V3U)+ | SV4U (SetterFun V4U)+ | SInt (SetterFun Int32)+ | SV2I (SetterFun V2I)+ | SV3I (SetterFun V3I)+ | SV4I (SetterFun V4I)+ | SFloat (SetterFun Float)+ | SV2F (SetterFun V2F)+ | SV3F (SetterFun V3F)+ | SV4F (SetterFun V4F)+ | SM22F (SetterFun M22F)+ | SM23F (SetterFun M23F)+ | SM24F (SetterFun M24F)+ | SM32F (SetterFun M32F)+ | SM33F (SetterFun M33F)+ | SM34F (SetterFun M34F)+ | SM42F (SetterFun M42F)+ | SM43F (SetterFun M43F)+ | SM44F (SetterFun M44F)+ -- shadow textures+ | SSTexture1D+ | SSTexture2D+ | SSTextureCube+ | SSTexture1DArray+ | SSTexture2DArray+ | SSTexture2DRect+ -- float textures+ | SFTexture1D+ | SFTexture2D (SetterFun TextureData)+ | SFTexture3D+ | SFTextureCube+ | SFTexture1DArray+ | SFTexture2DArray+ | SFTexture2DMS+ | SFTexture2DMSArray+ | SFTextureBuffer+ | SFTexture2DRect+ -- int textures+ | SITexture1D+ | SITexture2D+ | SITexture3D+ | SITextureCube+ | SITexture1DArray+ | SITexture2DArray+ | SITexture2DMS+ | SITexture2DMSArray+ | SITextureBuffer+ | SITexture2DRect+ -- uint textures+ | SUTexture1D+ | SUTexture2D+ | SUTexture3D+ | SUTextureCube+ | SUTexture1DArray+ | SUTexture2DArray+ | SUTexture2DMS+ | SUTexture2DMSArray+ | SUTextureBuffer+ | SUTexture2DRect++-- buffer handling+{-+ user can fills a buffer (continuous memory region)+ each buffer have a data descriptor, what describes the+ buffer content. e.g. a buffer can contain more arrays of stream types+-}++-- user will provide stream data using this setup function+type BufferSetter = (Ptr () -> IO ()) -> IO ()++-- specifies array component type (stream type in storage side)+-- this type can be overridden in GPU side, e.g ArrWord8 can be seen as TFloat or TWord also+data ArrayType+ = ArrWord8+ | ArrWord16+ | ArrWord32+ | ArrInt8+ | ArrInt16+ | ArrInt32+ | ArrFloat+ | ArrHalf -- Hint: half float is not supported in haskell+ deriving (Show,Eq,Ord)++sizeOfArrayType :: ArrayType -> Int+sizeOfArrayType ArrWord8 = 1+sizeOfArrayType ArrWord16 = 2+sizeOfArrayType ArrWord32 = 4+sizeOfArrayType ArrInt8 = 1+sizeOfArrayType ArrInt16 = 2+sizeOfArrayType ArrInt32 = 4+sizeOfArrayType ArrFloat = 4+sizeOfArrayType ArrHalf = 2++-- describes an array in a buffer+data Array -- array type, element count (NOT byte size!), setter+ = Array ArrayType Int BufferSetter++toStreamType :: InputType -> Maybe StreamType+toStreamType Word = Just Attribute_Word+toStreamType V2U = Just Attribute_V2U+toStreamType V3U = Just Attribute_V3U+toStreamType V4U = Just Attribute_V4U+toStreamType Int = Just Attribute_Int+toStreamType V2I = Just Attribute_V2I+toStreamType V3I = Just Attribute_V3I+toStreamType V4I = Just Attribute_V4I+toStreamType Float = Just Attribute_Float+toStreamType V2F = Just Attribute_V2F+toStreamType V3F = Just Attribute_V3F+toStreamType V4F = Just Attribute_V4F+toStreamType M22F = Just Attribute_M22F+toStreamType M23F = Just Attribute_M23F+toStreamType M24F = Just Attribute_M24F+toStreamType M32F = Just Attribute_M32F+toStreamType M33F = Just Attribute_M33F+toStreamType M34F = Just Attribute_M34F+toStreamType M42F = Just Attribute_M42F+toStreamType M43F = Just Attribute_M43F+toStreamType M44F = Just Attribute_M44F+toStreamType _ = Nothing++fromStreamType :: StreamType -> InputType+fromStreamType Attribute_Word = Word+fromStreamType Attribute_V2U = V2U+fromStreamType Attribute_V3U = V3U+fromStreamType Attribute_V4U = V4U+fromStreamType Attribute_Int = Int+fromStreamType Attribute_V2I = V2I+fromStreamType Attribute_V3I = V3I+fromStreamType Attribute_V4I = V4I+fromStreamType Attribute_Float = Float+fromStreamType Attribute_V2F = V2F+fromStreamType Attribute_V3F = V3F+fromStreamType Attribute_V4F = V4F+fromStreamType Attribute_M22F = M22F+fromStreamType Attribute_M23F = M23F+fromStreamType Attribute_M24F = M24F+fromStreamType Attribute_M32F = M32F+fromStreamType Attribute_M33F = M33F+fromStreamType Attribute_M34F = M34F+fromStreamType Attribute_M42F = M42F+fromStreamType Attribute_M43F = M43F+fromStreamType Attribute_M44F = M44F++-- user can specify streams using Stream type+-- a stream can be constant (ConstXXX) or can came from a buffer+data Stream b+ = ConstWord Word32+ | ConstV2U V2U+ | ConstV3U V3U+ | ConstV4U V4U+ | ConstInt Int32+ | ConstV2I V2I+ | ConstV3I V3I+ | ConstV4I V4I+ | ConstFloat Float+ | ConstV2F V2F+ | ConstV3F V3F+ | ConstV4F V4F+ | ConstM22F M22F+ | ConstM23F M23F+ | ConstM24F M24F+ | ConstM32F M32F+ | ConstM33F M33F+ | ConstM34F M34F+ | ConstM42F M42F+ | ConstM43F M43F+ | ConstM44F M44F+ | Stream + { streamType :: StreamType+ , streamBuffer :: b+ , streamArrIdx :: Int+ , streamStart :: Int+ , streamLength :: Int+ }+ deriving Show++streamToStreamType :: Stream a -> StreamType+streamToStreamType s = case s of+ ConstWord _ -> Attribute_Word+ ConstV2U _ -> Attribute_V2U+ ConstV3U _ -> Attribute_V3U+ ConstV4U _ -> Attribute_V4U+ ConstInt _ -> Attribute_Int+ ConstV2I _ -> Attribute_V2I+ ConstV3I _ -> Attribute_V3I+ ConstV4I _ -> Attribute_V4I+ ConstFloat _ -> Attribute_Float+ ConstV2F _ -> Attribute_V2F+ ConstV3F _ -> Attribute_V3F+ ConstV4F _ -> Attribute_V4F+ ConstM22F _ -> Attribute_M22F+ ConstM23F _ -> Attribute_M23F+ ConstM24F _ -> Attribute_M24F+ ConstM32F _ -> Attribute_M32F+ ConstM33F _ -> Attribute_M33F+ ConstM34F _ -> Attribute_M34F+ ConstM42F _ -> Attribute_M42F+ ConstM43F _ -> Attribute_M43F+ ConstM44F _ -> Attribute_M44F+ Stream t _ _ _ _ -> t++-- stream of index values (for index buffer)+data IndexStream b+ = IndexStream+ { indexBuffer :: b+ , indexArrIdx :: Int+ , indexStart :: Int+ , indexLength :: Int+ }++newtype TextureData+ = TextureData+ { textureObject :: GLuint+ }+ deriving Storable++data Primitive+ = TriangleStrip+ | TriangleList+ | TriangleFan+ | LineStrip+ | LineList+ | PointList+ | TriangleStripAdjacency+ | TriangleListAdjacency+ | LineStripAdjacency+ | LineListAdjacency+ deriving (Eq,Ord,Bounded,Enum,Show)++type StreamSetter = Stream Buffer -> IO ()++-- storable instances+instance Storable a => Storable (V2 a) where+ sizeOf _ = 2 * sizeOf (undefined :: a)+ alignment _ = sizeOf (undefined :: a)++ peek q = do+ let p = castPtr q :: Ptr a+ k = sizeOf (undefined :: a)+ x <- peek p + y <- peekByteOff p k+ return $! (V2 x y)++ poke q (V2 x y) = do+ let p = castPtr q :: Ptr a+ k = sizeOf (undefined :: a)+ poke p x+ pokeByteOff p k y++instance Storable a => Storable (V3 a) where+ sizeOf _ = 3 * sizeOf (undefined :: a)+ alignment _ = sizeOf (undefined :: a)++ peek q = do+ let p = castPtr q :: Ptr a+ k = sizeOf (undefined :: a)+ x <- peek p + y <- peekByteOff p k+ z <- peekByteOff p (k*2)+ return $! (V3 x y z)++ poke q (V3 x y z) = do+ let p = castPtr q :: Ptr a+ k = sizeOf (undefined :: a)+ poke p x+ pokeByteOff p k y+ pokeByteOff p (k*2) z++instance Storable a => Storable (V4 a) where+ sizeOf _ = 4 * sizeOf (undefined :: a)+ alignment _ = sizeOf (undefined :: a)++ peek q = do+ let p = castPtr q :: Ptr a+ k = sizeOf (undefined :: a)+ x <- peek p + y <- peekByteOff p k+ z <- peekByteOff p (k*2)+ w <- peekByteOff p (k*3)+ return $! (V4 x y z w)++ poke q (V4 x y z w) = do+ let p = castPtr q :: Ptr a+ k = sizeOf (undefined :: a)+ poke p x+ pokeByteOff p k y+ pokeByteOff p (k*2) z+ pokeByteOff p (k*3) w
+ src/LambdaCube/GL/Util.hs view
@@ -0,0 +1,756 @@+{-# LANGUAGE RecordWildCards #-}+module LambdaCube.GL.Util (+ queryUniforms,+ queryStreams,+ mkUniformSetter,+ setUniform,+ setVertexAttrib,+ compileShader,+ printProgramLog,+ glGetShaderiv1,+ glGetProgramiv1,+ Buffer(..),+ ArrayDesc(..),+ StreamSetter,+ streamToInputType,+ arrayTypeToGLType,+ comparisonFunctionToGLType,+ logicOperationToGLType,+ blendEquationToGLType,+ blendingFactorToGLType,+ checkGL,+ textureDataTypeToGLType,+ textureDataTypeToGLArityType,+ glGetIntegerv1,+ setSampler,+ checkFBO,+ compileSampler,+ compileTexture,+ primitiveToFetchPrimitive,+ primitiveToGLType,+ inputTypeToTextureTarget+) where++import Control.Applicative+import Control.Exception+import Control.Monad+import Data.IORef+import Data.List as L+import Foreign+import Foreign.C.String+import qualified Data.Vector as V+import Data.Vector.Unboxed.Mutable (IOVector)+import qualified Data.Vector.Unboxed.Mutable as MV+import Data.Map (Map)+import qualified Data.Map as Map++import Graphics.GL.Core33+import LambdaCube.Linear+import LambdaCube.IR+import LambdaCube.PipelineSchema+import LambdaCube.GL.Type++setSampler :: GLint -> Int32 -> IO ()+setSampler i v = glUniform1i i $ fromIntegral v++z2 = V2 0 0 :: V2F+z3 = V3 0 0 0 :: V3F+z4 = V4 0 0 0 0 :: V4F++-- uniform functions+queryUniforms :: GLuint -> IO (Map String GLint, Map String InputType)+queryUniforms po = do+ ul <- getNameTypeSize po glGetActiveUniform glGetUniformLocation GL_ACTIVE_UNIFORMS GL_ACTIVE_UNIFORM_MAX_LENGTH+ let uNames = [n | (n,_,_,_) <- ul]+ uTypes = [fromGLType (e,s) | (_,_,e,s) <- ul]+ uLocation = [i | (_,i,_,_) <- ul]+ return $! (Map.fromList $! zip uNames uLocation, Map.fromList $! zip uNames uTypes)++b2w :: Bool -> GLuint+b2w True = 1+b2w False = 0++mkUniformSetter :: InputType -> IO (GLUniform, InputSetter)+mkUniformSetter t@Bool = do {r <- newIORef 0; return $! (GLUniform t r, SBool $! writeIORef r . b2w)}+mkUniformSetter t@V2B = do {r <- newIORef (V2 0 0); return $! (GLUniform t r, SV2B $! writeIORef r . fmap b2w)}+mkUniformSetter t@V3B = do {r <- newIORef (V3 0 0 0); return $! (GLUniform t r, SV3B $! writeIORef r . fmap b2w)}+mkUniformSetter t@V4B = do {r <- newIORef (V4 0 0 0 0); return $! (GLUniform t r, SV4B $! writeIORef r . fmap b2w)}+mkUniformSetter t@Word = do {r <- newIORef 0; return $! (GLUniform t r, SWord $! writeIORef r)}+mkUniformSetter t@V2U = do {r <- newIORef (V2 0 0); return $! (GLUniform t r, SV2U $! writeIORef r)}+mkUniformSetter t@V3U = do {r <- newIORef (V3 0 0 0); return $! (GLUniform t r, SV3U $! writeIORef r)}+mkUniformSetter t@V4U = do {r <- newIORef (V4 0 0 0 0); return $! (GLUniform t r, SV4U $! writeIORef r)}+mkUniformSetter t@Int = do {r <- newIORef 0; return $! (GLUniform t r, SInt $! writeIORef r)}+mkUniformSetter t@V2I = do {r <- newIORef (V2 0 0); return $! (GLUniform t r, SV2I $! writeIORef r)}+mkUniformSetter t@V3I = do {r <- newIORef (V3 0 0 0); return $! (GLUniform t r, SV3I $! writeIORef r)}+mkUniformSetter t@V4I = do {r <- newIORef (V4 0 0 0 0); return $! (GLUniform t r, SV4I $! writeIORef r)}+mkUniformSetter t@Float = do {r <- newIORef 0; return $! (GLUniform t r, SFloat $! writeIORef r)}+mkUniformSetter t@V2F = do {r <- newIORef (V2 0 0); return $! (GLUniform t r, SV2F $! writeIORef r)}+mkUniformSetter t@V3F = do {r <- newIORef (V3 0 0 0); return $! (GLUniform t r, SV3F $! writeIORef r)}+mkUniformSetter t@V4F = do {r <- newIORef (V4 0 0 0 0); return $! (GLUniform t r, SV4F $! writeIORef r)}+mkUniformSetter t@M22F = do {r <- newIORef (V2 z2 z2); return $! (GLUniform t r, SM22F $! writeIORef r)}+mkUniformSetter t@M23F = do {r <- newIORef (V3 z2 z2 z2); return $! (GLUniform t r, SM23F $! writeIORef r)}+mkUniformSetter t@M24F = do {r <- newIORef (V4 z2 z2 z2 z2); return $! (GLUniform t r, SM24F $! writeIORef r)}+mkUniformSetter t@M32F = do {r <- newIORef (V2 z3 z3); return $! (GLUniform t r, SM32F $! writeIORef r)}+mkUniformSetter t@M33F = do {r <- newIORef (V3 z3 z3 z3); return $! (GLUniform t r, SM33F $! writeIORef r)}+mkUniformSetter t@M34F = do {r <- newIORef (V4 z3 z3 z3 z3); return $! (GLUniform t r, SM34F $! writeIORef r)}+mkUniformSetter t@M42F = do {r <- newIORef (V2 z4 z4); return $! (GLUniform t r, SM42F $! writeIORef r)}+mkUniformSetter t@M43F = do {r <- newIORef (V3 z4 z4 z4); return $! (GLUniform t r, SM43F $! writeIORef r)}+mkUniformSetter t@M44F = do {r <- newIORef (V4 z4 z4 z4 z4); return $! (GLUniform t r, SM44F $! writeIORef r)}+mkUniformSetter t@FTexture2D = do {r <- newIORef (TextureData 0); return $! (GLUniform t r, SFTexture2D $! writeIORef r)}++-- sets value based uniforms only (does not handle textures)+setUniform :: Storable a => GLint -> InputType -> IORef a -> IO ()+setUniform i ty ref = do+ v <- readIORef ref+ let false = fromIntegral GL_FALSE+ with v $ \p -> case ty of+ Bool -> glUniform1uiv i 1 (castPtr p)+ V2B -> glUniform2uiv i 1 (castPtr p)+ V3B -> glUniform3uiv i 1 (castPtr p)+ V4B -> glUniform4uiv i 1 (castPtr p)+ Word -> glUniform1uiv i 1 (castPtr p)+ V2U -> glUniform2uiv i 1 (castPtr p)+ V3U -> glUniform3uiv i 1 (castPtr p)+ V4U -> glUniform4uiv i 1 (castPtr p)+ Int -> glUniform1iv i 1 (castPtr p)+ V2I -> glUniform2iv i 1 (castPtr p)+ V3I -> glUniform3iv i 1 (castPtr p)+ V4I -> glUniform4iv i 1 (castPtr p)+ Float -> glUniform1fv i 1 (castPtr p)+ V2F -> glUniform2fv i 1 (castPtr p)+ V3F -> glUniform3fv i 1 (castPtr p)+ V4F -> glUniform4fv i 1 (castPtr p)+ M22F -> glUniformMatrix2fv i 1 false (castPtr p)+ M23F -> glUniformMatrix2x3fv i 1 false (castPtr p)+ M24F -> glUniformMatrix2x4fv i 1 false (castPtr p)+ M32F -> glUniformMatrix3x2fv i 1 false (castPtr p)+ M33F -> glUniformMatrix3fv i 1 false (castPtr p)+ M34F -> glUniformMatrix3x4fv i 1 false (castPtr p)+ M42F -> glUniformMatrix4x2fv i 1 false (castPtr p)+ M43F -> glUniformMatrix4x3fv i 1 false (castPtr p)+ M44F -> glUniformMatrix4fv i 1 false (castPtr p)+ FTexture2D -> return () --putStrLn $ "TODO: setUniform FTexture2D"+ _ -> fail $ "internal error (setUniform)! - " ++ show ty++-- attribute functions+queryStreams :: GLuint -> IO (Map String GLuint, Map String InputType)+queryStreams po = do+ al <- getNameTypeSize po glGetActiveAttrib glGetAttribLocation GL_ACTIVE_ATTRIBUTES GL_ACTIVE_ATTRIBUTE_MAX_LENGTH+ let aNames = [n | (n,_,_,_) <- al]+ aTypes = [fromGLType (e,s) | (_,_,e,s) <- al]+ aLocation = [fromIntegral i | (_,i,_,_) <- al]+ return $! (Map.fromList $! zip aNames aLocation, Map.fromList $! zip aNames aTypes)++arrayTypeToGLType :: ArrayType -> GLenum+arrayTypeToGLType a = case a of+ ArrWord8 -> GL_UNSIGNED_BYTE+ ArrWord16 -> GL_UNSIGNED_SHORT+ ArrWord32 -> GL_UNSIGNED_INT+ ArrInt8 -> GL_BYTE+ ArrInt16 -> GL_SHORT+ ArrInt32 -> GL_INT+ ArrFloat -> GL_FLOAT+ ArrHalf -> GL_HALF_FLOAT++setVertexAttrib :: GLuint -> Stream Buffer -> IO ()+setVertexAttrib i val = case val of+ ConstWord v -> with v $! \p -> glVertexAttribI1uiv i $! castPtr p+ ConstV2U v -> with v $! \p -> glVertexAttribI2uiv i $! castPtr p+ ConstV3U v -> with v $! \p -> glVertexAttribI3uiv i $! castPtr p+ ConstV4U v -> with v $! \p -> glVertexAttribI4uiv i $! castPtr p+ ConstInt v -> with v $! \p -> glVertexAttribI1iv i $! castPtr p+ ConstV2I v -> with v $! \p -> glVertexAttribI2iv i $! castPtr p+ ConstV3I v -> with v $! \p -> glVertexAttribI3iv i $! castPtr p+ ConstV4I v -> with v $! \p -> glVertexAttribI4iv i $! castPtr p+ ConstFloat v -> setAFloat i v+ ConstV2F v -> setAV2F i v+ ConstV3F v -> setAV3F i v+ ConstV4F v -> setAV4F i v+ ConstM22F (V2 x y) -> setAV2F i x >> setAV2F (i+1) y+ ConstM23F (V3 x y z) -> setAV2F i x >> setAV2F (i+1) y >> setAV2F (i+2) z+ ConstM24F (V4 x y z w) -> setAV2F i x >> setAV2F (i+1) y >> setAV2F (i+2) z >> setAV2F (i+3) w+ ConstM32F (V2 x y) -> setAV3F i x >> setAV3F (i+1) y+ ConstM33F (V3 x y z) -> setAV3F i x >> setAV3F (i+1) y >> setAV3F (i+2) z+ ConstM34F (V4 x y z w) -> setAV3F i x >> setAV3F (i+1) y >> setAV3F (i+2) z >> setAV3F (i+3) w+ ConstM42F (V2 x y) -> setAV4F i x >> setAV4F (i+1) y+ ConstM43F (V3 x y z) -> setAV4F i x >> setAV4F (i+1) y >> setAV4F (i+2) z+ ConstM44F (V4 x y z w) -> setAV4F i x >> setAV4F (i+1) y >> setAV4F (i+2) z >> setAV4F (i+3) w+ _ -> fail "internal error (setVertexAttrib)!"++setAFloat :: GLuint -> Float -> IO ()+setAV2F :: GLuint -> V2F -> IO ()+setAV3F :: GLuint -> V3F -> IO ()+setAV4F :: GLuint -> V4F -> IO ()+setAFloat i v = with v $! \p -> glVertexAttrib1fv i $! castPtr p+setAV2F i v = with v $! \p -> glVertexAttrib2fv i $! castPtr p+setAV3F i v = with v $! \p -> glVertexAttrib3fv i $! castPtr p+setAV4F i v = with v $! \p -> glVertexAttrib4fv i $! castPtr p++-- result list: [(name string,location,gl type,component count)]+getNameTypeSize :: GLuint -> (GLuint -> GLuint -> GLsizei -> Ptr GLsizei -> Ptr GLint -> Ptr GLenum -> Ptr GLchar -> IO ())+ -> (GLuint -> Ptr GLchar -> IO GLint) -> GLenum -> GLenum -> IO [(String,GLint,GLenum,GLint)]+getNameTypeSize o f g enum enumLen = do+ nameLen <- glGetProgramiv1 enumLen o+ allocaArray (fromIntegral nameLen) $! \namep -> alloca $! \sizep -> alloca $! \typep -> do+ n <- glGetProgramiv1 enum o+ forM [0..n-1] $! \i -> f o (fromIntegral i) (fromIntegral nameLen) nullPtr sizep typep namep >>+ (,,,) <$> peekCString (castPtr namep) <*> g o namep <*> peek typep <*> peek sizep++fromGLType :: (GLenum,GLint) -> InputType+fromGLType (t,1)+ | t == GL_BOOL = Bool+ | t == GL_BOOL_VEC2 = V2B+ | t == GL_BOOL_VEC3 = V3B+ | t == GL_BOOL_VEC4 = V4B+ | t == GL_UNSIGNED_INT = Word+ | t == GL_UNSIGNED_INT_VEC2 = V2U+ | t == GL_UNSIGNED_INT_VEC3 = V3U+ | t == GL_UNSIGNED_INT_VEC4 = V4U+ | t == GL_INT = Int+ | t == GL_INT_VEC2 = V2I+ | t == GL_INT_VEC3 = V3I+ | t == GL_INT_VEC4 = V4I+ | t == GL_FLOAT = Float+ | t == GL_FLOAT_VEC2 = V2F+ | t == GL_FLOAT_VEC3 = V3F+ | t == GL_FLOAT_VEC4 = V4F+ | t == GL_FLOAT_MAT2 = M22F+ | t == GL_FLOAT_MAT2x3 = M23F+ | t == GL_FLOAT_MAT2x4 = M24F+ | t == GL_FLOAT_MAT3x2 = M32F+ | t == GL_FLOAT_MAT3 = M33F+ | t == GL_FLOAT_MAT3x4 = M34F+ | t == GL_FLOAT_MAT4x2 = M42F+ | t == GL_FLOAT_MAT4x3 = M43F+ | t == GL_FLOAT_MAT4 = M44F+ | t == GL_SAMPLER_1D_ARRAY_SHADOW = STexture1DArray+ | t == GL_SAMPLER_1D_SHADOW = STexture1D+ | t == GL_SAMPLER_2D_ARRAY_SHADOW = STexture2DArray+ | t == GL_SAMPLER_2D_RECT_SHADOW = STexture2DRect+ | t == GL_SAMPLER_2D_SHADOW = STexture2D+ | t == GL_SAMPLER_CUBE_SHADOW = STextureCube+ | t == GL_INT_SAMPLER_1D = ITexture1D+ | t == GL_INT_SAMPLER_1D_ARRAY = ITexture1DArray+ | t == GL_INT_SAMPLER_2D = ITexture2D+ | t == GL_INT_SAMPLER_2D_ARRAY = ITexture2DArray+ | t == GL_INT_SAMPLER_2D_MULTISAMPLE = ITexture2DMS+ | t == GL_INT_SAMPLER_2D_MULTISAMPLE_ARRAY = ITexture2DMSArray+ | t == GL_INT_SAMPLER_2D_RECT = ITexture2DRect+ | t == GL_INT_SAMPLER_3D = ITexture3D+ | t == GL_INT_SAMPLER_BUFFER = ITextureBuffer+ | t == GL_INT_SAMPLER_CUBE = ITextureCube+ | t == GL_SAMPLER_1D = FTexture1D+ | t == GL_SAMPLER_1D_ARRAY = FTexture1DArray+ | t == GL_SAMPLER_2D = FTexture2D+ | t == GL_SAMPLER_2D_ARRAY = FTexture2DArray+ | t == GL_SAMPLER_2D_MULTISAMPLE = FTexture2DMS+ | t == GL_SAMPLER_2D_MULTISAMPLE_ARRAY = FTexture2DMSArray+ | t == GL_SAMPLER_2D_RECT = FTexture2DRect+ | t == GL_SAMPLER_3D = FTexture3D+ | t == GL_SAMPLER_BUFFER = FTextureBuffer+ | t == GL_SAMPLER_CUBE = FTextureCube+ | t == GL_UNSIGNED_INT_SAMPLER_1D = UTexture1D+ | t == GL_UNSIGNED_INT_SAMPLER_1D_ARRAY = UTexture1DArray+ | t == GL_UNSIGNED_INT_SAMPLER_2D = UTexture2D+ | t == GL_UNSIGNED_INT_SAMPLER_2D_ARRAY = UTexture2DArray+ | t == GL_UNSIGNED_INT_SAMPLER_2D_MULTISAMPLE = UTexture2DMS+ | t == GL_UNSIGNED_INT_SAMPLER_2D_MULTISAMPLE_ARRAY = UTexture2DMSArray+ | t == GL_UNSIGNED_INT_SAMPLER_2D_RECT = UTexture2DRect+ | t == GL_UNSIGNED_INT_SAMPLER_3D = UTexture3D+ | t == GL_UNSIGNED_INT_SAMPLER_BUFFER = UTextureBuffer+ | t == GL_UNSIGNED_INT_SAMPLER_CUBE = UTextureCube+ | otherwise = error "Failed fromGLType"+fromGLUniformType _ = error "Failed fromGLType"++printShaderLog :: GLuint -> IO String+printShaderLog o = do+ i <- glGetShaderiv1 GL_INFO_LOG_LENGTH o+ case (i > 0) of+ False -> return ""+ True -> do+ alloca $ \sizePtr -> allocaArray (fromIntegral i) $! \ps -> do+ glGetShaderInfoLog o (fromIntegral i) sizePtr ps+ size <- peek sizePtr+ log <- peekCStringLen (castPtr ps, fromIntegral size)+ putStrLn log+ return log++glGetShaderiv1 :: GLenum -> GLuint -> IO GLint+glGetShaderiv1 pname o = alloca $! \pi -> glGetShaderiv o pname pi >> peek pi++glGetProgramiv1 :: GLenum -> GLuint -> IO GLint+glGetProgramiv1 pname o = alloca $! \pi -> glGetProgramiv o pname pi >> peek pi++printProgramLog :: GLuint -> IO String+printProgramLog o = do+ i <- glGetProgramiv1 GL_INFO_LOG_LENGTH o+ case (i > 0) of+ False -> return ""+ True -> do+ alloca $ \sizePtr -> allocaArray (fromIntegral i) $! \ps -> do+ glGetProgramInfoLog o (fromIntegral i) sizePtr ps+ size <- peek sizePtr+ log <- peekCStringLen (castPtr ps, fromIntegral size)+ unless (null log) $ putStrLn log+ return log++compileShader :: GLuint -> [String] -> IO ()+compileShader o srcl = withMany withCString srcl $! \l -> withArray l $! \p -> do+ glShaderSource o (fromIntegral $! length srcl) (castPtr p) nullPtr+ glCompileShader o+ log <- printShaderLog o+ status <- glGetShaderiv1 GL_COMPILE_STATUS o+ when (status /= fromIntegral GL_TRUE) $ fail $ unlines ["compileShader failed:",log]++checkGL :: IO String+checkGL = do+ let f e | e == GL_INVALID_ENUM = "INVALID_ENUM"+ | e == GL_INVALID_VALUE = "INVALID_VALUE"+ | e == GL_INVALID_OPERATION = "INVALID_OPERATION"+ | e == GL_INVALID_FRAMEBUFFER_OPERATION = "INVALID_FRAMEBUFFER_OPERATION"+ | e == GL_OUT_OF_MEMORY = "OUT_OF_MEMORY"+ | e == GL_NO_ERROR = "OK"+ | otherwise = "Unknown error"+ e <- glGetError+ return $ f e++streamToInputType :: Stream Buffer -> InputType+streamToInputType s = case s of+ ConstWord _ -> Word+ ConstV2U _ -> V2U+ ConstV3U _ -> V3U+ ConstV4U _ -> V4U+ ConstInt _ -> Int+ ConstV2I _ -> V2I+ ConstV3I _ -> V3I+ ConstV4I _ -> V4I+ ConstFloat _ -> Float+ ConstV2F _ -> V2F+ ConstV3F _ -> V3F+ ConstV4F _ -> V4F+ ConstM22F _ -> M22F+ ConstM23F _ -> M23F+ ConstM24F _ -> M24F+ ConstM32F _ -> M32F+ ConstM33F _ -> M33F+ ConstM34F _ -> M34F+ ConstM42F _ -> M42F+ ConstM43F _ -> M43F+ ConstM44F _ -> M44F+ Stream t (Buffer a _) i _ _+ | 0 <= i && i < V.length a &&+ if elem t integralTypes then elem at integralArrTypes else True+ -> fromStreamType t+ | otherwise -> error "streamToInputType failed"+ where+ at = arrType $! (a V.! i)+ integralTypes = [Attribute_Word, Attribute_V2U, Attribute_V3U, Attribute_V4U, Attribute_Int, Attribute_V2I, Attribute_V3I, Attribute_V4I]+ integralArrTypes = [ArrWord8, ArrWord16, ArrWord32, ArrInt8, ArrInt16, ArrInt32]++comparisonFunctionToGLType :: ComparisonFunction -> GLenum+comparisonFunctionToGLType a = case a of+ Always -> GL_ALWAYS+ Equal -> GL_EQUAL+ Gequal -> GL_GEQUAL+ Greater -> GL_GREATER+ Lequal -> GL_LEQUAL+ Less -> GL_LESS+ Never -> GL_NEVER+ Notequal -> GL_NOTEQUAL++logicOperationToGLType :: LogicOperation -> GLenum+logicOperationToGLType a = case a of+ And -> GL_AND+ AndInverted -> GL_AND_INVERTED+ AndReverse -> GL_AND_REVERSE+ Clear -> GL_CLEAR+ Copy -> GL_COPY+ CopyInverted -> GL_COPY_INVERTED+ Equiv -> GL_EQUIV+ Invert -> GL_INVERT+ Nand -> GL_NAND+ Noop -> GL_NOOP+ Nor -> GL_NOR+ Or -> GL_OR+ OrInverted -> GL_OR_INVERTED+ OrReverse -> GL_OR_REVERSE+ Set -> GL_SET+ Xor -> GL_XOR++blendEquationToGLType :: BlendEquation -> GLenum+blendEquationToGLType a = case a of+ FuncAdd -> GL_FUNC_ADD+ FuncReverseSubtract -> GL_FUNC_REVERSE_SUBTRACT+ FuncSubtract -> GL_FUNC_SUBTRACT+ Max -> GL_MAX+ Min -> GL_MIN++blendingFactorToGLType :: BlendingFactor -> GLenum+blendingFactorToGLType a = case a of+ ConstantAlpha -> GL_CONSTANT_ALPHA+ ConstantColor -> GL_CONSTANT_COLOR+ DstAlpha -> GL_DST_ALPHA+ DstColor -> GL_DST_COLOR+ One -> GL_ONE+ OneMinusConstantAlpha -> GL_ONE_MINUS_CONSTANT_ALPHA+ OneMinusConstantColor -> GL_ONE_MINUS_CONSTANT_COLOR+ OneMinusDstAlpha -> GL_ONE_MINUS_DST_ALPHA+ OneMinusDstColor -> GL_ONE_MINUS_DST_COLOR+ OneMinusSrcAlpha -> GL_ONE_MINUS_SRC_ALPHA+ OneMinusSrcColor -> GL_ONE_MINUS_SRC_COLOR+ SrcAlpha -> GL_SRC_ALPHA+ SrcAlphaSaturate -> GL_SRC_ALPHA_SATURATE+ SrcColor -> GL_SRC_COLOR+ Zero -> GL_ZERO++textureDataTypeToGLType :: ImageSemantic -> TextureDataType -> GLenum+textureDataTypeToGLType Color a = case a of+ FloatT Red -> GL_R32F+ IntT Red -> GL_R32I+ WordT Red -> GL_R32UI+ FloatT RG -> GL_RG32F+ IntT RG -> GL_RG32I+ WordT RG -> GL_RG32UI+ FloatT RGBA -> GL_RGBA32F+ IntT RGBA -> GL_RGBA32I+ WordT RGBA -> GL_RGBA32UI+ a -> error $ "FIXME: This texture format is not yet supported" ++ show a+textureDataTypeToGLType Depth a = case a of+ FloatT Red -> GL_DEPTH_COMPONENT32F+ WordT Red -> GL_DEPTH_COMPONENT32+ a -> error $ "FIXME: This texture format is not yet supported" ++ show a+textureDataTypeToGLType Stencil a = case a of+ a -> error $ "FIXME: This texture format is not yet supported" ++ show a++textureDataTypeToGLArityType :: ImageSemantic -> TextureDataType -> GLenum+textureDataTypeToGLArityType Color a = case a of+ FloatT Red -> GL_RED+ IntT Red -> GL_RED+ WordT Red -> GL_RED+ FloatT RG -> GL_RG+ IntT RG -> GL_RG+ WordT RG -> GL_RG+ FloatT RGBA -> GL_RGBA+ IntT RGBA -> GL_RGBA+ WordT RGBA -> GL_RGBA+ a -> error $ "FIXME: This texture format is not yet supported" ++ show a+textureDataTypeToGLArityType Depth a = case a of+ FloatT Red -> GL_DEPTH_COMPONENT+ WordT Red -> GL_DEPTH_COMPONENT+ a -> error $ "FIXME: This texture format is not yet supported" ++ show a+textureDataTypeToGLArityType Stencil a = case a of+ a -> error $ "FIXME: This texture format is not yet supported" ++ show a+{-+Texture and renderbuffer color formats (R):+ R11F_G11F_B10F+ R16+ R16F+ R16I+ R16UI+ R32F+ R32I+ R32UI+ R8+ R8I+ R8UI+ RG16+ RG16F+ RG16I+ RG16UI+ RG32F+ RG32I+ RG32UI+ RG8+ RG8I+ RG8UI+ RGB10_A2+ RGB10_A2UI+ RGBA16+ RGBA16F+ RGBA16I+ RGBA16UI+ RGBA32F+ RGBA32I+ RGBA32UI+ RGBA8+ RGBA8I+ RGBA8UI+ SRGB8_ALPHA8+-}++glGetIntegerv1 :: GLenum -> IO GLint+glGetIntegerv1 e = alloca $ \pi -> glGetIntegerv e pi >> peek pi++checkFBO :: IO String+checkFBO = do+ let f e | e == GL_FRAMEBUFFER_UNDEFINED = "FRAMEBUFFER_UNDEFINED"+ | e == GL_FRAMEBUFFER_INCOMPLETE_ATTACHMENT = "FRAMEBUFFER_INCOMPLETE_ATTACHMENT"+ | e == GL_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER = "FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER"+ | e == GL_FRAMEBUFFER_INCOMPLETE_READ_BUFFER = "FRAMEBUFFER_INCOMPLETE_READ_BUFFER"+ | e == GL_FRAMEBUFFER_UNSUPPORTED = "FRAMEBUFFER_UNSUPPORTED"+ | e == GL_FRAMEBUFFER_INCOMPLETE_MULTISAMPLE = "FRAMEBUFFER_INCOMPLETE_MULTISAMPLE"+ | e == GL_FRAMEBUFFER_INCOMPLETE_LAYER_TARGETS = "FRAMEBUFFER_INCOMPLETE_LAYER_TARGETS"+ | e == GL_FRAMEBUFFER_COMPLETE = "FRAMEBUFFER_COMPLETE"+ | otherwise = "Unknown error"+ e <- glCheckFramebufferStatus GL_DRAW_FRAMEBUFFER+ return $ f e++filterToGLType :: Filter -> GLenum+filterToGLType a = case a of+ Nearest -> GL_NEAREST+ Linear -> GL_LINEAR+ NearestMipmapNearest -> GL_NEAREST_MIPMAP_NEAREST+ NearestMipmapLinear -> GL_NEAREST_MIPMAP_LINEAR+ LinearMipmapNearest -> GL_LINEAR_MIPMAP_NEAREST+ LinearMipmapLinear -> GL_LINEAR_MIPMAP_LINEAR++edgeModeToGLType :: EdgeMode -> GLenum+edgeModeToGLType a = case a of+ Repeat -> GL_REPEAT+ MirroredRepeat -> GL_MIRRORED_REPEAT+ ClampToEdge -> GL_CLAMP_TO_EDGE+ ClampToBorder -> GL_CLAMP_TO_BORDER++data ParameterSetup+ = ParameterSetup+ { setParameteri :: GLenum -> GLint -> IO ()+ , setParameterfv :: GLenum -> Ptr GLfloat -> IO ()+ , setParameterIiv :: GLenum -> Ptr GLint -> IO ()+ , setParameterIuiv :: GLenum -> Ptr GLuint -> IO ()+ , setParameterf :: GLenum -> GLfloat -> IO ()+ }++setTextureSamplerParameters :: GLenum -> SamplerDescriptor -> IO ()+setTextureSamplerParameters target = setParameters $ ParameterSetup+ { setParameteri = glTexParameteri target+ , setParameterfv = glTexParameterfv target+ , setParameterIiv = glTexParameterIiv target+ , setParameterIuiv = glTexParameterIuiv target+ , setParameterf = glTexParameterf target+ }++setSamplerParameters :: GLuint -> SamplerDescriptor -> IO ()+setSamplerParameters samplerObj = setParameters $ ParameterSetup+ { setParameteri = glSamplerParameteri samplerObj+ , setParameterfv = glSamplerParameterfv samplerObj+ , setParameterIiv = glSamplerParameterIiv samplerObj+ , setParameterIuiv = glSamplerParameterIuiv samplerObj+ , setParameterf = glSamplerParameterf samplerObj+ }++setParameters :: ParameterSetup -> SamplerDescriptor -> IO ()+setParameters ParameterSetup{..} s = do+ setParameteri GL_TEXTURE_WRAP_S $ fromIntegral $ edgeModeToGLType $ samplerWrapS s+ case samplerWrapT s of+ Nothing -> return ()+ Just a -> setParameteri GL_TEXTURE_WRAP_T $ fromIntegral $ edgeModeToGLType a+ case samplerWrapR s of+ Nothing -> return ()+ Just a -> setParameteri GL_TEXTURE_WRAP_R $ fromIntegral $ edgeModeToGLType a+ setParameteri GL_TEXTURE_MIN_FILTER $ fromIntegral $ filterToGLType $ samplerMinFilter s+ setParameteri GL_TEXTURE_MAG_FILTER $ fromIntegral $ filterToGLType $ samplerMagFilter s++ let setBColorV4F a = with a $ \p -> setParameterfv GL_TEXTURE_BORDER_COLOR $ castPtr p+ setBColorV4I a = with a $ \p -> setParameterIiv GL_TEXTURE_BORDER_COLOR $ castPtr p+ setBColorV4U a = with a $ \p -> setParameterIuiv GL_TEXTURE_BORDER_COLOR $ castPtr p+ case samplerBorderColor s of+ -- float, word, int, red, rg, rgb, rgba+ VFloat a -> setBColorV4F $ V4 a 0 0 0+ VV2F (V2 a b) -> setBColorV4F $ V4 a b 0 0+ VV3F (V3 a b c) -> setBColorV4F $ V4 a b c 0+ VV4F a -> setBColorV4F a++ VInt a -> setBColorV4I $ V4 a 0 0 0+ VV2I (V2 a b) -> setBColorV4I $ V4 a b 0 0+ VV3I (V3 a b c) -> setBColorV4I $ V4 a b c 0+ VV4I a -> setBColorV4I a++ VWord a -> setBColorV4U $ V4 a 0 0 0+ VV2U (V2 a b) -> setBColorV4U $ V4 a b 0 0+ VV3U (V3 a b c) -> setBColorV4U $ V4 a b c 0+ VV4U a -> setBColorV4U a+ _ -> fail "internal error (setTextureSamplerParameters)!"++ case samplerMinLod s of+ Nothing -> return ()+ Just a -> setParameterf GL_TEXTURE_MIN_LOD $ realToFrac a+ case samplerMaxLod s of+ Nothing -> return ()+ Just a -> setParameterf GL_TEXTURE_MAX_LOD $ realToFrac a+ setParameterf GL_TEXTURE_LOD_BIAS $ realToFrac $ samplerLodBias s+ case samplerCompareFunc s of+ Nothing -> setParameteri GL_TEXTURE_COMPARE_MODE $ fromIntegral GL_NONE+ Just a -> do+ setParameteri GL_TEXTURE_COMPARE_MODE $ fromIntegral GL_COMPARE_REF_TO_TEXTURE+ setParameteri GL_TEXTURE_COMPARE_FUNC $ fromIntegral $ comparisonFunctionToGLType a++compileSampler :: SamplerDescriptor -> IO GLSampler+compileSampler s = do+ so <- alloca $! \po -> glGenSamplers 1 po >> peek po+ setSamplerParameters so s+ return $ GLSampler+ { glSamplerObject = so+ }++compileTexture :: TextureDescriptor -> IO GLTexture+compileTexture txDescriptor = do+ to <- alloca $! \pto -> glGenTextures 1 pto >> peek pto+ let TextureDescriptor+ { textureType = txType+ , textureSize = txSize+ , textureSemantic = txSemantic+ , textureSampler = txSampler+ , textureBaseLevel = txBaseLevel+ , textureMaxLevel = txMaxLevel+ } = txDescriptor++ txSetup txTarget dTy = do+ let internalFormat = fromIntegral $ textureDataTypeToGLType txSemantic dTy+ dataFormat = fromIntegral $ textureDataTypeToGLArityType txSemantic dTy+ glBindTexture txTarget to+ glTexParameteri txTarget GL_TEXTURE_BASE_LEVEL $ fromIntegral txBaseLevel+ glTexParameteri txTarget GL_TEXTURE_MAX_LEVEL $ fromIntegral txMaxLevel+ setTextureSamplerParameters txTarget txSampler+ return (internalFormat,dataFormat)++ mipSize 0 x = [x]+ mipSize n x = x : mipSize (n-1) (x `div` 2)+ mipS = mipSize (txMaxLevel - txBaseLevel)+ levels = [txBaseLevel..txMaxLevel]+ target <- case txType of+ Texture1D dTy layerCnt -> do+ let VWord txW = txSize+ txTarget = if layerCnt > 1 then GL_TEXTURE_1D_ARRAY else GL_TEXTURE_1D+ (internalFormat,dataFormat) <- txSetup txTarget dTy+ forM_ (zip levels (mipS txW)) $ \(l,w) -> case layerCnt > 1 of+ True -> glTexImage2D txTarget (fromIntegral l) internalFormat (fromIntegral w) (fromIntegral layerCnt) 0 dataFormat GL_UNSIGNED_BYTE nullPtr+ False -> glTexImage1D txTarget (fromIntegral l) internalFormat (fromIntegral w) 0 dataFormat GL_UNSIGNED_BYTE nullPtr+ return txTarget+ Texture2D dTy layerCnt -> do+ let VV2U (V2 txW txH) = txSize+ txTarget = if layerCnt > 1 then GL_TEXTURE_2D_ARRAY else GL_TEXTURE_2D+ (internalFormat,dataFormat) <- txSetup txTarget dTy+ forM_ (zip3 levels (mipS txW) (mipS txH)) $ \(l,w,h) -> case layerCnt > 1 of+ True -> glTexImage3D txTarget (fromIntegral l) internalFormat (fromIntegral w) (fromIntegral h) (fromIntegral layerCnt) 0 dataFormat GL_UNSIGNED_BYTE nullPtr+ False -> glTexImage2D txTarget (fromIntegral l) internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat GL_UNSIGNED_BYTE nullPtr+ return txTarget+ Texture3D dTy -> do+ let VV3U (V3 txW txH txD) = txSize+ txTarget = GL_TEXTURE_3D+ (internalFormat,dataFormat) <- txSetup txTarget dTy+ forM_ (zip4 levels (mipS txW) (mipS txH) (mipS txD)) $ \(l,w,h,d) ->+ glTexImage3D txTarget (fromIntegral l) internalFormat (fromIntegral w) (fromIntegral h) (fromIntegral d) 0 dataFormat GL_UNSIGNED_BYTE nullPtr+ return txTarget+ TextureCube dTy -> do+ let VV2U (V2 txW txH) = txSize+ txTarget = GL_TEXTURE_CUBE_MAP+ targets =+ [ GL_TEXTURE_CUBE_MAP_POSITIVE_X + , GL_TEXTURE_CUBE_MAP_NEGATIVE_X+ , GL_TEXTURE_CUBE_MAP_POSITIVE_Y+ , GL_TEXTURE_CUBE_MAP_NEGATIVE_Y+ , GL_TEXTURE_CUBE_MAP_POSITIVE_Z+ , GL_TEXTURE_CUBE_MAP_NEGATIVE_Z+ ]+ (internalFormat,dataFormat) <- txSetup txTarget dTy+ forM_ (zip3 levels (mipS txW) (mipS txH)) $ \(l,w,h) -> + forM_ targets $ \t -> glTexImage2D t (fromIntegral l) internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat GL_UNSIGNED_BYTE nullPtr+ return txTarget+ TextureRect dTy -> do+ let VV2U (V2 txW txH) = txSize+ txTarget = GL_TEXTURE_RECTANGLE+ (internalFormat,dataFormat) <- txSetup txTarget dTy+ forM_ (zip3 levels (mipS txW) (mipS txH)) $ \(l,w,h) -> + glTexImage2D txTarget (fromIntegral l) internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat GL_UNSIGNED_BYTE nullPtr+ return txTarget+ Texture2DMS dTy layerCnt sampleCount isFixedLocations -> do+ let VV2U (V2 w h) = txSize+ txTarget = if layerCnt > 1 then GL_TEXTURE_2D_MULTISAMPLE_ARRAY else GL_TEXTURE_2D_MULTISAMPLE+ isFixed = fromIntegral $ if isFixedLocations then GL_TRUE else GL_FALSE+ (internalFormat,dataFormat) <- txSetup txTarget dTy+ case layerCnt > 1 of+ True -> glTexImage3DMultisample txTarget (fromIntegral sampleCount) internalFormat (fromIntegral w) (fromIntegral h) (fromIntegral layerCnt) isFixed+ False -> glTexImage2DMultisample txTarget (fromIntegral sampleCount) internalFormat (fromIntegral w) (fromIntegral h) isFixed+ return txTarget+ TextureBuffer dTy -> do+ fail "internal error: buffer texture is not supported yet"+ -- TODO+ let VV2U (V2 w h) = txSize+ txTarget = GL_TEXTURE_2D+ (internalFormat,dataFormat) <- txSetup txTarget dTy+ glTexImage2D GL_TEXTURE_2D 0 internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat GL_UNSIGNED_BYTE nullPtr+ return txTarget+ return $ GLTexture+ { glTextureObject = to+ , glTextureTarget = target+ }++primitiveToFetchPrimitive :: Primitive -> FetchPrimitive+primitiveToFetchPrimitive prim = case prim of+ TriangleStrip -> Triangles+ TriangleList -> Triangles+ TriangleFan -> Triangles+ LineStrip -> Lines+ LineList -> Lines+ PointList -> Points+ TriangleStripAdjacency -> TrianglesAdjacency+ TriangleListAdjacency -> TrianglesAdjacency+ LineStripAdjacency -> LinesAdjacency+ LineListAdjacency -> LinesAdjacency++primitiveToGLType :: Primitive -> GLenum+primitiveToGLType p = case p of+ TriangleStrip -> GL_TRIANGLE_STRIP+ TriangleList -> GL_TRIANGLES+ TriangleFan -> GL_TRIANGLE_FAN+ LineStrip -> GL_LINE_STRIP+ LineList -> GL_LINES+ PointList -> GL_POINTS+ TriangleStripAdjacency -> GL_TRIANGLE_STRIP_ADJACENCY+ TriangleListAdjacency -> GL_TRIANGLES_ADJACENCY+ LineStripAdjacency -> GL_LINE_STRIP_ADJACENCY+ LineListAdjacency -> GL_LINES_ADJACENCY++inputTypeToTextureTarget :: InputType -> GLenum+inputTypeToTextureTarget ty = case ty of+ STexture1D -> GL_TEXTURE_1D+ STexture2D -> GL_TEXTURE_2D+ STextureCube -> GL_TEXTURE_CUBE_MAP+ STexture1DArray -> GL_TEXTURE_1D_ARRAY+ STexture2DArray -> GL_TEXTURE_2D_ARRAY+ STexture2DRect -> GL_TEXTURE_RECTANGLE++ FTexture1D -> GL_TEXTURE_1D+ FTexture2D -> GL_TEXTURE_2D+ FTexture3D -> GL_TEXTURE_3D+ FTextureCube -> GL_TEXTURE_CUBE_MAP+ FTexture1DArray -> GL_TEXTURE_1D_ARRAY+ FTexture2DArray -> GL_TEXTURE_2D_ARRAY+ FTexture2DMS -> GL_TEXTURE_2D_MULTISAMPLE+ FTexture2DMSArray -> GL_TEXTURE_2D_MULTISAMPLE_ARRAY+ FTextureBuffer -> GL_TEXTURE_BUFFER+ FTexture2DRect -> GL_TEXTURE_RECTANGLE++ ITexture1D -> GL_TEXTURE_1D+ ITexture2D -> GL_TEXTURE_2D+ ITexture3D -> GL_TEXTURE_3D+ ITextureCube -> GL_TEXTURE_CUBE_MAP+ ITexture1DArray -> GL_TEXTURE_1D_ARRAY+ ITexture2DArray -> GL_TEXTURE_2D_ARRAY+ ITexture2DMS -> GL_TEXTURE_2D_MULTISAMPLE+ ITexture2DMSArray -> GL_TEXTURE_2D_MULTISAMPLE_ARRAY+ ITextureBuffer -> GL_TEXTURE_BUFFER+ ITexture2DRect -> GL_TEXTURE_RECTANGLE++ UTexture1D -> GL_TEXTURE_1D+ UTexture2D -> GL_TEXTURE_2D+ UTexture3D -> GL_TEXTURE_3D+ UTextureCube -> GL_TEXTURE_CUBE_MAP+ UTexture1DArray -> GL_TEXTURE_1D_ARRAY+ UTexture2DArray -> GL_TEXTURE_2D_ARRAY+ UTexture2DMS -> GL_TEXTURE_2D_MULTISAMPLE+ UTexture2DMSArray -> GL_TEXTURE_2D_MULTISAMPLE_ARRAY+ UTextureBuffer -> GL_TEXTURE_BUFFER+ UTexture2DRect -> GL_TEXTURE_RECTANGLE++ _ -> error "internal error (inputTypeToTextureTarget)!"
− src/lib/LambdaCube/GL.hs
@@ -1,297 +0,0 @@-module LambdaCube.GL (- -- language- module LambdaCube.Language.Type,- module LambdaCube.Language.ReifyType,- module LambdaCube.Language.HOAS,- module LambdaCube.Language,- Int32,- Word32,- uniformBool,- uniformV2B,- uniformV3B,- uniformV4B,-- uniformWord,- uniformV2U,- uniformV3U,- uniformV4U,-- uniformInt,- uniformV2I,- uniformV3I,- uniformV4I,-- uniformFloat,- uniformV2F,- uniformV3F,- uniformV4F,-- uniformM22F,- uniformM23F,- uniformM24F,- uniformM32F,- uniformM33F,- uniformM34F,- uniformM42F,- uniformM43F,- uniformM44F,-- uniformFTexture2D,-- -- backend- Buffer,- compileBuffer,- updateBuffer,- bufferSize,- arraySize,- arrayType,-- Renderer,- compileRenderer,- compileRendererFromCore,- slotUniform,- slotStream,- uniformSetter,- render,- dispose,- setScreenSize,- samplerOutput,-- Object,- addObject,- removeObject,- objectUniformSetter,- enableObject,-- -- texture (temporary)- compileTexture2DRGBAF,- updateTexture2DRGBAF,-- -- EDSL reuses types from Core- V2(..), V3(..), V4(..),- M22F, M23F, M24F, M32F, M33F, M34F, M42F, M43F, M44F,- V2F, V3F, V4F, V2I, V3I, V4I, V2U, V3U, V4U, V2B, V3B, V4B,- --InputType(..),- PointSpriteCoordOrigin(..),- PointSize(..),- PolygonOffset(..),- FrontFace(..),- PolygonMode(..),- ProvokingVertex(..),- CullMode(..),- DepthFunction,- ComparisonFunction(..),- StencilOperation(..),- BlendEquation(..),- BlendingFactor(..),- LogicOperation(..),- StencilOps(..),- StencilTests(..),- StencilTest(..),- Filter(..),- EdgeMode(..),-- -- types for pipeline input- InputSetter,- BufferSetter,- ArrayType(..),- Array(..),- Primitive(..),- StreamType(..),- Stream(..),- IndexStream(..),- TextureData(..),- SetterFun-) where--import Data.Int-import Data.Word--import LambdaCube.Core.Type--import LambdaCube.Language.ReifyType hiding (Shadow)-import LambdaCube.Language.Type-import LambdaCube.Language.HOAS-import LambdaCube.Language-import qualified LambdaCube.Language.Type as H-import qualified LambdaCube.Language.HOAS as H--import qualified LambdaCube.Core.DeBruijn as U-import LambdaCube.Convert.ToDeBruijn----import LambdaCube.GL.Backend hiding (compileRenderer)---import LambdaCube.GL.Compile-import LambdaCube.GL.Data-import LambdaCube.GL.Type---import LambdaCube.GL.Util (Buffer)-import qualified LambdaCube.GL.Backend as GL--import Control.Monad.State---import Data.ByteString.Char8 (ByteString)-import Data.ByteString.Char8 as SB-import Data.Trie as T--import LambdaCube.Core.Util.BiMap-import Data.List as L-import qualified Data.IntMap as IM--import System.IO as IO--compileRenderer :: H.GPOutput H.SingleOutput -> IO Renderer-compileRenderer l = compileRendererFromCore $ convertGPOutput l--compileRendererFromCore :: U.N -> IO Renderer-compileRendererFromCore l = do- let root = U.toExp dag l'- (l', dag) = runState (U.unN l) U.emptyDAG- U.DAG (BiMap _ em) tm _ _ _ = dag- unis = U.mkExpUni dag- gunis = U.mkGPUni dag- dag' = dag {U.expUniverseV = unis, U.gpUniverseV = gunis}- --print unis- --print gunis- print l'- mapM print $ L.zipWith (\(i,e) (_,t) -> (i,(t,e))) (IM.toList em) (IM.toList tm)-- --(root, dag) <- convert l- IO.hPutStrLn stderr "GL.compileRenderer"- GL.compileRenderer dag' root--nullSetter :: ByteString -> String -> a -> IO ()-nullSetter n t _ = return () -- Prelude.putStrLn $ "WARNING: unknown uniform: " ++ SB.unpack n ++ " :: " ++ t--uniformBool :: ByteString -> Trie InputSetter -> SetterFun Bool-uniformV2B :: ByteString -> Trie InputSetter -> SetterFun V2B-uniformV3B :: ByteString -> Trie InputSetter -> SetterFun V3B-uniformV4B :: ByteString -> Trie InputSetter -> SetterFun V4B--uniformWord :: ByteString -> Trie InputSetter -> SetterFun Word32-uniformV2U :: ByteString -> Trie InputSetter -> SetterFun V2U-uniformV3U :: ByteString -> Trie InputSetter -> SetterFun V3U-uniformV4U :: ByteString -> Trie InputSetter -> SetterFun V4U--uniformInt :: ByteString -> Trie InputSetter -> SetterFun Int32-uniformV2I :: ByteString -> Trie InputSetter -> SetterFun V2I-uniformV3I :: ByteString -> Trie InputSetter -> SetterFun V3I-uniformV4I :: ByteString -> Trie InputSetter -> SetterFun V4I--uniformFloat :: ByteString -> Trie InputSetter -> SetterFun Float-uniformV2F :: ByteString -> Trie InputSetter -> SetterFun V2F-uniformV3F :: ByteString -> Trie InputSetter -> SetterFun V3F-uniformV4F :: ByteString -> Trie InputSetter -> SetterFun V4F--uniformM22F :: ByteString -> Trie InputSetter -> SetterFun M22F-uniformM23F :: ByteString -> Trie InputSetter -> SetterFun M23F-uniformM24F :: ByteString -> Trie InputSetter -> SetterFun M24F-uniformM32F :: ByteString -> Trie InputSetter -> SetterFun M32F-uniformM33F :: ByteString -> Trie InputSetter -> SetterFun M33F-uniformM34F :: ByteString -> Trie InputSetter -> SetterFun M34F-uniformM42F :: ByteString -> Trie InputSetter -> SetterFun M42F-uniformM43F :: ByteString -> Trie InputSetter -> SetterFun M43F-uniformM44F :: ByteString -> Trie InputSetter -> SetterFun M44F--uniformFTexture2D :: ByteString -> Trie InputSetter -> SetterFun TextureData--uniformBool n is = case T.lookup n is of- Just (SBool (Setter fun)) -> fun- _ -> nullSetter n "Bool"--uniformV2B n is = case T.lookup n is of- Just (SV2B (Setter fun)) -> fun- _ -> nullSetter n "V2B"--uniformV3B n is = case T.lookup n is of- Just (SV3B (Setter fun)) -> fun- _ -> nullSetter n "V3B"--uniformV4B n is = case T.lookup n is of- Just (SV4B (Setter fun)) -> fun- _ -> nullSetter n "V4B"--uniformWord n is = case T.lookup n is of- Just (SWord (Setter fun)) -> fun- _ -> nullSetter n "Word"--uniformV2U n is = case T.lookup n is of- Just (SV2U (Setter fun)) -> fun- _ -> nullSetter n "V2U"--uniformV3U n is = case T.lookup n is of- Just (SV3U (Setter fun)) -> fun- _ -> nullSetter n "V3U"--uniformV4U n is = case T.lookup n is of- Just (SV4U (Setter fun)) -> fun- _ -> nullSetter n "V4U"--uniformInt n is = case T.lookup n is of- Just (SInt (Setter fun)) -> fun- _ -> nullSetter n "Int"--uniformV2I n is = case T.lookup n is of- Just (SV2I (Setter fun)) -> fun- _ -> nullSetter n "V2I"--uniformV3I n is = case T.lookup n is of- Just (SV3I (Setter fun)) -> fun- _ -> nullSetter n "V3I"--uniformV4I n is = case T.lookup n is of- Just (SV4I (Setter fun)) -> fun- _ -> nullSetter n "V4I"--uniformFloat n is = case T.lookup n is of- Just (SFloat (Setter fun)) -> fun- _ -> nullSetter n "Float"--uniformV2F n is = case T.lookup n is of- Just (SV2F (Setter fun)) -> fun- _ -> nullSetter n "V2F"--uniformV3F n is = case T.lookup n is of- Just (SV3F (Setter fun)) -> fun- _ -> nullSetter n "V3F"--uniformV4F n is = case T.lookup n is of- Just (SV4F (Setter fun)) -> fun- _ -> nullSetter n "V4F"--uniformM22F n is = case T.lookup n is of- Just (SM22F (Setter fun)) -> fun- _ -> nullSetter n "M22F"--uniformM23F n is = case T.lookup n is of- Just (SM23F (Setter fun)) -> fun- _ -> nullSetter n "M23F"--uniformM24F n is = case T.lookup n is of- Just (SM24F (Setter fun)) -> fun- _ -> nullSetter n "M24F"--uniformM32F n is = case T.lookup n is of- Just (SM32F (Setter fun)) -> fun- _ -> nullSetter n "M32F"--uniformM33F n is = case T.lookup n is of- Just (SM33F (Setter fun)) -> fun- _ -> nullSetter n "M33F"--uniformM34F n is = case T.lookup n is of- Just (SM34F (Setter fun)) -> fun- _ -> nullSetter n "M34F"--uniformM42F n is = case T.lookup n is of- Just (SM42F (Setter fun)) -> fun- _ -> nullSetter n "M42F"--uniformM43F n is = case T.lookup n is of- Just (SM43F (Setter fun)) -> fun- _ -> nullSetter n "M43F"--uniformM44F n is = case T.lookup n is of- Just (SM44F (Setter fun)) -> fun- _ -> nullSetter n "M44F"--uniformFTexture2D n is = case T.lookup n is of- Just (SFTexture2D (Setter fun)) -> fun- _ -> nullSetter n "FTexture2D"
− src/lib/LambdaCube/GL/Backend.hs
@@ -1,427 +0,0 @@-module LambdaCube.GL.Backend where--import Debug.Trace--import Control.Applicative-import Control.Monad-import Data.ByteString.Char8 (ByteString)-import Data.IORef-import Data.List as L-import Data.Maybe-import Data.Set (Set)-import Data.Map (Map)-import Data.Trie as T-import Foreign-import qualified Data.ByteString.Char8 as SB-import qualified Data.IntMap as IntMap-import qualified Data.Map as Map-import qualified Data.Set as Set-import qualified Data.Traversable as T-import qualified Data.Vector as V-import qualified Data.Vector.Unboxed.Mutable as MV--import Graphics.Rendering.OpenGL.Raw.Core32- ( GLuint- -- FRAMEBUFFER related *- -- create- , glBindFramebuffer- , glDeleteFramebuffers- , glGenFramebuffers- -- content manipulation- , glActiveTexture- , glBindRenderbuffer- , glBindTexture- , glDeleteTextures- , glDrawBuffer- , glDrawBuffers- , glFramebufferRenderbuffer- , glFramebufferTexture- , glFramebufferTexture2D- , glGenRenderbuffers- , glRenderbufferStorage- , glViewport- , gl_BACK_LEFT- , gl_COLOR_ATTACHMENT0- , gl_DEPTH_ATTACHMENT- , gl_DEPTH_COMPONENT32- , gl_DRAW_FRAMEBUFFER- , gl_MAX_COMBINED_TEXTURE_IMAGE_UNITS- , gl_NONE- , gl_RENDERBUFFER- , gl_TEXTURE0- , gl_TEXTURE_2D- , gl_UNSIGNED_BYTE- , glTexImage2D- , gl_TEXTURE_2D_ARRAY- , glTexImage3D- , gl_TEXTURE_MAX_LEVEL- , glTexParameteri- , gl_TEXTURE_BASE_LEVEL- , gl_NEAREST- , gl_TEXTURE_MIN_FILTER- , gl_TEXTURE_MAG_FILTER- , gl_CLAMP_TO_EDGE- , gl_TEXTURE_WRAP_S- , gl_TEXTURE_WRAP_T- , gl_DEPTH_COMPONENT32- , gl_DEPTH_COMPONENT- , glGenTextures- )--import LambdaCube.Core.Type-import LambdaCube.Core.DeBruijn-import LambdaCube.Core.Traversals-import LambdaCube.Core.Util.BiMap--import LambdaCube.GL.Type-import LambdaCube.GL.Util-import LambdaCube.GL.GLSLCodeGen-import LambdaCube.GL.Compile--import qualified Data.IntMap as IM--- Renderer--nubS :: Ord a => [a] -> [a]-nubS = Set.toList . Set.fromList--findFetch :: DAG -> Exp -> Maybe Exp-findFetch dag f = listToMaybe [a | a@Fetch {} <- drawOperations dag f]-------------------------------- odered according pass dependency (topology order)-{--findFrameBuffer-gpUniverse--}-orderedFrameBuffersFromGP :: DAG -> Exp -> [Exp]-orderedFrameBuffersFromGP dag r = es --[e | e@(Accumulate{}) <- IM.elems m]- where- rfb = findFrameBuffer dag r- txl = concat [map (findFrameBuffer dag . toExp dag) l | Texture _ _ _ l <- IM.elems m]- es = map (toExp dag) . nubS . map (toExpId dag) $ rfb : txl- BiMap _ m = dagExp dag-{--orderedFrameBuffersFromGP dag orig = order deps- where - deps :: Map Exp (Set Exp)- deps = add Map.empty $ findFrameBuffer dag orig-- add :: Map Exp (Set Exp) -> Exp -> Map Exp (Set Exp)- add m fb = Map.unionsWith Set.union $ m' : map (add m') fbl- where- m' = Map.alter fun fb m- fbl = concat [map (findFrameBuffer dag . toExp dag) l | Sampler _ _ tx <- concatMap (expUniverse' dag) (gpUniverse' dag fb), Texture _ _ _ l <- [toExp dag tx]]- fbs = Set.fromList fbl- fun Nothing = Just fbs- fun (Just a) = Just (a `Set.union` fbs)-- order :: Map Exp (Set Exp) -> [Exp]- order d- | Map.null d = []- | otherwise = leaves ++ order (Map.map (Set.\\ (Set.fromList leaves)) hasDeps)- where- leaves = Map.keys noDeps- (noDeps,hasDeps) = Map.partition Set.null d--}------------------------------printGLStatus = checkGL >>= print_-printFBOStatus = checkFBO >>= print_--mkSlotDescriptor :: Set Exp -> IO SlotDescriptor-mkSlotDescriptor gps = SlotDescriptor gps <$> newIORef Set.empty--mkRenderTextures :: DAG -> [Exp] -> Maybe (ByteString,Exp) -> IO (Map Exp String, Map Exp String, Map Exp GLuint, IO (), Exp -> [Exp])-mkRenderTextures dag allGPs samplerOutData = do- let samplers = nubS $ [s | s@Sampler {} <- expUniverse' dag allGPs] ++ [smp | (_,smp) <- maybeToList samplerOutData]- samplersWithTexture = nubS [s | s@(Sampler _ _ tx) <- samplers, Texture {} <- [toExp dag tx]]- -- collect all render textures refers to a FrameBuffer- isReferred :: Exp -> Exp -> Bool- isReferred f (Sampler _ _ tx) = findFrameBuffer dag (toExp dag f') == f- where- Texture _ _ _ [f'] = toExp dag tx- isReferred _ _ = False- dependentSamplers f = filter (isReferred f) samplersWithTexture- -- texture attributes: GL texture target (1D,2D,etc), arity, float/word/int, size, mipmap- -- sampler attributes: filter, edge mode- -- TODO: also build sampler name map: Map (Exp :: Sampler) (ByteString, GLTexObj)-- -- question: how should we handle the Stencil and Depth textures at multipass rendering- (renderTexNameList,renderTexGLObjList,disposeTex) <- fmap unzip3 $ forM (zip [0..] samplersWithTexture) $ \(sIdx,smp) -> do- to <- createGLTextureObject dag smp- putStr (" -- Render Texture " ++ show sIdx ++ "(texture object " ++ show to ++ "): ") >> printGLStatus >> putStrLn ""- return ((smp,"renderTex_" ++ show sIdx),(smp,to),with to $ \pto -> glDeleteTextures 1 pto)- let renderTexName = Map.fromList renderTexNameList- renderTexGLObj = Map.fromList renderTexGLObjList- texSlotName = Map.fromList $ nubS [(s,SB.unpack n) | s@(Sampler _ _ txExp) <- samplers, TextureSlot n _ <- [toExp dag txExp]]- return (texSlotName, renderTexName, renderTexGLObj, sequence_ disposeTex, dependentSamplers)--mkRenderDescriptor :: T.Trie InputGetter -> DAG -> RenderState -> Map Exp String -> Map Exp String -> Map Exp GLuint -> Exp -> IO RenderDescriptor-mkRenderDescriptor uniformGetterTrie dag rendState texSlotName renderTexName renderTexGLObj f = case f of- FrameBuffer imgs -> RenderDescriptor T.empty T.empty (compileClearFrameBuffer f) (return ()) <$> newIORef (ObjectSet (return ()) Map.empty) <*> pure (length [() | ColorImage {} <- imgs])- Accumulate {} -> do- {- - setup texture input, before each slot's render operation we should setup texture unit mapping- - we have to create the TextureUnit layout- - create TextureUnit setter action- - the shader should be setup at the creation- - we have to setup texture binding before each render action call- -}- let usedRenderSamplers = nubS [s | s@(Sampler _ _ te) <- expUniverse' dag f, Texture {} <- [toExp dag te]]- usedSlotSamplers = nubS [s | s@(Sampler _ _ te) <- expUniverse' dag f, TextureSlot {} <- [toExp dag te]]- usedRenderTexName = [(s,n) | s <- usedRenderSamplers, let Just n = Map.lookup s renderTexName]- usedTexSlotName = [(s,n) | s <- usedSlotSamplers, let Just n = Map.lookup s texSlotName]- renderTexObjs = [txObj | s <- usedRenderSamplers, let Just txObj = Map.lookup s renderTexGLObj]- texUnitState = textureUnitState rendState- textureSetup = forM_ (zip renderTexObjs [0.. MV.length texUnitState-1]) $ \(texObj,texUnitIdx) -> do- let texObj' = fromIntegral texObj- curTexObj <- MV.read texUnitState texUnitIdx- when (curTexObj /= texObj') $ do- MV.write texUnitState texUnitIdx texObj'- glActiveTexture $ gl_TEXTURE0 + fromIntegral texUnitIdx- glBindTexture gl_TEXTURE_2D texObj- putStrLn_ $ "CMD: glActiveTexture " ++ show texUnitIdx- putStrLn_ $ "CMD: glBindTexture gl_TEXTURE_2D " ++ show texObj- --putStr (" -- Texture bind (TexUnit " ++ show (texUnitIdx,texObj) ++ " TexObj): ") >> printGLStatus >> putStrLn ""-- drawRef <- newIORef $ ObjectSet (return ()) Map.empty- (rA,dA,uT,sT,outColorCnt) <- compileRenderFrameBuffer rendState uniformGetterTrie dag usedRenderTexName usedTexSlotName drawRef f- return $ RenderDescriptor- { uniformLocation = uT- , streamLocation = sT- , renderAction = textureSetup >> rA- , disposeAction = dA- , drawObjectsIORef = drawRef- , fragmentOutCount = outColorCnt- }- _ -> error $ "GP node type error: should be FrameBuffer but got: " ++ (head $ (words $ show f) ++ [])---- FIXME: currently we expect ScreenOut to be the last operation-mkPassSetup :: IORef (Word,Word) -> RenderState -> DAG -> Map Exp GLuint -> (Exp -> [Exp]) -> (Bool,Int,Int) -> Exp -> IO (IO (), IO ())-mkPassSetup screenSizeIORef rendState dag renderTexGLObj dependentSamplers (isLast,outIdx,outCnt) fb = case isLast of- True -> do- putStrLn $ " -- last pass output count: " ++ show outCnt ++ " outIdx: " ++ show outIdx- let setup = do- (screenW,screenH) <- readIORef screenSizeIORef- writeIORef (renderTargetSize rendState) $ V2 (fromIntegral screenW) (fromIntegral screenH)- glViewport 0 0 (fromIntegral screenW) (fromIntegral screenH)- putStrLn_ $ "CMD: glBindFramebuffer gl_DRAW_FRAMEBUFFER 0"- glBindFramebuffer gl_DRAW_FRAMEBUFFER 0- let fboMapping = [if i == outIdx then gl_BACK_LEFT else gl_NONE | i <- [1..outCnt]]- withArray fboMapping $ glDrawBuffers (fromIntegral $ length fboMapping)- --putStr " -- default FB bind: " >> printGLStatus >> putStrLn ""- return (setup,return ())- False -> do- -- setup each pass's FBO output, attach RenderTarget textures to source FBO- putStrLn " -- FBO init: "-- glFBO <- alloca $! \pbo -> glGenFramebuffers 1 pbo >> peek pbo- putStr " - alloc: " >> printGLStatus >> putStrLn ""- glBindFramebuffer gl_DRAW_FRAMEBUFFER glFBO- putStr " - bind: " >> printGLStatus >> putStrLn ""- let depSamplers = dependentSamplers fb- hasDepthOp = case fb of- Accumulate aCtx _ _ _ _ -> not $ L.null [() | DepthOp {} <- ops]- where AccumulationContext _ ops = toExp dag aCtx- FrameBuffer imgs -> not $ L.null [() | DepthImage {} <- imgs]- ----------- -- FIXME: samplers must contain the fragment value's output index!- ----------- (layerCnts,texSizes,fboMapping) <- fmap unzip3 $ forM (zip [0..] depSamplers) $ \(i,smp) -> do- let Sampler _ _ txExp = smp- Texture txType ts NoMip [prjFBExp] = toExp dag txExp- PrjFrameBuffer _ prjIdx _ = toExp dag prjFBExp- Just txObj = Map.lookup smp renderTexGLObj- colorNumber = outCnt - prjIdx - 1- attachSingleLayer = glFramebufferTexture2D gl_DRAW_FRAMEBUFFER (gl_COLOR_ATTACHMENT0 + fromIntegral i) gl_TEXTURE_2D txObj 0- attachMultiLayer = glFramebufferTexture gl_DRAW_FRAMEBUFFER (gl_COLOR_ATTACHMENT0 + fromIntegral i) txObj 0- lc <- case txType of- Texture2D _ ln- | ln <= 1 -> attachSingleLayer >> return ln- | otherwise -> attachMultiLayer >> return ln- TextureCube _ -> attachMultiLayer >> return 6- putStr (" - attach to color slot #" ++ show i ++ " texture object #" ++ show txObj ++ " with color number #" ++ show colorNumber ++ ": ") >> printGLStatus >> putStrLn ""- return (lc, ts, (colorNumber,gl_COLOR_ATTACHMENT0 + fromIntegral i)) -- FIXME: calculate FBO attachment index properly, index reffered from right- let fboMappingMap = IntMap.fromList fboMapping- fboMappingList = [IntMap.findWithDefault gl_NONE i fboMappingMap | i <- [0..outCnt-1]]- withArray fboMappingList $ glDrawBuffers $ fromIntegral outCnt- putStrLn $ " - FBO mapping: " ++ show [if i == gl_NONE then "gl_NONE" else ("gl_COLOR_ATTACHMENT" ++ (show $ i - gl_COLOR_ATTACHMENT0)) | i <- fboMappingList]- putStr " - mappig setup: " >> printGLStatus >> putStrLn ""-- -- check all texture size maches- unless (all (== head (texSizes ++ error "texSizes")) texSizes) $ error ("Framebuffer attachment size mismatch! \n" ++ " - sizes: " ++ show texSizes)- -- create and attach depth buffer- let VV2U (V2 depthW depthH) = head $ texSizes ++ error "texSizes2"- when hasDepthOp $ do- {-- depthTex <- alloca $! \pto -> glGenRenderbuffers 1 pto >> peek pto- putStr " - alloc depth texture: " >> printGLStatus >> putStrLn ""- glBindRenderbuffer gl_RENDERBUFFER depthTex- putStr " - bind depth texture: " >> printGLStatus >> putStrLn ""- glRenderbufferStorage gl_RENDERBUFFER gl_DEPTH_COMPONENT32 (fromIntegral depthW) (fromIntegral depthH)- putStr " - define depth texture: " >> printGLStatus >> putStrLn ""- glFramebufferRenderbuffer gl_DRAW_FRAMEBUFFER gl_DEPTH_ATTACHMENT gl_RENDERBUFFER depthTex- putStr " - attach depth texture: " >> printGLStatus >> putStrLn ""- -}- depthTex <- alloca $! \pto -> glGenTextures 1 pto >> peek pto- putStr " - alloc depth texture: " >> printGLStatus >> putStrLn ""- let layerCnt = head $ layerCnts ++ error "layerCnts"- txTarget = if layerCnt > 1 then gl_TEXTURE_2D_ARRAY else gl_TEXTURE_2D- internalFormat = fromIntegral gl_DEPTH_COMPONENT --32- dataFormat = fromIntegral gl_DEPTH_COMPONENT- glBindTexture txTarget depthTex- putStr " - bind depth texture: " >> printGLStatus >> putStrLn ""- -- temp- glTexParameteri txTarget gl_TEXTURE_WRAP_S $ fromIntegral gl_CLAMP_TO_EDGE- glTexParameteri txTarget gl_TEXTURE_WRAP_T $ fromIntegral gl_CLAMP_TO_EDGE- glTexParameteri txTarget gl_TEXTURE_MAG_FILTER $ fromIntegral gl_NEAREST- glTexParameteri txTarget gl_TEXTURE_MIN_FILTER $ fromIntegral gl_NEAREST- glTexParameteri txTarget gl_TEXTURE_BASE_LEVEL 0- glTexParameteri txTarget gl_TEXTURE_MAX_LEVEL 0- -- temp end- case layerCnt > 1 of- True -> glTexImage3D gl_TEXTURE_2D_ARRAY 0 internalFormat (fromIntegral depthW) (fromIntegral depthH) (fromIntegral layerCnt) 0 dataFormat gl_UNSIGNED_BYTE nullPtr- False -> glTexImage2D gl_TEXTURE_2D 0 internalFormat (fromIntegral depthW) (fromIntegral depthH) 0 dataFormat gl_UNSIGNED_BYTE nullPtr- putStr " - define depth texture: " >> printGLStatus >> putStrLn ""- case layerCnt > 1 of- True -> glFramebufferTexture gl_DRAW_FRAMEBUFFER gl_DEPTH_ATTACHMENT depthTex 0- False -> glFramebufferTexture2D gl_DRAW_FRAMEBUFFER gl_DEPTH_ATTACHMENT gl_TEXTURE_2D depthTex 0- putStr " - attach depth texture: " >> printGLStatus >> putStrLn ""--- putStr " - check FBO completeness: " >> printFBOStatus >> putStrLn ""-- let renderAct = do- --printGLStatus >> putStrLn ""- putStrLn_ $ "CMD: glBindFramebuffer gl_DRAW_FRAMEBUFFER " ++ show glFBO- glBindFramebuffer gl_DRAW_FRAMEBUFFER glFBO- printGLStatus- writeIORef (renderTargetSize rendState) $ V2 (fromIntegral depthW) (fromIntegral depthH)- glViewport 0 0 (fromIntegral depthW) (fromIntegral depthH)- --putStr " -- FBO bind: " >> printGLStatus >> putStrLn ""- --putStr " -- FBO status: " >> printFBOStatus >> putStrLn ""- disposeAct = do- with glFBO $ \pbo -> glDeleteFramebuffers 1 pbo- --with depthTex $ \pto -> glDeleteTextures 1 pto- return (renderAct,disposeAct)--mkRenderState :: IO RenderState-mkRenderState = do- maxTextureUnits <- glGetIntegerv1 gl_MAX_COMBINED_TEXTURE_IMAGE_UNITS- texUnitState <- MV.new $ fromIntegral maxTextureUnits- MV.set texUnitState (-1)- rtSize <- newIORef $ V2 0 0- return $ RenderState- { textureUnitState = texUnitState- , renderTargetSize = rtSize- }-{-- Note: Input mapping problem- more programs use the same slot -> minimize vertex attribute mapping collisions (best case: use the same mapping)- more programs use the same uniform -> minimize uniform mapping collisions (best case: use the same mapping)--}--- FIXME: implement properly-compileRenderer :: DAG -> Exp -> IO Renderer-compileRenderer dag outExp = do- let (samplerOutData,gp,idx) = case outExp of- ScreenOut img -> (Nothing,toExp dag gpId,idx)- where- PrjFrameBuffer n idx gpId = toExp dag img- SamplerOut outName smpIdx -> (Just (outName,smp),toExp dag gpId,idx)- where- smp@(Sampler _ _ tex) = toExp dag smpIdx- Texture _ _ _ [img] = toExp dag tex- PrjFrameBuffer n idx gpId = toExp dag img-- unis :: Exp -> [(ByteString,InputType)]- unis fb = nubS [(name,t) | u@(Uni name) <- expUniverse' dag fb, let [t] = codeGenType $ expType dag u] ++- nubS [(name,t) | s@(Sampler _ _ ts) <- expUniverse' dag fb- , TextureSlot name _ <- [toExp dag ts]- , let [t] = codeGenType $ expType dag s]-- ordFBs = orderedFrameBuffersFromGP dag gp- allGPs = Set.toList $ Set.unions $ map (Set.fromList . gpUniverse' dag) $ nubS ordFBs-- -- collect slot info: name, primitive type, stream input, uniform input- (slotStreamList, slotUniformList, slotGPList) = unzip3- [ (T.singleton name (primType,T.fromList inputs)- ,T.singleton name (T.fromList $ unis fb)- ,T.singleton name (Set.singleton fb))- | fb <- concatMap (renderChain dag) ordFBs- , Fetch name primType inputs <- maybeToList $ findFetch dag fb- ]- slotStreamTrie = foldl' (T.mergeBy (\(a1,a2) (b1,b2) -> Just (a1, T.unionL a2 b2))) T.empty slotStreamList- slotUniformTrie = foldl' (T.mergeBy (\a b -> Just (T.unionL a b))) T.empty slotUniformList- (uniformNames,uniformTypes) = unzip $ nubS $ concatMap (T.toList . snd) $ T.toList slotUniformTrie-- putStrLn_ "calculate exp universe..."- print_ $ map (toExpId dag) ordFBs- print_ ordFBs- putStrLn_ $ "Exp universe size: " ++ show (length (nubS $ expUniverse' dag gp))- putStrLn_ $ "ord GP size: " ++ show (length ordFBs)- putStrLn_ $ "GP universe size: " ++ show (length allGPs)-- -- create RenderState- rendState <- mkRenderState-- (uSetup,uSetter,uGetter) <- unzip3 <$> mapM (mkUniformSetter rendState) uniformTypes- let uniformSetterTrie = T.fromList $! zip uniformNames uSetter- uniformGetterTrie = T.fromList $! zip uniformNames uGetter- mkUniformSetupTrie = T.fromList $! zip uniformNames uSetup-- slotGP :: Trie (Set Exp)- slotGP = foldl' (T.mergeBy (\a b -> Just $ Set.union a b)) T.empty slotGPList-- -- create SlotDescriptors (input setup)- slotDescriptors <- T.fromList <$> mapM (\(n,a) -> (n,) <$> mkSlotDescriptor a) (T.toList slotGP)-- -- allocate render textures (output resource initialization)- (texSlotName,renderTexName,renderTexGLObj,renderTexDispose,dependentSamplers) <- mkRenderTextures dag allGPs samplerOutData-- -- create RenderDescriptors- renderDescriptors <- Map.fromList <$> mapM (\a -> (a,) <$> mkRenderDescriptor uniformGetterTrie dag rendState texSlotName renderTexName renderTexGLObj a) (nubS $ concatMap (renderChain dag) ordFBs)-- -- create IORef for ScreenOut Size- screenSizeIORef <- newIORef (0,0)-- putStrLn ("number of passes: " ++ show (length ordFBs))- -- join compiled graphics network components- (passRender,passDispose) <- fmap unzip $ forM (zip ordFBs [1..]) $ \(fb,passNo) -> do- let (drawList, disposeList) = unzip [(renderAction rd, disposeAction rd) | f <- renderChain dag fb, let Just rd = Map.lookup f renderDescriptors]- let Just rd = Map.lookup fb renderDescriptors- putStrLn ("pass #" ++ show passNo)- putStrLn (" - draw count: " ++ show (length drawList))- (passSetup,passDispose) <- mkPassSetup screenSizeIORef rendState dag renderTexGLObj dependentSamplers (samplerOutData == Nothing && fb == gp,fragmentOutCount rd - idx, fragmentOutCount rd) fb- return (passSetup >> sequence_ drawList, passDispose >> sequence_ disposeList)-- -- debug- putStrLn $ "number of passes: " ++ show (length ordFBs) ++ " is output the last? " ++ show (findFrameBuffer dag gp == last ordFBs)-- -- TODO: validate- -- all slot name should be unique- -- all uniform with same name have the same type- -- all stream input with same name have the same type- objIDSeed <- newIORef 1- return $! Renderer- -- public- { slotUniform = slotUniformTrie- , slotStream = slotStreamTrie- , uniformSetter = uniformSetterTrie- , render = do- --print_ " * Frame Started"- putStrLn_ "CMD: render frame started"- MV.set (textureUnitState rendState) (-1)-- sequence_ passRender- --print_ " * Frame Ended"- , dispose = renderTexDispose >> sequence_ passDispose- , setScreenSize = \w h -> writeIORef screenSizeIORef (w,h)- , samplerOutput = T.fromList [(n,TextureData $ renderTexGLObj Map.! s) | (n,s) <- maybeToList samplerOutData]-- -- internal- , mkUniformSetup = mkUniformSetupTrie- , slotDescriptor = slotDescriptors- , renderDescriptor = renderDescriptors- , renderState = rendState- , objectIDSeed = objIDSeed- }
− src/lib/LambdaCube/GL/Compile.hs
@@ -1,589 +0,0 @@-module LambdaCube.GL.Compile where--import Control.Applicative hiding (Const)-import Control.Monad-import Data.ByteString.Char8 (ByteString)-import Data.IORef-import Data.List as L-import Data.Maybe-import Data.Set (Set)-import Data.Map (Map)-import Data.Trie as T-import Foreign-import qualified Data.ByteString.Char8 as SB-import qualified Data.Set as Set-import qualified Data.Map as Map-import qualified Data.Traversable as T-import qualified Data.Vector as V--import Graphics.Rendering.OpenGL.Raw.Core32- ( GLboolean- , GLenum- , GLint- , GLuint- , glDisable- , glEnable- , gl_TRUE-- -- SHADER PROGRAM related *- , glAttachShader- , glBindFragDataLocation- , glCreateProgram- , glCreateShader- , glDeleteProgram- , glDeleteShader- , glLinkProgram- , glUseProgram- , gl_FRAGMENT_SHADER- , gl_GEOMETRY_SHADER- , gl_LINK_STATUS- , gl_VERTEX_SHADER-- -- ACCUMULATION CONTEXT related *- , glViewport- -- blending- , glBlendColor- , glBlendEquationSeparate- , glBlendFuncSeparate- , gl_BLEND- -- logic operation- , glLogicOp- , gl_COLOR_LOGIC_OP- -- framebuffer related- , glClear- , glClearColor- , glClearDepth- , glColorMask- , gl_COLOR_BUFFER_BIT- , gl_DEPTH_BUFFER_BIT- -- depth and stencil filter functions- , glDepthFunc- , glDepthMask- , gl_DEPTH_TEST- , gl_STENCIL_TEST-- -- RASTER CONTEXT related *- , glProvokingVertex- , gl_FIRST_VERTEX_CONVENTION- , gl_LAST_VERTEX_CONVENTION- -- point- , glPointParameterf- , glPointSize- , gl_LOWER_LEFT- , gl_POINT_FADE_THRESHOLD_SIZE- , gl_POINT_SPRITE_COORD_ORIGIN- , gl_PROGRAM_POINT_SIZE- , gl_UPPER_LEFT- -- line- , glLineWidth- -- triangle- , glCullFace- , glFrontFace- , glPolygonMode- , glPolygonOffset- , gl_BACK- , gl_CCW- , gl_CULL_FACE- , gl_CW- , gl_FILL- , gl_FRONT- , gl_FRONT_AND_BACK- , gl_LINE- , gl_POINT- , gl_POLYGON_OFFSET_FILL- , gl_POLYGON_OFFSET_LINE- , gl_POLYGON_OFFSET_POINT- -- debug- )--import LambdaCube.Core.Type-import LambdaCube.Core.DeBruijn-import LambdaCube.Core.Traversals--import LambdaCube.GL.Type-import LambdaCube.GL.Util-import LambdaCube.GL.GLSLCodeGen--data ShaderSource- = VertexShaderSrc !ByteString- | GeometryShaderSrc !ByteString- | FragmentShaderSrc !ByteString--setupRasterContext :: RasterContext -> IO ()-setupRasterContext = cvt- where- cff :: FrontFace -> GLenum- cff CCW = gl_CCW- cff CW = gl_CW-- setProvokingVertex :: ProvokingVertex -> IO ()- setProvokingVertex pv = glProvokingVertex $ case pv of- FirstVertex -> gl_FIRST_VERTEX_CONVENTION- LastVertex -> gl_LAST_VERTEX_CONVENTION-- setPointSize :: PointSize -> IO ()- setPointSize ps = case ps of- ProgramPointSize -> glEnable gl_PROGRAM_POINT_SIZE- PointSize s -> do- glDisable gl_PROGRAM_POINT_SIZE- glPointSize $ realToFrac s-- cvt :: RasterContext -> IO ()- cvt (PointCtx ps fts sc) = do- setPointSize ps- glPointParameterf gl_POINT_FADE_THRESHOLD_SIZE (realToFrac fts)- glPointParameterf gl_POINT_SPRITE_COORD_ORIGIN $ realToFrac $ case sc of- LowerLeft -> gl_LOWER_LEFT- UpperLeft -> gl_UPPER_LEFT-- cvt (LineCtx lw pv) = do- glLineWidth (realToFrac lw)- setProvokingVertex pv-- cvt (TriangleCtx cm pm po pv) = do- let printGLStatus = checkGL >>= print_-- putStrLn_ "TriangleCtx 1" >> printGLStatus- -- cull mode- case cm of- CullNone -> glDisable gl_CULL_FACE- CullFront f -> do- glEnable gl_CULL_FACE- glCullFace gl_FRONT- glFrontFace $ cff f- CullBack f -> do- glEnable gl_CULL_FACE- glCullFace gl_BACK- glFrontFace $ cff f- putStrLn_ "TriangleCtx 2" >> printGLStatus-- -- polygon mode- case pm of- PolygonPoint ps -> do- setPointSize ps- putStrLn_ "TriangleCtx 2 - 1" >> printGLStatus- glPolygonMode gl_FRONT_AND_BACK gl_POINT- putStrLn_ "TriangleCtx 2 - 2" >> printGLStatus- PolygonLine lw -> do- putStrLn_ ("TriangleCtx 2 - 3 : " ++ show lw) >> printGLStatus- glLineWidth (realToFrac lw)- putStrLn_ "TriangleCtx 2 - 4" >> printGLStatus- glPolygonMode gl_FRONT_AND_BACK gl_LINE- putStrLn_ "TriangleCtx 2 - 5" >> printGLStatus- PolygonFill -> glPolygonMode gl_FRONT_AND_BACK gl_FILL- putStrLn_ "TriangleCtx 3" >> printGLStatus-- -- polygon offset- {-- glDisable gl_POLYGON_OFFSET_POINT- glDisable gl_POLYGON_OFFSET_LINE- glDisable gl_POLYGON_OFFSET_FILL- -}- putStrLn_ "TriangleCtx 4" >> printGLStatus- case po of- NoOffset -> glDisable $ case pm of- PolygonPoint _ -> gl_POLYGON_OFFSET_POINT- PolygonLine _ -> gl_POLYGON_OFFSET_LINE- PolygonFill -> gl_POLYGON_OFFSET_FILL- Offset f u -> do- glPolygonOffset (realToFrac f) (realToFrac u)- glEnable $ case pm of- PolygonPoint _ -> gl_POLYGON_OFFSET_POINT- PolygonLine _ -> gl_POLYGON_OFFSET_LINE- PolygonFill -> gl_POLYGON_OFFSET_FILL- putStrLn_ "TriangleCtx 5" >> printGLStatus-- -- provoking vertex- setProvokingVertex pv- putStrLn_ "TriangleCtx 6" >> printGLStatus--setupAccumulationContext :: RenderState -> T.Trie InputGetter -> DAG -> ExpId -> IO ()-setupAccumulationContext rendState uniformGetterTrie dag aCtx = cvt ops- where- AccumulationContext vpSize ops = toExp dag aCtx- cvt :: [FragmentOperation] -> IO ()- cvt (StencilOp a b c : DepthOp f m : xs) = do- -- TODO- cvtC 0 xs- cvt (StencilOp a b c : xs) = do- -- TODO- cvtC 0 xs- cvt (DepthOp df dm : xs) = do- -- TODO- glDisable gl_STENCIL_TEST- case df == Always && dm == False of- True -> glDisable gl_DEPTH_TEST- False -> do- glEnable gl_DEPTH_TEST- glDepthFunc $! comparisonFunctionToGLType df- glDepthMask (cvtBool dm)- cvtC 0 xs- cvt xs = do- glDisable gl_DEPTH_TEST- glDisable gl_STENCIL_TEST- cvtC 0 xs-- cvtC :: Int -> [FragmentOperation] -> IO ()- cvtC i (ColorOp b m : xs) = do- -- TODO- case b of- NoBlending -> do- -- FIXME: requires GL 3.1- --glDisablei gl_BLEND $ fromIntegral gl_DRAW_BUFFER0 + fromIntegral i- glDisable gl_BLEND -- workaround- glDisable gl_COLOR_LOGIC_OP- BlendLogicOp op -> do- glDisable gl_BLEND- glEnable gl_COLOR_LOGIC_OP- glLogicOp $ logicOperationToGLType op- Blend (cEq,aEq) ((scF,dcF),(saF,daF)) (V4 r g b a) -> do- glDisable gl_COLOR_LOGIC_OP- -- FIXME: requires GL 3.1- --glEnablei gl_BLEND $ fromIntegral gl_DRAW_BUFFER0 + fromIntegral i- glEnable gl_BLEND -- workaround- glBlendEquationSeparate (blendEquationToGLType cEq) (blendEquationToGLType aEq)- glBlendFuncSeparate (blendingFactorToGLType scF) (blendingFactorToGLType dcF)- (blendingFactorToGLType saF) (blendingFactorToGLType daF)- glBlendColor (realToFrac r) (realToFrac g) (realToFrac b) (realToFrac a)- let cvt True = 1- cvt False = 0- (mr,mg,mb,ma) = case m of- VBool r -> (cvt r, 1, 1, 1)- VV2B (V2 r g) -> (cvt r, cvt g, 1, 1)- VV3B (V3 r g b) -> (cvt r, cvt g, cvt b, 1)- VV4B (V4 r g b a) -> (cvt r, cvt g, cvt b, cvt a)- _ -> (1,1,1,1)- glColorMask mr mg mb ma- cvtC (i + 1) xs- cvtC _ [] = case vpSize of- Nothing -> do- V2 w h <- readIORef $ renderTargetSize rendState- glViewport 0 0 (fromIntegral w) (fromIntegral h)- Just vpSizeExp -> do- V4 x y w h <- case toExp dag vpSizeExp of- Uni n -> case T.lookup n uniformGetterTrie of- Just (SV4U (Getter v)) -> v- _ -> error $ "interal error: viewport size type mismatch for Uni input " ++ show n- Const (VV4U c) -> return c- a -> error $ "interal error: viewport size type mismatch - " ++ show a- glViewport (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h)-- cvtBool :: Bool -> GLboolean- cvtBool True = 1- cvtBool False = 0--{-- compile steps:- - collect all render buffers and render textures and allocate the GL resources- - create setup actions all FBO-s (including clear targets action)- - compile Image setup function for each- - compile FragmentOperation function for each- - compile shader programs-- render stages:- - draw pass:- - bind FBO- - clear FBO targets- - bind program- - execute draw actions- - execute next draw pass- - blit ScreenOut to Back buffer if necessary-- hints:- - we will have one GLProgram and one FBO per Accumulate--}--- TODO:--- according context create FBO attachments--- we always use Textures (without mipmap, as a single image) as FBO attachments--- RenderBuffer can be use if it not fed to a sampler and it has olny one layer--- question:--- what is needed to create a Texture:--- size - will be stored in FrameBuffer :: GP (FrameBuffer sh t)--- internal format - for each component (float,int or word)-{-- glGenTextures(1, &color_tex);- glBindTexture(GL_TEXTURE_2D, color_tex);- glTexImage2D(GL_TEXTURE_2D, 0, GL_RGBA8, 256, 256, 0, GL_BGRA, GL_UNSIGNED_BYTE, NULL);-- void glFramebufferTexture(GLenum target, GLenum attachment, GLuint texture, GLint level);- void glDrawBuffers( GLsizei n, const GLenum *bufs );--}-{-- scissor:- enable/disable: SCISSOR_TEST- void Scissor( int left, int bottom, sizei width, sizei height );-- multisample:- enable/disable: SAMPLE_ALPHA_TO_COVERAGE, SAMPLE_ALPHA_TO_ONE, SAMPLE_COVERAGE, SAMPLE_MASK- void SampleCoverage( clampf value, boolean invert );- void SampleMaski( uint maskNumber, bitfield mask );-- stencil:- enable/disable: STENCIL_TEST- void StencilFunc( enum func, int ref, uint mask );- void StencilFuncSeparate( enum face, enum func, int ref, uint mask );- void StencilOp( enum sfail, enum dpfail, enum dppass );- void StencilOpSeparate( enum face, enum sfail, enum dpfail, enum dppass );-- depth:- enable/disable: DEPTH_TEST- void DepthFunc( enum func );-- blending:- enable/disable:- target: BLEND- index: DRAW_BUFFERi- void Enablei( enum target, uint index );- void Disablei( enum target, uint index );- FRAMEBUFFER_SRGB- Blend Equation:- void BlendEquation( enum mode );- void BlendEquationSeparate( enum modeRGB, enum modeAlpha );- void BlendFuncSeparate( enum srcRGB, enum dstRGB, enum srcAlpha, enum dstAlpha );- void BlendFunc( enum src, enum dst );- void BlendColor( clampf red, clampf green, clampf blue, clampf alpha );-- dither:- enable/disable: DITHER-- logic operation:- enable/disable: COLOR_LOGIC_OP- void LogicOp( enum op );-- Selecting a Buffer for Writing:- void DrawBuffer( enum buf );- void DrawBuffers( sizei n, const enum *bufs );-- Fine Control of Buffer Updates:- void ColorMask( boolean r, boolean g, boolean b, boolean a );- void ColorMaski( uint buf, boolean r, boolean g, boolean b, boolean a );- void DepthMask( boolean mask );- void StencilMask( uint mask );- void StencilMaskSeparate( enum face, uint mask );-- Clearing the Buffers:- void Clear( bitfield buf );- void ClearColor( clampf r, clampf g, clampf b, clampf a );- void ClearDepth( clampd d );- void ClearStencil( int s );- void ClearBuffer{if ui}v( enum buffer, int drawbuffer, const T*value);- void ClearBufferfi( enum buffer, int drawbuffer, float depth, int stencil );-- Reading and Copying Pixels:- void ReadPixels( int x, int y, sizei width, sizei height, enum format, enum type, void *data );- void ReadBuffer( enum src );- void ClampColor( enum target, enum clamp );- - void BlitFramebuffer( int srcX0, int srcY0, int srcX1, int srcY1, int dstX0, int dstY0, int dstX1, int dstY1, bitfield mask, enum filter );--}-{-- NOTE:- We have to validate context, because we can support only the same Blend and LogicOperation for all render targets,- however blending or LogicOp can be disabled separatly to each render target.--}--compileClearFrameBuffer :: Exp -> IO ()-compileClearFrameBuffer (FrameBuffer fb) = putStrLn_ ("CMD: clearFrameBuffer " ++ show fb) >> cvt fb- where- -- we have to handle depth and stencil specially, available configurations:- -- depth- -- stencil- -- depth-stencil- cvt :: [Image] -> IO ()- cvt (StencilImage sh1 s : DepthImage sh2 d : xs) = do- -- TODO- cvtC 0 xs- cvt (StencilImage sh s : xs) = do- -- TODO- cvtC 0 xs- cvt (DepthImage sh d : xs) = do- let --renderGL3 = with d $ \pd -> glClearBufferfv gl_DEPTH 0 $ castPtr pd- glDepthMask 1- glClearDepth $ realToFrac d- glClear $ fromIntegral gl_DEPTH_BUFFER_BIT- --print " * glClear gl_DEPTH_BUFFER_BIT"- cvtC 0 xs- cvt xs = cvtC 0 xs-- cvtC :: Int -> [Image] -> IO ()- cvtC i (ColorImage sh c : xs) = do- -- for GL3:- --with c' $ \pc -> glClearBufferfv gl_COLOR (fromIntegral $ gl_DRAW_BUFFER0 + fromIntegral i) $ castPtr pc- let (r,g,b,a) = case c of- VFloat r -> (realToFrac r, 0, 0, 1)- VV2F (V2 r g) -> (realToFrac r, realToFrac g, 0, 1)- VV3F (V3 r g b) -> (realToFrac r, realToFrac g, realToFrac b, 1)- VV4F (V4 r g b a) -> (realToFrac r, realToFrac g, realToFrac b, realToFrac a)- _ -> (0,0,0,1)- glClearColor r g b a- glClear $ fromIntegral gl_COLOR_BUFFER_BIT- cvtC i (UnclearedImage sh : xs) = return ()- cvtC i [] = return ()---- TODO-{-- hint:- sampler names are generated, only texture slots are named by user- one texture can be attached to more samplers- user feed textures not samplers to gfx network-- texturing support:- collect all sampler and texture definitions- create sampler <-> texture name map- sort previous passes- create sampler setup action- add texture slots to uniform input trie-- resources to create- samplers- sampler setup action- textures- hint: only if it is an output of a previous pass--}-{-- void GenSamplers( sizei count, uint *samplers );- void BindSampler( uint unit, uint sampler );- void DeleteSamplers( sizei count, const uint *samplers );- void SamplerParameter{if}v( uint sampler, enum pname, T param );- void SamplerParameterI{u ui}v( uint sampler, enum pname, T *params );- pname:- TEXTURE_WRAP_S- TEXTURE_WRAP_T- TEXTURE_WRAP_R- TEXTURE_MIN_FILTER- TEXTURE_MAG_FILTER- TEXTURE_BORDER_COLOR- TEXTURE_MIN_LOD- TEXTURE_MAX_LOD- TEXTURE_LOD_BIAS- TEXTURE_COMPARE_MODE- TEXTURE_COMPARE_FUNC- void DeleteSamplers( sizei count, const uint *samplers );-- void ActiveTexture( enum texture );- TEXTUREi = TEXTURE0 + i- void BindTexture( enum target, uint texture );- target:- TEXTURE_1D- TEXTURE_2D- TEXTURE_3D- TEXTURE_1D_ARRAY- TEXTURE_2D_ARRAY- TEXTURE_RECTANGLE- TEXTURE_BUFFER- TEXTURE_CUBE_MAP- TEXTURE_2D_MULTISAMPLE- TEXTURE_2D_MULTISAMPLE_ARRAY--}----- FIXME: simple solution, does not support sharing--- result: (RenderAction, DisposeAction, UniformLocation, StreamLocation)-compileRenderFrameBuffer :: RenderState -> Trie InputGetter -> DAG -> [(Exp,String)] -> [(Exp,String)] -> IORef ObjectSet -> Exp -> IO (IO (), IO (), Trie GLint, Trie GLuint, Int)-compileRenderFrameBuffer rendState uniformGetterTrie dag samplerNames slotSamplerNames objsIORef (Accumulate aCtx ffilter fsh rastExp fb) = do- --rndr <- compileFrameBuffer fb rndr'- po <- glCreateProgram- let Rasterize rCtx primsExp = toExp dag rastExp- (vsh,gsh,fetchExp) = case toExp dag primsExp of- Transform vsh fetchExp -> (vsh,Nothing,fetchExp)- Reassemble gsh transExp -> case toExp dag transExp of- Transform vsh fetchExp -> (vsh,Just gsh,fetchExp)- _ -> error "internal error: compileRenderFrameBuffer"- _ -> error "internal error: compileRenderFrameBuffer"- Fetch slotName slotPrim slotInput = toExp dag fetchExp- (shl,fragOuts,outColorCnt) = case gsh of- Nothing -> ([VertexShaderSrc srcV, FragmentShaderSrc srcF], (map fst outF), outColorCnt)- where- (srcF,outF,outColorCnt) = codeGenFragmentShader dag samplerNameMap outV (toExp dag ffilter) $ toExp dag fsh- Just gs -> ([VertexShaderSrc srcV, GeometryShaderSrc srcG, FragmentShaderSrc srcF], (map fst outF), outColorCnt)- where- (srcG,outG) = codeGenGeometryShader dag samplerNameMap slotPrim outV $ toExp dag gs- (srcF,outF,outColorCnt) = codeGenFragmentShader dag samplerNameMap outG (toExp dag ffilter) $ toExp dag fsh- (srcV,outV) = codeGenVertexShader dag samplerNameMap slotInput $ toExp dag vsh- allSamplerNames = samplerNames ++ slotSamplerNames - samplerNameMap = Map.fromList allSamplerNames- printGLStatus = checkGL >>= print_- createAndAttach [] _ = return $! Nothing- createAndAttach sl t = do- mapM_ SB.putStrLn sl- o <- glCreateShader t- compileShader o sl- glAttachShader po o- putStr " + compile shader source: " >> printGLStatus- return $! Just o- putStrLn $ "compileRenderFrameBuffer: compiling program for slot: " ++ show slotName- putStrLn " + compile vertex shader"- vsh <- createAndAttach [s | VertexShaderSrc s <- shl] gl_VERTEX_SHADER- putStrLn " + compile geometry shader"- gsh <- createAndAttach [s | GeometryShaderSrc s <- shl] gl_GEOMETRY_SHADER- putStrLn " + compile fragment shader"- fsh <- createAndAttach [s | FragmentShaderSrc s <- shl] gl_FRAGMENT_SHADER-- -- connect Fragment output to FBO- forM_ (zip fragOuts [0..]) $ \(n,i) -> SB.useAsCString n $ \pn -> do- putStrLn ("variable " ++ show n ++ " attached to color number #" ++ show i)- glBindFragDataLocation po i $ castPtr pn- putStr " + setup shader output mapping: " >> printGLStatus- glLinkProgram po- printProgramLog po-- -- check link status- status <- glGetProgramiv1 gl_LINK_STATUS po- when (status /= fromIntegral gl_TRUE) $ fail "link program failed!"-- -- query active uniforms, attributes and samplers- (uLoc,uType) <- queryUniforms po- (sLoc,sType) <- queryStreams po-- putStrLn $ "shader program stream input: " ++ show sLoc- putStrLn $ "shader program uniform input: " ++ show uLoc- putStrLn $ "expected sampler input: " ++ show allSamplerNames-- -- set sampler mapping- glUseProgram po- forM_ (zip [0..] (map (SB.pack . snd) allSamplerNames)) $ \(tuIdx,n) -> case T.lookup n uLoc of- Nothing -> putStrLn $ "WARNING - unxepected inactive sampler: " ++ show n- Just i -> (setSampler i tuIdx) >> putStr (" + setup texture unit mapping (smp " ++ show i ++ " <-> TexUnit " ++ show tuIdx ++": ") >> printGLStatus-- -- HINT: we get the uniform location now, so we have to provide this info to the renderer- let uLoc' = foldl' (\t (_,n) -> setSamplerLoc t (SB.pack n)) uLoc allSamplerNames- renderSmpNamesS = Set.fromList $ map (SB.pack . snd) samplerNames- renderSmpCount = Set.size renderSmpNamesS- slotSmpName = map (SB.pack . snd) slotSamplerNames-- setSamplerLoc :: Trie GLint -> ByteString -> Trie GLint- setSamplerLoc t n- | Set.member n renderSmpNamesS = T.delete n t- | otherwise = T.adjust (\_ -> fromIntegral $ renderSmpCount + idx) n t- where- Just idx = elemIndex n slotSmpName-- disposeFun = glDeleteProgram po >> mapM_ glDeleteShader (catMaybes [vsh,gsh,fsh])- renderFun = do- ObjectSet drawObjs objsMap <- readIORef objsIORef- --unless (False {-Map.null objsMap-}) $ do- unless (Map.null objsMap) $ do- --putStrLn $ "Slot: " ++ show slotName ++ " object count: " ++ show (Map.size objsMap)- putStrLn_ "pre draw" >> printGLStatus- putStrLn_ $ "CMD: setRasterContext " ++ show rCtx- setupRasterContext rCtx- putStrLn_ ("setupRasterContext " ++ show rCtx) >> printGLStatus- setupAccumulationContext rendState uniformGetterTrie dag aCtx- putStrLn_ "setupAccumulationContext" >> printGLStatus- putStrLn_ $ "CMD: setAccumulationContext " ++ show aCtx- putStrLn_ $ "CMD: glUseProgram " ++ show po- glUseProgram po- putStrLn_ "glUseProgram" >> printGLStatus- putStrLn_ $ "CMD: renderSlot " ++ show slotName- drawObjs- putStrLn_ "drawObjs" >> printGLStatus- print_ slotName- print_ uLoc'- return $! (renderFun, disposeFun, uLoc', sLoc, outColorCnt)--putStrLn_ :: String -> IO ()---putStrLn_ = putStrLn-putStrLn_ _ = return ()--print_ :: Show a => a -> IO ()-print_ _ = return ()
− src/lib/LambdaCube/GL/Data.hs
@@ -1,336 +0,0 @@-module LambdaCube.GL.Data where--import Control.Applicative-import Control.Monad-import Data.ByteString.Char8 (ByteString)-import Data.IORef-import Data.List as L-import Data.Maybe-import Data.Trie as T-import Foreign -import System.IO.Unsafe---import qualified Data.IntMap as IM-import qualified Data.Map as Map-import qualified Data.Set as Set-import qualified Data.Vector as V----import Control.DeepSeq--import Graphics.Rendering.OpenGL.Raw.Core32- ( GLuint- - -- FUNCTION APPLICATION related *- -- render call- , glDrawArrays- , glDrawElements- , gl_LINES- , gl_LINES_ADJACENCY- , gl_LINE_STRIP- , gl_LINE_STRIP_ADJACENCY- , gl_POINTS- , gl_TRIANGLES- , gl_TRIANGLES_ADJACENCY- , gl_TRIANGLE_FAN- , gl_TRIANGLE_STRIP- , gl_TRIANGLE_STRIP_ADJACENCY-- -- BUFFER related *- -- buffer data- , glBindBuffer- , glBindVertexArray- , glBufferData- , glBufferSubData- , glGenBuffers- , glGenVertexArrays- , gl_ARRAY_BUFFER- , gl_ELEMENT_ARRAY_BUFFER- , gl_STATIC_DRAW-- -- TEXTURE related *- -- texture data- , glBindTexture- , glGenTextures- , glGenerateMipmap- , glPixelStorei- , glTexImage2D- , glTexSubImage2D- , glTexParameteri- , gl_CLAMP_TO_EDGE- , gl_LINEAR- , gl_LINEAR_MIPMAP_LINEAR- , gl_REPEAT- , gl_RGB- , gl_RGBA- , gl_RGBA8- , gl_TEXTURE_2D- , gl_TEXTURE_BASE_LEVEL- , gl_TEXTURE_MAG_FILTER- , gl_TEXTURE_MAX_LEVEL- , gl_TEXTURE_MIN_FILTER- , gl_TEXTURE_WRAP_S- , gl_TEXTURE_WRAP_T- , gl_UNPACK_ALIGNMENT- , gl_UNSIGNED_BYTE- )--import Data.Word-import Data.Bitmap.Pure--import LambdaCube.GL.Type-import LambdaCube.GL.Util-import LambdaCube.Core.Type-import LambdaCube.Core.DeBruijn---- Buffer-compileBuffer :: [Array] -> IO Buffer-compileBuffer arrs = do- let calcDesc (offset,setters,descs) (Array arrType cnt setter) =- let size = cnt * sizeOfArrayType arrType- in (size + offset, (offset,size,setter):setters, ArrayDesc arrType cnt offset size:descs)- (bufSize,arrSetters,arrDescs) = foldl' calcDesc (0,[],[]) arrs- bo <- alloca $! \pbo -> glGenBuffers 1 pbo >> peek pbo- glBindBuffer gl_ARRAY_BUFFER bo- glBufferData gl_ARRAY_BUFFER (fromIntegral bufSize) nullPtr gl_STATIC_DRAW- forM_ arrSetters $! \(offset,size,setter) -> setter $! glBufferSubData gl_ARRAY_BUFFER (fromIntegral offset) (fromIntegral size)- glBindBuffer gl_ARRAY_BUFFER 0- return $! Buffer (V.fromList $! reverse arrDescs) bo--updateBuffer :: Buffer -> [(Int,Array)] -> IO ()-updateBuffer (Buffer arrDescs bo) arrs = do- glBindBuffer gl_ARRAY_BUFFER bo- forM arrs $ \(i,Array arrType cnt setter) -> do- let ArrayDesc ty len offset size = arrDescs V.! i- when (ty == arrType && cnt == len) $- setter $! glBufferSubData gl_ARRAY_BUFFER (fromIntegral offset) (fromIntegral size)- glBindBuffer gl_ARRAY_BUFFER 0--bufferSize :: Buffer -> Int-bufferSize = V.length . bufArrays--arraySize :: Buffer -> Int -> Int-arraySize buf arrIdx = arrLength $! bufArrays buf V.! arrIdx--arrayType :: Buffer -> Int -> ArrayType-arrayType buf arrIdx = arrType $! bufArrays buf V.! arrIdx---- question: should we render the full stream?--- answer: YES--- Object-nullObject :: Object-nullObject = unsafePerformIO $ Object "" T.empty 0 <$> newIORef False--addObject :: Renderer -> ByteString -> Primitive -> Maybe (IndexStream Buffer) -> Trie (Stream Buffer) -> [ByteString] -> IO Object-addObject renderer slotName prim objIndices objAttributes objUniforms =- if (not $ T.member slotName $! slotUniform renderer) then do- putStrLn $ "WARNING: unknown slot name: " ++ show slotName- return nullObject- else do- -- validate- let Just (slotType,sType) = T.lookup slotName $ slotStream renderer- objSType = fmap streamToInputType objAttributes- primType = case prim of- TriangleStrip -> Triangles- TriangleList -> Triangles- TriangleFan -> Triangles- LineStrip -> Lines- LineList -> Lines- PointList -> Points- TriangleStripAdjacency -> TrianglesAdjacency- TriangleListAdjacency -> TrianglesAdjacency- LineStripAdjacency -> LinesAdjacency- LineListAdjacency -> LinesAdjacency- primGL = case prim of- TriangleStrip -> gl_TRIANGLE_STRIP- TriangleList -> gl_TRIANGLES- TriangleFan -> gl_TRIANGLE_FAN- LineStrip -> gl_LINE_STRIP- LineList -> gl_LINES- PointList -> gl_POINTS- TriangleStripAdjacency -> gl_TRIANGLE_STRIP_ADJACENCY- TriangleListAdjacency -> gl_TRIANGLES_ADJACENCY- LineStripAdjacency -> gl_LINE_STRIP_ADJACENCY- LineListAdjacency -> gl_LINES_ADJACENCY- streamCounts = [c | Stream _ _ _ _ c <- T.elems objAttributes]- count = head $ streamCounts ++ error "streamCounts"-- when (slotType /= primType) $ fail $ "addObject: primitive type mismatch: " ++ show (slotType,primType)- when (objSType /= sType) $ fail $ unlines- [ "addObject: attribute mismatch"- , "expected:"- , " " ++ show sType- , "actual:"- , " " ++ show objSType- ]- when (L.null streamCounts) $ fail "addObject: missing stream attribute, a least one stream attribute is required!"- when (L.or [c /= count | c <- streamCounts]) $ fail "addObject: streams should have the same length!"-- -- validate index type if presented and create draw action- (iSetup,draw) <- case objIndices of- Nothing -> return (putStrLn_ ("OBJ: glBindBuffer gl_ELEMENT_ARRAY_BUFFER 0") >> glBindBuffer gl_ELEMENT_ARRAY_BUFFER 0, - putStrLn_ ("OBJ: glDrawArrays " ++ show prim ++ " 0 " ++ show count) >> glDrawArrays primGL 0 (fromIntegral count))- Just (IndexStream (Buffer arrs bo) arrIdx start idxCount) -> do- -- setup index buffer- let ArrayDesc arrType arrLen arrOffs arrSize = arrs V.! arrIdx- glType = arrayTypeToGLType arrType- ptr = intPtrToPtr $! fromIntegral (arrOffs + start * sizeOfArrayType arrType)- -- validate index type- when (notElem arrType [ArrWord8, ArrWord16, ArrWord32]) $ fail "addObject: index type should be unsigned integer type"- return (putStrLn_ ("OBJ: glBindBuffer gl_ELEMENT_ARRAY_BUFFER " ++ show bo) >> glBindBuffer gl_ELEMENT_ARRAY_BUFFER bo,- putStrLn_ ("OBJ: glDrawElements " ++ show prim ++ " " ++ show idxCount ++ " " ++ show arrType ++ " " ++ show ptr) >> glDrawElements primGL (fromIntegral idxCount) glType ptr)-- -- implementation- let renderDescriptorMap = renderDescriptor renderer- uniformType = T.fromList $ concat [T.toList t | (_,t) <- T.toList $ slotUniform renderer]- mkUSetup = mkUniformSetup renderer- globalUNames = Set.toList $! (Set.fromList $! T.keys uniformType) Set.\\ (Set.fromList objUniforms)- rendState = renderState renderer- - stateIORef <- newIORef True- (mkObjUSetup,objUSetters,_) <- unzip3 <$> (sequence [mkUniformSetter rendState t | n <- objUniforms, t <- maybeToList $ T.lookup n uniformType])- let objUSetterTrie = T.fromList $! zip objUniforms objUSetters- - mkDrawAction :: Exp -> IO (GLuint,IO ())- mkDrawAction gp = do- let Just rd = Map.lookup gp renderDescriptorMap- sLocs = streamLocation rd- uLocs = uniformLocation rd- -- stream setup action- sSetup = sequence_ [ mkSSetter t loc s - | (n,s) <- T.toList objAttributes- , t <- maybeToList $ T.lookup n sType- , loc <- maybeToList $ T.lookup n sLocs- ]- -- global uniform setup- {-- globalUSetup = sequence_ [ mkUS loc - | n <- globalUNames- , let Just mkUS = T.lookup n mkUSetup- , loc <- maybeToList $ T.lookup n uLocs- ]- -}- globalUSetup = V.sequence_ $ V.fromList- [ mkUS loc- | n <- globalUNames- , let Just mkUS = T.lookup n mkUSetup- , loc <- maybeToList $ T.lookup n uLocs- ]- -- object uniform setup- objUSetup = sequence_ [ mkOUS loc- | (n,mkOUS) <- zip objUniforms mkObjUSetup- , loc <- maybeToList $ T.lookup n uLocs- ]- --print sLocs- -- create Vertex Array Object- vao <- alloca $! \pvao -> glGenVertexArrays 1 pvao >> peek pvao- glBindVertexArray vao- sSetup -- setup vertex attributes- iSetup -- setup index buffer- let renderFun = readIORef stateIORef >>= \enabled -> when enabled $ do- --print "draw object"- --putStrLn $ " setup global uniforms: " ++ show [n | n <- globalUNames, T.member n uLocs]- globalUSetup -- setup uniforms- putStrLn_ $ "OBJ: globalUSetup"- --putStrLn_ $ " setup object uniforms: " ++ show [n | n <- objUniforms, T.member n uLocs]- objUSetup- putStrLn_ $ "OBJ: objUSetup"- putStrLn_ $ "OBJ: glBindVertexArray " ++ show vao- glBindVertexArray vao -- setup stream input (aka object attributes)- draw -- execute draw function- return (vao,renderFun)-- Just (SlotDescriptor gps objSetRef) = T.lookup slotName (slotDescriptor renderer)- gpList = Set.toList gps- {-- - create the object draw action for every Accumulate node- - update ObjectSet's draw action lists- -}- --print sType- (vaoList,drawList) <- unzip <$> mapM mkDrawAction gpList- objID <- readIORef (objectIDSeed renderer)- modifyIORef (objectIDSeed renderer) (+1)- let obj = Object- { objectSlotName = slotName- , objectUniformSetter = objUSetterTrie- , objectID = objID- , objectEnabledIORef = stateIORef- }-- -- add object to slot's object set- modifyIORef objSetRef $ \s -> Set.insert obj s-- -- add draw object action to list- forM_ (zip gpList drawList) $ \(gp,draw) -> do- --print ("add", vaoList)- let Just rd = Map.lookup gp renderDescriptorMap- modifyIORef (drawObjectsIORef rd) $ \(ObjectSet _ drawMap) ->- let drawMap' = Map.insert obj draw drawMap- in ObjectSet (sequence_ $ Map.elems drawMap') drawMap'-- return obj--removeObject :: Renderer -> Object -> IO ()-removeObject rend obj = do- let Just (SlotDescriptor gps objSetRef) = T.lookup (objectSlotName obj) (slotDescriptor rend)- renderDescriptorMap = renderDescriptor rend-- -- remove object from slot's object set- modifyIORef objSetRef $ \s -> Set.delete obj s-- -- remove draw object action from list- forM_ (Set.toList gps) $ \gp -> do- let Just rd = Map.lookup gp renderDescriptorMap- modifyIORef (drawObjectsIORef rd) $ \(ObjectSet _ drawMap) ->- let drawMap' = Map.delete obj drawMap- in ObjectSet (sequence_ $ Map.elems drawMap') drawMap'--enableObject :: Object -> Bool -> IO ()-enableObject obj b = writeIORef (objectEnabledIORef obj) b---- Texture---- FIXME: Temporary implemenation-compileTexture2DRGBAF :: Bool -> Bool -> Bitmap Word8 -> IO TextureData-compileTexture2DRGBAF isMip isClamped bitmap = do- glPixelStorei gl_UNPACK_ALIGNMENT 1- to <- alloca $! \pto -> glGenTextures 1 pto >> peek pto- glBindTexture gl_TEXTURE_2D to- let (width,height) = bitmapSize bitmap- wrapMode = case isClamped of- True -> gl_CLAMP_TO_EDGE- False -> gl_REPEAT- (minFilter,maxLevel) = case isMip of- False -> (gl_LINEAR,0)- True -> (gl_LINEAR_MIPMAP_LINEAR, floor $ log (fromIntegral $ max width height) / log 2)- glTexParameteri gl_TEXTURE_2D gl_TEXTURE_WRAP_S $ fromIntegral wrapMode- glTexParameteri gl_TEXTURE_2D gl_TEXTURE_WRAP_T $ fromIntegral wrapMode- glTexParameteri gl_TEXTURE_2D gl_TEXTURE_MIN_FILTER $ fromIntegral minFilter- glTexParameteri gl_TEXTURE_2D gl_TEXTURE_MAG_FILTER $ fromIntegral gl_LINEAR- glTexParameteri gl_TEXTURE_2D gl_TEXTURE_BASE_LEVEL 0- glTexParameteri gl_TEXTURE_2D gl_TEXTURE_MAX_LEVEL $ fromIntegral maxLevel- withBitmap bitmap $ \(w,h) nchn 0 ptr -> do- let internalFormat = fromIntegral gl_RGBA8- dataFormat = fromIntegral $ case nchn of- 3 -> gl_RGB- 4 -> gl_RGBA- _ -> error "unsupported texture format!"- glTexImage2D gl_TEXTURE_2D 0 internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat gl_UNSIGNED_BYTE $ castPtr ptr- when isMip $ glGenerateMipmap gl_TEXTURE_2D- return $ TextureData to--updateTexture2DRGBAF :: TextureData -> Bool -> Bitmap Word8 -> IO ()-updateTexture2DRGBAF tx isMip bitmap = do- glPixelStorei gl_UNPACK_ALIGNMENT 1- let to = textureObject tx- glBindTexture gl_TEXTURE_2D to- withBitmap bitmap $ \(w,h) nchn 0 ptr -> do- let internalFormat = fromIntegral gl_RGBA8- dataFormat = fromIntegral $ case nchn of- 3 -> gl_RGB- 4 -> gl_RGBA- _ -> error "unsupported texture format!"- glTexSubImage2D gl_TEXTURE_2D 0 0 0 (fromIntegral w) (fromIntegral h) dataFormat gl_UNSIGNED_BYTE $ castPtr ptr- when isMip $ glGenerateMipmap gl_TEXTURE_2D--putStrLn_ :: String -> IO ()---putStrLn_ = putStrLn-putStrLn_ _ = return ()
− src/lib/LambdaCube/GL/GLSLCodeGen.hs
@@ -1,867 +0,0 @@-module LambdaCube.GL.GLSLCodeGen (- codeGenVertexShader,- codeGenGeometryShader,- codeGenFragmentShader,- codeGenType-) where--import Debug.Trace--import Control.Applicative hiding (Const)-import Control.Exception-import Control.Monad.State-import Data.ByteString.Char8 (ByteString,pack,unpack)-import Data.Int-import Data.IntMap (IntMap)-import Data.Map (Map)-import Data.Maybe-import Data.Set (Set)-import Data.Word-import Text.PrettyPrint.HughesPJClass-import qualified Data.ByteString.Char8 as SB-import qualified Data.IntMap as IntMap-import qualified Data.Map as Map-import qualified Data.Set as Set-import qualified Data.Vector as V--import LambdaCube.Core.Type hiding (And,Or,Equal)-import LambdaCube.Core.PrimFun-import LambdaCube.Core.DeBruijn hiding (ExpC(..))-import LambdaCube.Core.Traversals--import Language.GLSL.Syntax hiding (Const,InterpolationQualifier(..),TypeSpecifierNonArray(..))-import Language.GLSL.Syntax (TypeSpecifierNonArray)-import qualified Language.GLSL.Syntax as GLSL-import Language.GLSL.Pretty--codeGenPrim :: PrimFun -> [InputType] -> [InputType] -> [Expr] -> [Expr]---- Vec/Mat (de)construction-codeGenPrim PrimTupToV2 ty argTy [a,b]- | all (==Bool) argTy = [functionCall "bvec2" [a,b]]- | all (==Float) argTy = [functionCall "vec2" [a,b]]- | all (==Int) argTy = [functionCall "ivec2" [a,b]]- | all (==Word) argTy = [functionCall "uvec2" [a,b]]- | all (==V2F) argTy = [functionCall "mat2" [a,b]]- | all (==V3F) argTy = [functionCall "mat3x2" [a,b]]- | all (==V4F) argTy = [functionCall "mat4x2" [a,b]]-codeGenPrim PrimTupToV3 ty argTy [a,b,c]- | all (==Bool) argTy = [functionCall "bvec3" [a,b,c]]- | all (==Float) argTy = [functionCall "vec3" [a,b,c]]- | all (==Int) argTy = [functionCall "ivec3" [a,b,c]]- | all (==Word) argTy = [functionCall "uvec3" [a,b,c]]- | all (==V2F) argTy = [functionCall "mat2x3" [a,b,c]]- | all (==V3F) argTy = [functionCall "mat3" [a,b,c]]- | all (==V4F) argTy = [functionCall "mat4x3" [a,b,c]]-codeGenPrim PrimTupToV4 ty argTy [a,b,c,d]- | all (==Bool) argTy = [functionCall "bvec4" [a,b,c,d]]- | all (==Float) argTy = [functionCall "vec4" [a,b,c,d]]- | all (==Int) argTy = [functionCall "ivec4" [a,b,c,d]]- | all (==Word) argTy = [functionCall "uvec4" [a,b,c,d]]- | all (==V2F) argTy = [functionCall "mat2x4" [a,b,c,d]]- | all (==V3F) argTy = [functionCall "mat3x4" [a,b,c,d]]- | all (==V4F) argTy = [functionCall "mat4" [a,b,c,d]]--codeGenPrim PrimV2ToTup ty argTy [a]- | all isMatrix argTy = [ Bracket a (IntConstant Decimal 0)- , Bracket a (IntConstant Decimal 1)- ]- | otherwise = [ FieldSelection a "x"- , FieldSelection a "y"- ]-codeGenPrim PrimV3ToTup ty argTy [a]- | all isMatrix argTy = [ Bracket a (IntConstant Decimal 0)- , Bracket a (IntConstant Decimal 1)- , Bracket a (IntConstant Decimal 2)- ]- | otherwise = [ FieldSelection a "x"- , FieldSelection a "y"- , FieldSelection a "z"- ]-codeGenPrim PrimV4ToTup ty argTy [a]- | all isMatrix argTy = [ Bracket a (IntConstant Decimal 0)- , Bracket a (IntConstant Decimal 1)- , Bracket a (IntConstant Decimal 2)- , Bracket a (IntConstant Decimal 3)- ]- | otherwise = [ FieldSelection a "x"- , FieldSelection a "y"- , FieldSelection a "z"- , FieldSelection a "w"- ]---- Arithmetic Functions--- OK-codeGenPrim PrimAdd ty argTy [a,b] = [Add a b]-codeGenPrim PrimAddS ty argTy [a,b] = [Add a b]-codeGenPrim PrimSub ty argTy [a,b] = [Sub a b]-codeGenPrim PrimSubS ty argTy [a,b] = [Sub a b]-codeGenPrim PrimMul ty argTy [a,b]- | all isMatrix argTy = [functionCall "matrixCompMult" [a,b]]- | otherwise = [Mul a b]-codeGenPrim PrimMulS ty argTy [a,b] = [Mul a b]-codeGenPrim PrimDiv ty argTy [a,b] = [Div a b]-codeGenPrim PrimDivS ty argTy [a,b] = [Div a b]-codeGenPrim PrimNeg ty argTy [a] = [UnaryNegate a]-codeGenPrim PrimMod ty argTy [a,b]- | all isIntegral argTy = [Mod a b]- | otherwise = [functionCall "mod" [a,b]]-codeGenPrim PrimModS ty argTy [a,b]- | all isIntegral argTy = [Mod a b]- | otherwise = [functionCall "mod" [a,b]]---- Bit-wise Functions--- OK-codeGenPrim PrimBAnd ty argTy [a,b] = [BitAnd a b]-codeGenPrim PrimBAndS ty argTy [a,b] = [BitAnd a b]-codeGenPrim PrimBOr ty argTy [a,b] = [BitOr a b]-codeGenPrim PrimBOrS ty argTy [a,b] = [BitOr a b]-codeGenPrim PrimBXor ty argTy [a,b] = [BitXor a b]-codeGenPrim PrimBXorS ty argTy [a,b] = [BitXor a b]-codeGenPrim PrimBNot ty argTy [a] = [UnaryOneComplement a]-codeGenPrim PrimBShiftL ty argTy [a,b] = [LeftShift a b]-codeGenPrim PrimBShiftLS ty argTy [a,b] = [LeftShift a b]-codeGenPrim PrimBShiftR ty argTy [a,b] = [RightShift a b]-codeGenPrim PrimBShiftRS ty argTy [a,b] = [RightShift a b]---- Logic Functions--- OK-codeGenPrim PrimAnd ty argTy [a,b] = [And a b]-codeGenPrim PrimOr ty argTy [a,b] = [Or a b]-codeGenPrim PrimXor ty argTy [a,b] = error "codeGenPrim PrimXor is not implemented yet!" -- TODO: implement in GLSLSyntax-codeGenPrim PrimNot ty argTy [a]- | all isScalar argTy = [UnaryNot a]- | otherwise = [functionCall "not" [a]]-codeGenPrim PrimAny ty argTy [a] = [functionCall "any" [a]]-codeGenPrim PrimAll ty argTy [a] = [functionCall "all" [a]]---- Angle and Trigonometry Functions--- OK-codeGenPrim PrimACos ty argTy [a] = [functionCall "acos" [a]]-codeGenPrim PrimACosH ty argTy [a] = [functionCall "acosh" [a]]-codeGenPrim PrimASin ty argTy [a] = [functionCall "asin" [a]]-codeGenPrim PrimASinH ty argTy [a] = [functionCall "asinh" [a]]-codeGenPrim PrimATan ty argTy [a] = [functionCall "atan" [a]]-codeGenPrim PrimATan2 ty argTy [a,b] = [functionCall "atan" [a,b]]-codeGenPrim PrimATanH ty argTy [a] = [functionCall "atanh" [a]]-codeGenPrim PrimCos ty argTy [a] = [functionCall "cos" [a]]-codeGenPrim PrimCosH ty argTy [a] = [functionCall "cosh" [a]]-codeGenPrim PrimDegrees ty argTy [a] = [functionCall "degrees" [a]]-codeGenPrim PrimRadians ty argTy [a] = [functionCall "radians" [a]]-codeGenPrim PrimSin ty argTy [a] = [functionCall "sin" [a]]-codeGenPrim PrimSinH ty argTy [a] = [functionCall "sinh" [a]]-codeGenPrim PrimTan ty argTy [a] = [functionCall "tan" [a]]-codeGenPrim PrimTanH ty argTy [a] = [functionCall "tanh" [a]]---- Exponential Functions--- OK-codeGenPrim PrimPow ty argTy [a,b] = [functionCall "pow" [a,b]]-codeGenPrim PrimExp ty argTy [a] = [functionCall "exp" [a]]-codeGenPrim PrimLog ty argTy [a] = [functionCall "log" [a]]-codeGenPrim PrimExp2 ty argTy [a] = [functionCall "exp2" [a]]-codeGenPrim PrimLog2 ty argTy [a] = [functionCall "log2" [a]]-codeGenPrim PrimSqrt ty argTy [a] = [functionCall "sqrt" [a]]-codeGenPrim PrimInvSqrt ty argTy [a] = [functionCall "inversesqrt" [a]]---- Common Functions--- OK-codeGenPrim PrimIsNan ty argTy [a] = [functionCall "isnan" [a]]-codeGenPrim PrimIsInf ty argTy [a] = [functionCall "isinf" [a]]-codeGenPrim PrimAbs ty argTy [a] = [functionCall "abs" [a]]-codeGenPrim PrimSign ty argTy [a] = [functionCall "sign" [a]]-codeGenPrim PrimFloor ty argTy [a] = [functionCall "floor" [a]]-codeGenPrim PrimTrunc ty argTy [a] = [functionCall "trunc" [a]]-codeGenPrim PrimRound ty argTy [a] = [functionCall "round" [a]]-codeGenPrim PrimRoundEven ty argTy [a] = [functionCall "roundEven" [a]]-codeGenPrim PrimCeil ty argTy [a] = [functionCall "ceil" [a]]-codeGenPrim PrimFract ty argTy [a] = [functionCall "fract" [a]]-codeGenPrim PrimModF ty argTy [a] = error "codeGenPrim PrimModF is not implemented yet!" -- TODO-codeGenPrim PrimMin ty argTy [a,b] = [functionCall "min" [a,b]]-codeGenPrim PrimMinS ty argTy [a,b] = [functionCall "min" [a,b]]-codeGenPrim PrimMax ty argTy [a,b] = [functionCall "max" [a,b]]-codeGenPrim PrimMaxS ty argTy [a,b] = [functionCall "max" [a,b]]-codeGenPrim PrimClamp ty argTy [a,b,c] = [functionCall "clamp" [a,b,c]]-codeGenPrim PrimClampS ty argTy [a,b,c] = [functionCall "clamp" [a,b,c]]-codeGenPrim PrimMix ty argTy [a,b,c] = [functionCall "mix" [a,b,c]]-codeGenPrim PrimMixS ty argTy [a,b,c] = [functionCall "mix" [a,b,c]]-codeGenPrim PrimMixB ty argTy [a,b,c] = [functionCall "mix" [a,b,c]]-codeGenPrim PrimStep ty argTy [a,b] = [functionCall "step" [a,b]]-codeGenPrim PrimStepS ty argTy [a,b] = [functionCall "step" [a,b]]-codeGenPrim PrimSmoothStep ty argTy [a,b,c] = [functionCall "smoothstep" [a,b,c]]-codeGenPrim PrimSmoothStepS ty argTy [a,b,c] = [functionCall "smoothstep" [a,b,c]]---- Integer/Float Conversion Functions--- OK-codeGenPrim PrimFloatBitsToInt ty argTy [a] = [functionCall "floatBitsToInt" [a]]-codeGenPrim PrimFloatBitsToUInt ty argTy [a] = [functionCall "floatBitsToUint" [a]]-codeGenPrim PrimIntBitsToFloat ty argTy [a] = [functionCall "intBitsToFloat" [a]]-codeGenPrim PrimUIntBitsToFloat ty argTy [a] = [functionCall "uintBitsToFloat" [a]]---- Geometric Functions--- OK-codeGenPrim PrimLength ty argTy [a] = [functionCall "length" [a]]-codeGenPrim PrimDistance ty argTy [a,b] = [functionCall "distance" [a,b]]-codeGenPrim PrimDot ty argTy [a,b] = [functionCall "dot" [a,b]]-codeGenPrim PrimCross ty argTy [a,b] = [functionCall "cross" [a,b]]-codeGenPrim PrimNormalize ty argTy [a] = [functionCall "normalize" [a]]-codeGenPrim PrimFaceForward ty argTy [a,b,c] = [functionCall "faceforward" [a,b,c]]-codeGenPrim PrimReflect ty argTy [a,b] = [functionCall "reflect" [a,b]]-codeGenPrim PrimRefract ty argTy [a,b,c] = [functionCall "refract" [a,b,c]]---- Matrix Functions--- OK-codeGenPrim PrimTranspose ty argTy [a] = [functionCall "transpose" [a]]-codeGenPrim PrimDeterminant ty argTy [a] = [functionCall "determinant" [a]]-codeGenPrim PrimInverse ty argTy [a] = [functionCall "inverse" [a]]-codeGenPrim PrimOuterProduct ty argTy [a,b] = [functionCall "outerProduct" [a,b]]-codeGenPrim PrimMulMatVec ty argTy [a,b] = [Mul a b]-codeGenPrim PrimMulVecMat ty argTy [a,b] = [Mul a b]-codeGenPrim PrimMulMatMat ty argTy [a,b] = [Mul a b]---- Vector and Scalar Relational Functions--- OK-codeGenPrim PrimLessThan ty argTy [a,b]- | all isScalarNum argTy = [Lt a b]- | otherwise = [functionCall "lessThan" [a,b]]-codeGenPrim PrimLessThanEqual ty argTy [a,b]- | all isScalarNum argTy = [Lte a b]- | otherwise = [functionCall "lessThanEqual" [a,b]]-codeGenPrim PrimGreaterThan ty argTy [a,b]- | all isScalarNum argTy = [Gt a b]- | otherwise = [functionCall "greaterThan" [a,b]]-codeGenPrim PrimGreaterThanEqual ty argTy [a,b]- | all isScalarNum argTy = [Gte a b]- | otherwise = [functionCall "greaterThanEqual" [a,b]]-codeGenPrim PrimEqualV ty argTy [a,b]- | all isScalar argTy = [Equ a b]- | otherwise = [functionCall "equal" [a,b]]-codeGenPrim PrimEqual ty argTy [a,b] = [Equ a b]-codeGenPrim PrimNotEqualV ty argTy [a,b]- | all isScalar argTy = [Neq a b]- | otherwise = [functionCall "notEqual" [a,b]]-codeGenPrim PrimNotEqual ty argTy [a,b] = [Neq a b]---- Fragment Processing Functions--- OK-codeGenPrim PrimDFdx ty argTy [a] = [functionCall "dFdx" [a]]-codeGenPrim PrimDFdy ty argTy [a] = [functionCall "dFdy" [a]]-codeGenPrim PrimFWidth ty argTy [a] = [functionCall "fwidth" [a]]---- Noise Functions--- OK-codeGenPrim PrimNoise1 ty argTy [a] = [functionCall "noise1" [a]]-codeGenPrim PrimNoise2 ty argTy [a] = [functionCall "noise2" [a]]-codeGenPrim PrimNoise3 ty argTy [a] = [functionCall "noise3" [a]]-codeGenPrim PrimNoise4 ty argTy [a] = [functionCall "noise4" [a]]---- Texture Lookup Functions-codeGenPrim PrimTextureSize ty argTy [a] = [functionCall "textureSize" [a]]-codeGenPrim PrimTextureSize ty argTy [a,b] = [functionCall "textureSize" [a,b]]-codeGenPrim PrimTexture ty argTy [a,b] = [swizzleV4 ty $ functionCall "texture" [a,b]]-codeGenPrim PrimTexture ty argTy [a,b,c] = [swizzleV4 ty $ functionCall "texture" [a,b,c]]-codeGenPrim PrimTextureProj ty argTy [a,b] = [swizzleV4 ty $ functionCall "textureProj" [a,b]]-codeGenPrim PrimTextureProj ty argTy [a,b,c] = [swizzleV4 ty $ functionCall "textureProj" [a,b,c]]-codeGenPrim PrimTextureLod ty argTy [a,b,c] = [swizzleV4 ty $ functionCall "textureLod" [a,b,c]]-codeGenPrim PrimTextureOffset ty argTy [a,b,c] = [swizzleV4 ty $ functionCall "textureOffset" [a,b,c]]-codeGenPrim PrimTextureOffset ty argTy [a,b,c,d] = [swizzleV4 ty $ functionCall "textureOffset" [a,b,c,d]]-codeGenPrim PrimTexelFetch ty argTy [a,b] = [swizzleV4 ty $ functionCall "texelFetch" [a,b]]-codeGenPrim PrimTexelFetch ty argTy [a,b,c] = [swizzleV4 ty $ functionCall "texelFetch" [a,b,c]]-codeGenPrim PrimTexelFetchOffset ty argTy [a,b,c] = [swizzleV4 ty $ functionCall "texelFetchOffset" [a,b,c]]-codeGenPrim PrimTexelFetchOffset ty argTy [a,b,c,d] = [swizzleV4 ty $ functionCall "texelFetchOffset" [a,b,c,d]]-codeGenPrim PrimTextureProjOffset ty argTy [a,b,c] = [swizzleV4 ty $ functionCall "textureProjOffset" [a,b,c]]-codeGenPrim PrimTextureProjOffset ty argTy [a,b,c,d] = [swizzleV4 ty $ functionCall "textureProjOffset" [a,b,c,d]]-codeGenPrim PrimTextureLodOffset ty argTy [a,b,c,d] = [swizzleV4 ty $ functionCall "textureLodOffset" [a,b,c,d]]-codeGenPrim PrimTextureProjLod ty argTy [a,b,c] = [swizzleV4 ty $ functionCall "textureProjLod" [a,b,c]]-codeGenPrim PrimTextureProjLodOffset ty argTy [a,b,c,d] = [swizzleV4 ty $ functionCall "textureProjLodOffset" [a,b,c,d]]-codeGenPrim PrimTextureGrad ty argTy [a,b,c,d] = [swizzleV4 ty $ functionCall "textureGrad" [a,b,c,d]]-codeGenPrim PrimTextureGradOffset ty argTy [a,b,c,d,e] = [swizzleV4 ty $ functionCall "textureGradOffset" [a,b,c,d,e]]-codeGenPrim PrimTextureProjGrad ty argTy [a,b,c,d] = [swizzleV4 ty $ functionCall "textureProjGrad" [a,b,c,d]]-codeGenPrim PrimTextureProjGradOffset ty argTy [a,b,c,d,e] = [swizzleV4 ty $ functionCall "textureProjGradOffset" [a,b,c,d,e]]---- unmatched primitive function-codeGenPrim prim ty argTy params = throw $ userError $ unlines $- [ "codeGenPrim failed: "- , " name: " ++ show prim- , " parameter types: " ++ show ty- , " parameter values: " ++ show params- ]--swizzleV4 :: [InputType] -> Expr -> Expr-swizzleV4 [ty] a- | elem ty [V4F, V4I, V4U] = a- | elem ty [V3F, V3I, V3U] = FieldSelection a "rgb"- | elem ty [V2F, V2I, V2U] = FieldSelection a "rg"- | elem ty [Float, Int, Word] = FieldSelection a "r"- | otherwise = error $ "swizzleV4 - illegal type: " ++ show ty---- glsl ast utility-functionCall :: String -> [Expr] -> Expr-functionCall name params = FunctionCall (FuncId name) (Params params)--isMatrix :: InputType -> Bool-isMatrix ty = elem ty $- [ M22F, M23F, M24F- , M32F, M33F, M34F- , M42F, M43F, M44F- ]--isIntegral :: InputType -> Bool-isIntegral ty = elem ty $- [ Word, V2U, V3U, V4U- , Int, V2I, V3I, V4I- ]--isScalarNum :: InputType -> Bool-isScalarNum ty = elem ty [Int, Word, Float]--isScalar :: InputType -> Bool-isScalar ty = elem ty [Bool, Int, Word, Float]--wordC :: Word32 -> Expr-wordC v = IntConstant Decimal (fromIntegral v)--intC :: Int32 -> Expr-intC v = IntConstant Decimal (fromIntegral v)--boolC :: Bool -> Expr-boolC v = BoolConstant v--floatC :: Float -> Expr-floatC v = FloatConstant v--v2C :: String -> (a -> Expr) -> V2 a -> Expr-v2C name f (V2 x y) = functionCall name [f x, f y]--v3C :: String -> (a -> Expr) -> V3 a -> Expr-v3C name f (V3 x y z) = functionCall name [f x, f y, f z]--v4C :: String -> (a -> Expr) -> V4 a -> Expr-v4C name f (V4 x y z w) = functionCall name [f x, f y, f z, f w]--matX2C :: String -> (v Float -> Expr) -> V2 (v Float) -> Expr-matX2C name f (V2 x y) = functionCall name [f x, f y]--matX3C :: String -> (v Float -> Expr) -> V3 (v Float) -> Expr-matX3C name f (V3 x y z) = functionCall name [f x, f y, f z]--matX4C :: String -> (v Float -> Expr) -> V4 (v Float) -> Expr-matX4C name f (V4 x y z w) = functionCall name [f x, f y, f z, f w]--codeGenConst :: Value -> Expr-codeGenConst (VBool v) = boolC v-codeGenConst (VV2B v) = v2C "bvec2" boolC v-codeGenConst (VV3B v) = v3C "bvec3" boolC v-codeGenConst (VV4B v) = v4C "bvec4" boolC v-codeGenConst (VWord v) = wordC v-codeGenConst (VV2U v) = v2C "uvec2" wordC v-codeGenConst (VV3U v) = v3C "uvec3" wordC v-codeGenConst (VV4U v) = v4C "uvec4" wordC v-codeGenConst (VInt v) = intC v-codeGenConst (VV2I v) = v2C "ivec2" intC v-codeGenConst (VV3I v) = v3C "ivec3" intC v-codeGenConst (VV4I v) = v4C "ivec4" intC v-codeGenConst (VFloat v) = floatC v-codeGenConst (VV2F v) = v2C "vec2" floatC v-codeGenConst (VV3F v) = v3C "vec3" floatC v-codeGenConst (VV4F v) = v4C "vec4" floatC v-codeGenConst (VM22F v) = matX2C "mat2" (v2C "vec2" floatC) v-codeGenConst (VM23F v) = matX3C "mat2x3" (v2C "vec2" floatC) v-codeGenConst (VM24F v) = matX4C "mat2x4" (v2C "vec2" floatC) v-codeGenConst (VM32F v) = matX2C "mat3x2" (v3C "vec3" floatC) v-codeGenConst (VM33F v) = matX3C "mat3" (v3C "vec3" floatC) v-codeGenConst (VM34F v) = matX4C "mat3x4" (v3C "vec3" floatC) v-codeGenConst (VM42F v) = matX2C "mat4x2" (v4C "vec4" floatC) v-codeGenConst (VM43F v) = matX3C "mat4x3" (v4C "vec4" floatC) v-codeGenConst (VM44F v) = matX4C "mat4" (v4C "vec4" floatC) v--type CGen a = State ([Statement],IntMap [Expr]) a--store :: DAG -> Int -> Expr -> CGen [Expr]-store dag expId exp = do- let name = "val" ++ show expId- newVar = Variable name- t = codeGenType $ expIdType dag expId- [ty] = {-trace (show expId ++ " [ty] = " ++ show t)-} t- newStmt = varStmt name (toGLSLType ty) exp- cnt = expIdCount dag expId- case cnt > 0 of- True -> do- (stmt,varMap) <- get- put (newStmt:stmt,IntMap.insert expId [newVar] varMap)- return [newVar]- False -> return [exp]--addStmt :: Statement -> CGen ()-addStmt s = do- (stmt,varMap) <- get- put (s:stmt,varMap)- return ()--addExpr :: ExpId -> [Expr] -> CGen ()-addExpr expId exprs = do- (stmt,varMap) <- get- put (stmt,IntMap.insert expId exprs varMap)- return ()--type Env = V.Vector [Expr]--codeGenExp' :: DAG -> Map Exp String -> Env -> ExpId -> CGen [Expr]-codeGenExp' dag smpName env expId = do- (stmt,varMap) <- get- case IntMap.lookup expId varMap of- Just v -> return v- Nothing -> case toExp dag expId of- - Loop st lc sr is -> do- -- state transform, loop condition, state to result, initial state- isE <- codeGenExp' dag smpName env is- let getBody a = case toExp dag a of- Lam b -> case toExp dag b of- Body c -> c- _ -> error "internal error: illegal lambda function!"- _ -> error "internal error: illegal lambda function!"- name = "state" ++ show expId ++ "_"- t = codeGenType $ expIdType dag is- (stS,stE) = unzip $ [(varStmt n (toGLSLType ty) e, Variable n) | (e,ty,i) <- zip3 isE t [0..], let n = name ++ show i]- mapM addStmt stS- {-- done - create state variable- done - create while loop:- done - loop condition expression- done - state transformation expression- done - create result from final state- -}- (_,loopCGenState) <- get- let loop = While (Condition $ BoolConstant True) (CompoundStatement $ Compound $ reverse body)- env' = (V.snoc env stE)- (_,(body,_)) = (flip runState) ([],loopCGenState) $ do- [lcE] <- codeGenExp' dag smpName env' (getBody lc)- addStmt (SelectionStatement (UnaryNot lcE) Break Nothing)- stE' <- codeGenExp' dag smpName env' (getBody st)- mapM_ addStmt $ zipWith assign stE stE'- return ()- addStmt loop- rE <- codeGenExp' dag smpName env' (getBody sr)- addExpr expId rE- return rE- Const c -> store dag expId $ codeGenConst c- Uni n -> return [Variable $! unpack n]- PrimVar n -> return [Variable $! unpack n]- PrimApp f arg -> do- arg' <- codeGenExp' dag smpName env arg- let argTy = codeGenType $ expIdType dag arg- ty = codeGenType $ expIdType dag expId- e = codeGenPrim f ty argTy arg'- if length e > 1 then return e else- store dag expId $ head $ e ++ error "PrimApp - head"- s@(Sampler f e t) -> case Map.lookup s smpName of- Just name -> return [Variable name]- Nothing -> error "Internal error: Unknown sampler value!"- Cond p t e -> do- [p'] <- codeGenExp' dag smpName env p- t' <- codeGenExp' dag smpName env t- e' <- codeGenExp' dag smpName env e- let branch a b = Selection p' a b- return $ zipWith branch t' e'- e@(Var i li) -> do- let ty = expType dag e- arity = length $! codeGenType ty- errEx = throw $ userError $ unlines $- [ "codeGenExp failed: "- , " Var " ++ show i ++ " (" ++ show li ++ ") :: " ++ show ty- , " input names: " ++ show env- , " arity: " ++ show arity- ]- case env V.!? i of- Nothing -> errEx- Just v -> return v --if length v == arity then return v else errEx-- Tup t -> concat <$> mapM (codeGenExp' dag smpName env) t- p@(Prj idx e) -> do- let ty = expType dag p- e' <- codeGenExp' dag smpName env e- return $ reverse . take (length $ codeGenType ty) . drop idx . reverse $ e'-{-- required info: output variable names- if we disable inline functions, it simplifies variable name gen--}--codeGenVertexShader :: DAG- -> Map Exp String- -> [(ByteString,InputType)]- -> Exp- -> (ByteString, [(ByteString,GLSL.InterpolationQualifier,InputType)])-codeGenVertexShader dag smpName inVars = cvt- where- genExp :: ExpId -> CGen [Expr]- genExp = codeGenExp' dag smpName $ V.singleton [Variable (unpack n) | n <- map fst inVars]-- genIExp :: Exp -> CGen (GLSL.InterpolationQualifier,[Expr],[InputType])- genIExp (Flat e) = (GLSL.Flat,,codeGenType $ expIdType dag e) <$> genExp e- genIExp (Smooth e) = (GLSL.Smooth,,codeGenType $ expIdType dag e) <$> genExp e- genIExp (NoPerspective e) = (GLSL.NoPerspective,,codeGenType $ expIdType dag e) <$> genExp e-- cvt :: Exp -> (ByteString, [(ByteString,GLSL.InterpolationQualifier,InputType)])- cvt (Lam lam) = cvt $ toExp dag lam- cvt (Body bodyExp) = (SB.unlines $!- [ "#version 330 core"- -- , "#extension GL_EXT_gpu_shader4 : enable"- -- , "#pragma optimize(off)"- , pp [uniform (unpack n) (toGLSLType t) | (n,t) <- uniVars]- , pp [uniform n (toGLSLType t) | (n,t) <- smpVars]- , pp [inVar (unpack n) (toGLSLType t) | (n,t) <- inVars]- , pp [outVarIQ (unpack n) iq (toGLSLType t) | n <- oNames | iq <- oQ | [t] <- oT]- , "void main ()"- , ppE (posE:sizeE:concat oE ++ clipE) ("gl_Position":"gl_PointSize":oNames ++ take clipCount clipNames)- ], [(n,q,t) | n <- oNames | q <- oQ | [t] <- oT])- where- clipCount = length clipE- clipNames = [pack $ "gl_ClipDistance[" ++ show i ++ "]" | i <- [0..]]- VertexOut pos size clips outs = toExp dag bodyExp- ppE e a = pack $! show $! pPrint $! Compound $ reverse stmt ++ [assign (Variable (unpack n)) ex | ex <- e | n <- a]- pp a = pack $! show $! pPrint $! TranslationUnit a- uniVars = Set.toList $ Set.fromList [(n,t) | u@(Uni n) <- expUniverse' dag (toExp dag bodyExp), let Single t = expType dag u]- smpVars = Set.toList $ Set.fromList [(n,t) | s@Sampler {} <- expUniverse' dag (toExp dag bodyExp), let Single t = expType dag s, let Just n = Map.lookup s smpName]- ((clipE,posE,sizeE,oQ,oE,oT),(stmt,_)) = runState genSrc ([],IntMap.empty)- genSrc = do- --[posE'] <- genExp pos- a <- genExp pos- let [posE'] = {-trace ("let [posE'] = " ++ show a)-} a- [sizeE'] <- genExp size- clipE' <- concat <$> mapM genExp clips- (oQ',oE',oT') <- unzip3 <$> mapM genIExp (map (toExp dag) outs)- return (clipE',posE',sizeE',oQ',oE',oT')- oNames = [pack $ "v" ++ show i | i <- [0..]]--codeGenGeometryShader :: DAG- -> Map Exp String- -> FetchPrimitive- -> [(ByteString,GLSL.InterpolationQualifier,InputType)]- -> Exp- -> (ByteString, [(ByteString,GLSL.InterpolationQualifier,InputType)])-codeGenGeometryShader dag samplerNameMap inPrim inVars geomSh@(GeometryShader layerCount outPrim maxGenVertices funPrimCnt funPrim funVert) = (SB.concat [srcPre, src], outVars)- where-{-- done - uniforms- done - samplers- done - input variables- - output variables- - - primitive count expression- - primitive loop- - vertex loop--}- srcPre = pack $ unlines $- [ "#version 330 core"- -- , "#extension GL_EXT_gpu_shader4 : enable"- , "layout(" ++ cvtInputPrim inPrim ++ ") in;"- , "layout (" ++ cvtOutputPrim outPrim ++ ", max_vertices=" ++ show maxGenVertices ++ ") out;"- ]- src = SB.unlines $- [ pp [uniform (unpack n) (toGLSLType t) | (n,t) <- uniVars]- , pp [uniform n (toGLSLType t) | (n,t) <- smpVars]- , pp [inVarArr (unpack n) iq (toGLSLType t) | (n,iq,t) <- inVars]- , pp [outVarIQ n iq (toGLSLType t) | n <- oNames | iq <- oQ | [t] <- oT]- , pack "void main ()"- -- , pack "{ for(int i = 0; i < gl_in.length(); i++) { gl_Position = gl_in[i].gl_Position; gl_PointSize = gl_in[i].gl_PointSize; EmitVertex(); } }"- , pack $! show $! pPrint $! Compound $ reverse stmt- ]-- pp a = pack $! show $! pPrint $! TranslationUnit a- uniVars = Set.toList $ Set.fromList [(n,t) | u@(Uni n) <- expUniverse' dag geomSh, let Single t = expType dag u]- smpVars = Set.toList $ Set.fromList [(n,t) | s@Sampler {} <- expUniverse' dag geomSh, let Single t = expType dag s, let Just n = Map.lookup s samplerNameMap]-- cvtInputPrim a = case a of- Points -> "points"- Lines -> "lines"- Triangles -> "triangles"- LinesAdjacency -> "lines_adjacency"- TrianglesAdjacency -> "triangles_adjacency"-- cvtOutputPrim a = case a of- TrianglesOutput -> "triangle_strip"- LinesOutput -> "line_strip"- PointsOutput -> "points"-- genExp :: Env -> ExpId -> CGen [Expr]- genExp = codeGenExp' dag samplerNameMap-- genIExp :: Env -> Exp -> CGen (GLSL.InterpolationQualifier,[Expr],[InputType])- genIExp env (Flat e) = (GLSL.Flat,,codeGenType $ expIdType dag e) <$> genExp env e- genIExp env (Smooth e) = (GLSL.Smooth,,codeGenType $ expIdType dag e) <$> genExp env e- genIExp env (NoPerspective e) = (GLSL.NoPerspective,,codeGenType $ expIdType dag e) <$> genExp env e-- oNames = ["g" ++ show i | i <- [0..]]- ((oQ,oT),(stmt,_)) = runState genSrc ([],IntMap.empty)- outVars = zip3 (map pack oNames) oQ (concat oT)- genSrc = do- -- calculate how many primitives should we generate- -- create primitive loop (ends with EndPrimitive())- -- create vertex loop (EmitVertex())- let primCntBody = getBody funPrimCnt- primCntLam = funPrimCnt- primBody = getBody funPrim- vertBody = getBody funVert- vertLam = funVert- GeometryOut stE pE sE cE oE = toExp dag vertBody- --Tuple [iTy,Single Int] = expIdType dag primCntBody- Tuple iTyInt = expIdType dag primCntBody- iTy = Tuple $ take (length iTyInt-1) iTyInt- (inputTy,clipsTy) = case expIdType dag primCntLam of- Tuple it@((Tuple [Single V4F,Single Float,ct,_]):_) -> (it,ct)- it@(Tuple [Single V4F,Single Float,ct,_]) -> ([it],ct)- t -> error $ "clipsTy error: " ++ show t- vertStTy = expIdType dag vertLam- -- create expressions for input primitive vertices- primVert i = [pre ++ "gl_Position", pre ++ "gl_PointSize"] ++- [pre ++ "gl_ClipDistance[" ++ show n ++ "]" | n <- [0..tySize clipsTy-1]] ++- [unpack n ++ post | (n,_,_) <- inVars]- where- pre = "gl_in[" ++ i ++ "]."- post = "[" ++ i ++ "]"- inputVerts = map Variable $ concat [primVert (show i) | i <- [0..length inputTy-1]]- eCnt <- codeGenExp' dag samplerNameMap (V.singleton inputVerts) primCntBody- (_,varMapP) <- get- let (primStateE,[primCntE]) = splitAt (length eCnt - 1) eCnt- (stPS,stPE) = unzip $ [(varStmt n (toGLSLType ty) e, Variable n) | (e,ty,i) <- zip3 primStateE (codeGenType iTy) [0..], let n = "statePrim_" ++ show i]- primCntVar = Variable "primCnt"- primIdVar = Variable "gl_PrimitiveID"- layerVar = Variable "gl_Layer"- clipVars = [Variable $ "gl_ClipDistance[" ++ show i ++ "]" | i <- [0..]]- (resP,(sP,_)) = runState primLoop ([],varMapP)- primLoop = do- (primIdE:layerE:stPrimStVertCntVert) <- genExp (V.singleton stPE) primBody- let (stPrimE',xsE) = splitAt (length primStateE) stPrimStVertCntVert- (stVertE,[vertCntE]) = splitAt (length xsE - 1) xsE- (stVS,stVE) = unzip $ [(varStmt n (toGLSLType ty) e, Variable n) | (e,ty,i) <- zip3 stVertE (codeGenType vertStTy) [0..], let n = "stateVert_" ++ show i]- vertCntVar = GLSL.Variable "vertCnt"- mapM addStmt stVS- (_,varMapV) <- get- let (resV,(sV,_)) = runState genVertFun ([],varMapV)- genVertFun = do- let env = V.singleton stVE- genVert = genExp env- stVE' <- genVert stE- [posE] <- genVert pE- [sizeE] <- genVert sE- clipsE <- concat <$> mapM genVert cE- (oQ',oE',oT') <- unzip3 <$> mapM (genIExp env) (map (toExp dag) oE)- -- set vertex variables - position, size, clip distances, outputs- addStmt $ assign (Variable "gl_Position") posE- addStmt $ assign (Variable "gl_PointSize") sizeE- mapM_ addStmt $ zipWith assign clipVars clipsE- mapM_ addStmt $ zipWith assign (map Variable oNames) (concat oE')- addStmt $ ExpressionStatement $ Just $ functionCall "EmitVertex" []- mapM_ addStmt $ zipWith assign stVE stVE'- return (oQ',oT')- addStmt $ varStmt "vertCnt" GLSL.Int vertCntE- addStmt $ assign primIdVar primIdE- addStmt $ assign layerVar layerE- addStmt $ GLSL.For (Left Nothing)- (Just $ GLSL.Condition $ GLSL.Gt vertCntVar (GLSL.IntConstant GLSL.Decimal 0))- (Just $ GLSL.PostDec vertCntVar)- (CompoundStatement $ Compound $ reverse sV)- addStmt $ ExpressionStatement $ Just $ functionCall "EndPrimitive" []- mapM_ addStmt $ zipWith assign stPE stPrimE'- return resV- mapM addStmt stPS- addStmt $ varStmt "primCnt" GLSL.Int primCntE- addStmt $ GLSL.For (Left Nothing)- (Just $ GLSL.Condition $ GLSL.Gt primCntVar (GLSL.IntConstant GLSL.Decimal 0))- (Just $ GLSL.PostDec primCntVar)- (CompoundStatement $ Compound $ reverse sP)- return resP-- getBody a = b- where- Lam l = toExp dag a- Body b = toExp dag l--codeGenFragmentShader :: DAG- -> Map Exp String- -> [(ByteString,GLSL.InterpolationQualifier,InputType)]- -> Exp- -> Exp- -> (ByteString, [(ByteString,InputType)],Int)-codeGenFragmentShader dag smpName inVars ffilter = cvt- where- cvtF :: Exp -> CGen Expr- cvtF (Lam lam) = cvtF $ toExp dag lam- cvtF (Body bodyExp) = do- [e] <- genExp bodyExp- return e-- cvt :: Exp -> (ByteString, [(ByteString,InputType)],Int)- cvt (Lam lam) = cvt $ toExp dag lam- cvt (Body bodyExp) = case toExp dag bodyExp of- FragmentOut e -> src e []- FragmentOutDepth de e -> src e [("gl_FragDepth",de)]- FragmentOutRastDepth e -> src e []-- genExp :: ExpId -> CGen [Expr]- genExp = codeGenExp' dag smpName $ V.singleton [Variable (unpack n) | (n,_,_) <- inVars]-- genFExp :: ExpId -> CGen ([Expr],[InputType])- genFExp e = (,codeGenType $ expIdType dag e) <$> genExp e-- oNames :: [ByteString]- oNames = [pack $ "f" ++ show i | i <- [0..]]-- src :: [ExpId] -> [(ByteString,ExpId)] -> (ByteString, [(ByteString,InputType)],Int)- src outs outs' = (SB.unlines $!- [ "#version 330 core"- -- , "#extension GL_EXT_gpu_shader4 : enable"- -- , "#pragma optimize(off)"- , pp [uniform (unpack n) (toGLSLType t) | (n,t) <- uniVars]- , pp [uniform n (toGLSLType t) | (n,t) <- smpVars]- , pp [inVarIQ (unpack n) iq (toGLSLType t) | (n,iq,t) <- inVars]- , pp [outVar (unpack n) (toGLSLType t) | n <- oNames | [t] <- oT]- , "void main ()"- , ppBody $ case ffilter of- PassAll -> reverse stmt ++ body- Filter f -> reverse fstmt ++ [SelectionStatement (UnaryNot fexpr) Discard $ Just (CompoundStatement $ Compound $ reverse stmt ++ body)]- ], [(n,t) | n <- oNames | [t] <- oT], length outs)- where- assigns a e = [assign (Variable (unpack n)) ex | ex <- e | n <- a]- ppBody l = pack $! show $! pPrint $! Compound l- pp a = pack $! show $! pPrint $! TranslationUnit a- allExps = concat [expUniverse' dag outs, expUniverse' dag (map snd outs'), filterExps]- filterExps = case ffilter of- PassAll -> []- Filter f -> expUniverse' dag f- uniVars = Set.toList $ Set.fromList [(n,t) | u@(Uni n) <- allExps, let Single t = expType dag u]- smpVars = Set.toList $ Set.fromList [(n,t) | s@Sampler {} <- allExps, let Single t = expType dag s, let Just n = Map.lookup s smpName]- body = assigns (oN' ++ oNames) (concat oE' ++ concat oE)- ((oE',oN',oE,oT,fstmt,fexpr),(stmt,_)) = runState genSrc ([],IntMap.empty)- genSrc = do- fexpr' <- case ffilter of- PassAll -> return $ boolC True- Filter f -> cvtF $ toExp dag f- (fstmt',s) <- get- put ([],s)- (oE'',oN'') <- unzip <$> sequence [(,n) <$> genExp e | (n,e) <- outs']- (oE',oT') <- unzip <$> mapM genFExp outs- return (oE'',oN'',oE',oT',fstmt',fexpr')---codeGenType :: Ty -> [InputType]-codeGenType (Single ty) = [ty]-codeGenType (Tuple l) = concatMap codeGenType l-codeGenType t = error $ "codeGenType error: " ++ show t---- Utility functions-toGLSLType :: InputType -> TypeSpecifierNonArray-toGLSLType t = case t of- Bool -> GLSL.Bool- V2B -> GLSL.BVec2- V3B -> GLSL.BVec3- V4B -> GLSL.BVec4- Word -> GLSL.UInt- V2U -> GLSL.UVec2- V3U -> GLSL.UVec3- V4U -> GLSL.UVec4- Int -> GLSL.Int- V2I -> GLSL.IVec2- V3I -> GLSL.IVec3- V4I -> GLSL.IVec4- Float -> GLSL.Float- V2F -> GLSL.Vec2- V3F -> GLSL.Vec3- V4F -> GLSL.Vec4- M22F -> GLSL.Mat2- M23F -> GLSL.Mat2x3- M24F -> GLSL.Mat2x4- M32F -> GLSL.Mat3x2- M33F -> GLSL.Mat3- M34F -> GLSL.Mat3x4- M42F -> GLSL.Mat4x2- M43F -> GLSL.Mat4x3- M44F -> GLSL.Mat4- -- shadow textures- STexture1D -> GLSL.Sampler1DShadow- STexture2D -> GLSL.Sampler2DShadow- STextureCube -> GLSL.SamplerCubeShadow- STexture1DArray -> GLSL.Sampler1DArrayShadow- STexture2DArray -> GLSL.Sampler2DArrayShadow- STexture2DRect -> GLSL.Sampler2DRectShadow- -- float textures- FTexture1D -> GLSL.Sampler1D- FTexture2D -> GLSL.Sampler2D- FTexture3D -> GLSL.Sampler3D- FTextureCube -> GLSL.SamplerCube- FTexture1DArray -> GLSL.Sampler1DArray- FTexture2DArray -> GLSL.Sampler2DArray- FTexture2DMS -> GLSL.Sampler2DMS- FTexture2DMSArray -> GLSL.Sampler2DMSArray- FTextureBuffer -> GLSL.SamplerBuffer- FTexture2DRect -> GLSL.Sampler2DRect- -- int textures- ITexture1D -> GLSL.ISampler1D- ITexture2D -> GLSL.ISampler2D- ITexture3D -> GLSL.ISampler3D- ITextureCube -> GLSL.ISamplerCube- ITexture1DArray -> GLSL.ISampler1DArray- ITexture2DArray -> GLSL.ISampler2DArray- ITexture2DMS -> GLSL.ISampler2DMS- ITexture2DMSArray -> GLSL.ISampler2DMSArray- ITextureBuffer -> GLSL.ISamplerBuffer- ITexture2DRect -> GLSL.ISampler2DRect- -- uint textures- UTexture1D -> GLSL.USampler1D- UTexture2D -> GLSL.USampler2D- UTexture3D -> GLSL.USampler3D- UTextureCube -> GLSL.USamplerCube- UTexture1DArray -> GLSL.USampler1DArray- UTexture2DArray -> GLSL.USampler2DArray- UTexture2DMS -> GLSL.USampler2DMS- UTexture2DMSArray -> GLSL.USampler2DMSArray- UTextureBuffer -> GLSL.USamplerBuffer- UTexture2DRect -> GLSL.USampler2DRect--varInit :: String -> TypeSpecifierNonArray -> Maybe TypeQualifier -> Maybe Expr -> Declaration-varInit name ty tq val = InitDeclaration (TypeDeclarator varType) [InitDecl name Nothing val]- where- varTySpecNoPrec = TypeSpecNoPrecision ty Nothing- varTySpec = TypeSpec Nothing varTySpecNoPrec- varType = FullType tq varTySpec--var :: String -> TypeSpecifierNonArray -> Maybe TypeQualifier -> Declaration-var name ty tq = varInit name ty tq Nothing--uniform :: String -> TypeSpecifierNonArray -> ExternalDeclaration-uniform name ty = Declaration $ var name ty (Just $ TypeQualSto Uniform)--inVar :: String -> TypeSpecifierNonArray -> ExternalDeclaration-inVar name ty = Declaration $ var name ty (Just $ TypeQualSto In)--inVarArr :: String -> GLSL.InterpolationQualifier -> TypeSpecifierNonArray -> ExternalDeclaration-inVarArr name iq ty = Declaration $ InitDeclaration (TypeDeclarator varType) [InitDecl name (Just Nothing) Nothing]- where- tq = Just $ TypeQualInt iq $ Just In- varTySpecNoPrec = TypeSpecNoPrecision ty Nothing- varTySpec = TypeSpec Nothing varTySpecNoPrec- varType = FullType tq varTySpec--inVarIQ :: String -> GLSL.InterpolationQualifier -> TypeSpecifierNonArray -> ExternalDeclaration-inVarIQ name iq ty = Declaration $ var name ty (Just $ TypeQualInt iq $ Just In)--outVar :: String -> TypeSpecifierNonArray -> ExternalDeclaration-outVar name ty = Declaration $ var name ty (Just $ TypeQualSto Out)--outVarIQ :: String -> GLSL.InterpolationQualifier -> TypeSpecifierNonArray -> ExternalDeclaration-outVarIQ name iq ty = Declaration $ var name ty (Just $ TypeQualInt iq $ Just Out)-{--attribute :: String -> TypeSpecifierNonArray -> ExternalDeclaration-attribute name ty = Declaration $ var name ty (Just $ TypeQualSto Attribute)--varying :: String -> TypeSpecifierNonArray -> ExternalDeclaration-varying name ty = Declaration $ var name ty (Just $ TypeQualSto Varying)--varyingIQ :: String -> GLSL.InterpolationQualifier -> TypeSpecifierNonArray -> ExternalDeclaration-varyingIQ name iq ty = Declaration $ var name ty (Just $ TypeQualInt iq $ Just Varying)--}-assign :: Expr -> Expr -> Statement-assign l r = ExpressionStatement $ Just $ Equal l r--varStmt :: String -> TypeSpecifierNonArray -> Expr -> Statement-varStmt name ty val = DeclarationStatement $ varInit name ty Nothing $ Just val
− src/lib/LambdaCube/GL/Mesh.hs
@@ -1,229 +0,0 @@-module LambdaCube.GL.Mesh (- loadMesh,- saveMesh,- addMesh,- compileMesh,- updateMesh,- Mesh(..),- MeshPrimitive(..),- MeshAttribute(..)-) where--import Control.Applicative-import Control.Monad-import Data.Binary-import Data.ByteString.Char8 (ByteString)-import Foreign.Ptr-import Data.Int-import Foreign.Storable-import Foreign.Marshal.Utils-import System.IO.Unsafe-import qualified Data.ByteString.Char8 as SB-import qualified Data.ByteString.Lazy as LB-import qualified Data.Trie as T-import qualified Data.Vector.Storable as V-import qualified Data.Vector.Storable.Mutable as MV--import LambdaCube.GL--fileVersion :: Int32-fileVersion = 1--data MeshAttribute- = A_Float (V.Vector Float)- | A_V2F (V.Vector V2F)- | A_V3F (V.Vector V3F)- | A_V4F (V.Vector V4F)- | A_M22F (V.Vector M22F)- | A_M33F (V.Vector M33F)- | A_M44F (V.Vector M44F)- | A_Int (V.Vector Int32)- | A_Word (V.Vector Word32)--data MeshPrimitive- = P_Points- | P_TriangleStrip- | P_Triangles- | P_TriangleStripI (V.Vector Int32)- | P_TrianglesI (V.Vector Int32)--data Mesh- = Mesh - { mAttributes :: T.Trie MeshAttribute- , mPrimitive :: MeshPrimitive- , mGPUData :: Maybe GPUData- }--data GPUData- = GPUData- { dPrimitive :: Primitive- , dStreams :: T.Trie (Stream Buffer)- , dIndices :: Maybe (IndexStream Buffer)- }--loadMesh :: ByteString -> IO Mesh-loadMesh n = compileMesh =<< decode <$> LB.readFile (SB.unpack n)--saveMesh :: ByteString -> Mesh -> IO ()-saveMesh n m = LB.writeFile (SB.unpack n) (encode m)--addMesh :: Renderer -> ByteString -> Mesh -> [ByteString] -> IO Object-addMesh renderer slotName (Mesh _ _ (Just (GPUData prim streams indices))) objUniNames = do- -- select proper attributes- let Just (slotPrim,slotStreams) = T.lookup slotName $! slotStream renderer- filterStream n s- | T.member n slotStreams = Just s- | otherwise = Nothing- addObject renderer slotName prim indices (T.mapBy filterStream streams) objUniNames-addMesh _ _ _ _ = fail "addMesh: only compiled mesh with GPUData is supported"--withV w a f = w a (\p -> f $ castPtr p)--meshAttrToArray :: MeshAttribute -> Array-meshAttrToArray (A_Float v) = Array ArrFloat (1 * V.length v) $ withV V.unsafeWith v-meshAttrToArray (A_V2F v) = Array ArrFloat (2 * V.length v) $ withV V.unsafeWith v-meshAttrToArray (A_V3F v) = Array ArrFloat (3 * V.length v) $ withV V.unsafeWith v-meshAttrToArray (A_V4F v) = Array ArrFloat (4 * V.length v) $ withV V.unsafeWith v-meshAttrToArray (A_M22F v) = Array ArrFloat (4 * V.length v) $ withV V.unsafeWith v-meshAttrToArray (A_M33F v) = Array ArrFloat (9 * V.length v) $ withV V.unsafeWith v-meshAttrToArray (A_M44F v) = Array ArrFloat (16 * V.length v) $ withV V.unsafeWith v-meshAttrToArray (A_Int v) = Array ArrInt32 (1 * V.length v) $ withV V.unsafeWith v-meshAttrToArray (A_Word v) = Array ArrWord32 (1 * V.length v) $ withV V.unsafeWith v--meshAttrToStream :: Buffer -> Int -> MeshAttribute -> Stream Buffer-meshAttrToStream b i (A_Float v) = Stream TFloat b i 0 (V.length v)-meshAttrToStream b i (A_V2F v) = Stream TV2F b i 0 (V.length v)-meshAttrToStream b i (A_V3F v) = Stream TV3F b i 0 (V.length v)-meshAttrToStream b i (A_V4F v) = Stream TV4F b i 0 (V.length v)-meshAttrToStream b i (A_M22F v) = Stream TM22F b i 0 (V.length v)-meshAttrToStream b i (A_M33F v) = Stream TM33F b i 0 (V.length v)-meshAttrToStream b i (A_M44F v) = Stream TM44F b i 0 (V.length v)-meshAttrToStream b i (A_Int v) = Stream TInt b i 0 (V.length v)-meshAttrToStream b i (A_Word v) = Stream TWord b i 0 (V.length v)--{--updateBuffer :: Buffer -> [(Int,Array)] -> IO ()-- | Stream - { streamType :: StreamType- , streamBuffer :: b- , streamArrIdx :: Int- , streamStart :: Int- , streamLength :: Int- }---- stream of index values (for index buffer)-data IndexStream b- = IndexStream- { indexBuffer :: b- , indexArrIdx :: Int- , indexStart :: Int- , indexLength :: Int- }--}-updateMesh :: Mesh -> [(ByteString,MeshAttribute)] -> Maybe MeshPrimitive -> IO ()-updateMesh (Mesh dMA dMP (Just (GPUData _ dS dI))) al mp = do- -- check type match- let arrayChk (Array t1 s1 _) (Array t2 s2 _) = t1 == t2 && s1 == s2- ok = and [T.member n dMA && arrayChk (meshAttrToArray a1) (meshAttrToArray a2) | (n,a1) <- al, let Just a2 = T.lookup n dMA]- if not ok then putStrLn "updateMesh: attribute mismatch!"- else do- forM_ al $ \(n,a) -> do- case T.lookup n dS of- Just (Stream _ b i _ _) -> updateBuffer b [(i,meshAttrToArray a)]- _ -> return ()-{-- case mp of- Nothing -> return ()- Just p -> do- let ok2 = case (dMP,p) of- (Just (P_TriangleStripI v1, P_TriangleStripI v2) -> V.length v1 == V.length v2- (P_TrianglesI v1, P_TrianglesI v2) -> V.length v1 == V.length v2- (a,b) -> a == b--}--compileMesh :: Mesh -> IO Mesh-compileMesh (Mesh attrs mPrim Nothing) = do- let mkIndexBuf v = do- iBuf <- compileBuffer [Array ArrWord32 (V.length v) $ withV V.unsafeWith v]- return $! Just $! IndexStream iBuf 0 0 (V.length v)- vBuf <- compileBuffer [meshAttrToArray a | a <- T.elems attrs]- (indices,prim) <- case mPrim of- P_Points -> return (Nothing,PointList)- P_TriangleStrip -> return (Nothing,TriangleStrip)- P_Triangles -> return (Nothing,TriangleList)- P_TriangleStripI v -> (,TriangleStrip) <$> mkIndexBuf v- P_TrianglesI v -> (,TriangleList) <$> mkIndexBuf v- let streams = T.fromList $! zipWith (\i (n,a) -> (n,meshAttrToStream vBuf i a)) [0..] (T.toList attrs)- gpuData = GPUData prim streams indices- return $! Mesh attrs mPrim (Just gpuData)--compileMesh mesh = return mesh--sblToV :: Storable a => [SB.ByteString] -> V.Vector a-sblToV ls = v- where- offs o (s:xs) = (o,s):offs (o + SB.length s) xs- offs _ [] = []- cnt = sum (map SB.length ls) `div` (sizeOf $ V.head v)- v = unsafePerformIO $ do- mv <- MV.new cnt- MV.unsafeWith mv $ \dst -> forM_ (offs 0 ls) $ \(o,s) ->- SB.useAsCStringLen s $ \(src,len) -> moveBytes (plusPtr dst o) src len- V.unsafeFreeze mv--vToSB :: Storable a => V.Vector a -> SB.ByteString-vToSB v = unsafePerformIO $ do- let len = V.length v * sizeOf (V.head v)- V.unsafeWith v $ \p -> SB.packCStringLen (castPtr p,len)--instance Storable a => Binary (V.Vector a) where- put v = put $ vToSB v- get = do s <- get ; return $ sblToV [s]--instance Binary MeshAttribute where- put (A_Float a) = putWord8 0 >> put a- put (A_V2F a) = putWord8 1 >> put a- put (A_V3F a) = putWord8 2 >> put a- put (A_V4F a) = putWord8 3 >> put a- put (A_M22F a) = putWord8 4 >> put a- put (A_M33F a) = putWord8 5 >> put a- put (A_M44F a) = putWord8 6 >> put a- put (A_Int a) = putWord8 7 >> put a- put (A_Word a) = putWord8 8 >> put a- get = do- tag_ <- getWord8- case tag_ of- 0 -> A_Float <$> get- 1 -> A_V2F <$> get- 2 -> A_V3F <$> get- 3 -> A_V4F <$> get- 4 -> A_M22F <$> get- 5 -> A_M33F <$> get- 6 -> A_M44F <$> get- 7 -> A_Int <$> get- 8 -> A_Word <$> get- _ -> fail "no parse"--instance Binary MeshPrimitive where- put P_Points = putWord8 0- put P_TriangleStrip = putWord8 1- put P_Triangles = putWord8 2- put (P_TriangleStripI a) = putWord8 3 >> put a- put (P_TrianglesI a) = putWord8 4 >> put a- get = do- tag_ <- getWord8- case tag_ of- 0 -> return P_Points- 1 -> return P_TriangleStrip- 2 -> return P_Triangles- 3 -> P_TriangleStripI <$> get- 4 -> P_TrianglesI <$> get- _ -> fail "no parse"--instance Binary Mesh where- put (Mesh a b _) = put (T.toList a) >> put b- get = do- a <- get- b <- get- return $! Mesh (T.fromList a) b Nothing
− src/lib/LambdaCube/GL/Type.hs
@@ -1,476 +0,0 @@-module LambdaCube.GL.Type where--import Data.ByteString.Char8 (ByteString)-import Data.IORef-import Data.Word-import Data.Map (Map)---import Data.IntMap (IntMap)-import Data.Set (Set)-import Data.Trie (Trie)-import Data.Vector.Unboxed.Mutable (IOVector)-import qualified Data.Vector as V-import qualified Data.Vector.Unboxed.Mutable as MV--import Graphics.Rendering.OpenGL.Raw.Core32 (GLint, GLuint)-import Foreign.Storable-import Foreign.Ptr-import Data.Int-import Data.Typeable--import LambdaCube.Core.Type-import LambdaCube.Core.DeBruijn--{-- we should store:- generic attributer setters (default values in that case when an attribute is missing from a mesh)- question:- should we provide default attributes or should we require a full attribute description from the user?- answer: the latter seems better idea!- question:- is a mesh object constant in vertex attributes? e.g. if we'd like to change the value of an attribute buffer or generic attribute- then we have to swap the old mesh object with a new one.- answer: seems a good and reasonable idea, because we can customize object rendering using per object uniforms!- PUBLIC:- - slotUniforms :: Trie (Trie InputType)- - slotStreams :: Trie (PrimitiveType, Trie InputType)- - uniformSetter :: Trie InputSetter- - render :: IO ()- - dispose :: IO ()- INTERNAL:- - object sets :: Trie (TVar ObjectSet)- - globalUniformSetup :: Trie (GLint -> IO ())- - uniform setup actions :: Trie (STM (GLint -> IO (), InputSetter))- - attribute setup actions :: Trie (GLuint -> StreamSetter)-- note: if we'd like to support slot sharing between different sub gfx networks,- then we have to check that they have the same primitve type and- there is no type collision if we build the union of they stream input- otherwise we can not support slot sharing.- should we use namespaces in stream input names?- e.g "slot name/atribute name" in this case we can store stream attribute descriptions in a single trie.- or should we use trie of tries?- discussion:- how to handle sub network uniform/attribute naming- - global all- - namespace prefix in name- - trie of tries- temporary decision:- i'll use global names-- minimal restricition for (global name) uniforms and attributes:- a name sould bound to only one type!-- TODO:- proper handling of attribute and uniform sharing between shader programs- two alternatives:- - use same mapping for every program (more efficient, but requires more gl features)- - use custom mapping per program with custom attribute/uniform setter (less efficient, but more compatible/less restricitive)--}-------------- API -------------{---- Buffer- compileBuffer :: [Array] -> IO Buffer- bufferSize :: Buffer -> Int- arraySize :: Buffer -> Int -> Int- arrayType :: Buffer -> Int -> ArrayType---- Renderer- compileRenderer :: GPOutput -> IO Renderer- slotUniforms :: Renderer -> Trie (Trie InputType)- slotStreams :: Renderer -> Trie (PrimitiveType, Trie InputType)- uniformSetter :: Renderer -> Trie InputSetter- render :: Renderer -> IO ()- dispose :: Renderer -> IO ()---- Object- addObject :: Renderer -> ByteString -> Primitive -> Maybe (IndexStream Buffer) -> Trie (Stream Buffer) -> [ByteString] -> IO Object- removeObject :: Renderer -> Object -> IO ()- objectUniformSetter :: Object -> Trie InputSetter--}--data Renderer -- internal type- = Renderer- -- public- { slotUniform :: Trie (Trie InputType)- , slotStream :: Trie (FetchPrimitive, Trie InputType)- , uniformSetter :: Trie InputSetter -- global uniform- , render :: IO ()- , dispose :: IO ()- , setScreenSize :: Word -> Word -> IO ()- , samplerOutput :: Trie TextureData-- -- internal- , mkUniformSetup :: Trie (GLint -> IO ()) -- global unifiorm- , slotDescriptor :: Trie SlotDescriptor- , renderDescriptor :: Map Exp RenderDescriptor --Map GP RenderDescriptor- , renderState :: RenderState- , objectIDSeed :: IORef Int- }--data RenderDescriptor- = RenderDescriptor- { uniformLocation :: Trie GLint -- Uniform name -> GLint- , streamLocation :: Trie GLuint -- Attribute name -> GLuint- , renderAction :: IO ()- , disposeAction :: IO ()- , drawObjectsIORef :: IORef ObjectSet -- updated internally, according objectSet- -- hint: Map is required to support slot sharing across different Accumulation nodes,- -- because each node requires it's own render action list: [IO ()]- , fragmentOutCount :: Int- }--data SlotDescriptor- = SlotDescriptor- { attachedGP :: Set Exp- , objectSet :: IORef (Set Object) -- objects, added to this slot (set by user)- }--data ObjectSet- = ObjectSet- { drawObject :: IO () -- synthetized/sorted render action- , drawObjectMap :: Map Object (IO ()) -- original render actions- }--data Object -- internal type- = Object- { objectSlotName :: ByteString- , objectUniformSetter :: Trie InputSetter- , objectID :: Int- , objectEnabledIORef :: IORef Bool- }--instance Eq Object where- a == b = objectID a == objectID b--instance Ord Object where- a `compare` b = objectID a `compare` objectID b--data RenderState- = RenderState- { textureUnitState :: IOVector Int- , renderTargetSize :: IORef V2U- }--type StreamSetter = Stream Buffer -> IO ()--data Buffer -- internal type- = Buffer- { bufArrays :: V.Vector ArrayDesc- , bufGLObj :: GLuint- }- deriving (Show,Eq)--data ArrayDesc- = ArrayDesc- { arrType :: ArrayType- , arrLength :: Int -- item count- , arrOffset :: Int -- byte position in buffer- , arrSize :: Int -- size in bytes- }- deriving (Show,Eq)---- storable instances-instance Storable a => Storable (V2 a) where- sizeOf _ = 2 * sizeOf (undefined :: a)- alignment _ = sizeOf (undefined :: a)-- peek q = do- let p = castPtr q :: Ptr a- k = sizeOf (undefined :: a)- x <- peek p - y <- peekByteOff p k- return $! (V2 x y)-- poke q (V2 x y) = do- let p = castPtr q :: Ptr a- k = sizeOf (undefined :: a)- poke p x- pokeByteOff p k y--instance Storable a => Storable (V3 a) where- sizeOf _ = 3 * sizeOf (undefined :: a)- alignment _ = sizeOf (undefined :: a)-- peek q = do- let p = castPtr q :: Ptr a- k = sizeOf (undefined :: a)- x <- peek p - y <- peekByteOff p k- z <- peekByteOff p (k*2)- return $! (V3 x y z)-- poke q (V3 x y z) = do- let p = castPtr q :: Ptr a- k = sizeOf (undefined :: a)- poke p x- pokeByteOff p k y- pokeByteOff p (k*2) z--instance Storable a => Storable (V4 a) where- sizeOf _ = 4 * sizeOf (undefined :: a)- alignment _ = sizeOf (undefined :: a)-- peek q = do- let p = castPtr q :: Ptr a- k = sizeOf (undefined :: a)- x <- peek p - y <- peekByteOff p k- z <- peekByteOff p (k*2)- w <- peekByteOff p (k*3)- return $! (V4 x y z w)-- poke q (V4 x y z w) = do- let p = castPtr q :: Ptr a- k = sizeOf (undefined :: a)- poke p x- pokeByteOff p k y- pokeByteOff p (k*2) z- pokeByteOff p (k*3) w--data TextureData- = TextureData- { textureObject :: GLuint- } deriving Show--type SetterFun a = a -> IO ()-newtype Getter a = Getter (IO a)-newtype Setter a = Setter (SetterFun a)--type InputGetter = Input Getter-type InputSetter = Input Setter---- user will provide scalar input data via this type-data Input a- = SBool (a Bool)- | SV2B (a V2B)- | SV3B (a V3B)- | SV4B (a V4B)- | SWord (a Word32)- | SV2U (a V2U)- | SV3U (a V3U)- | SV4U (a V4U)- | SInt (a Int32)- | SV2I (a V2I)- | SV3I (a V3I)- | SV4I (a V4I)- | SFloat (a Float)- | SV2F (a V2F)- | SV3F (a V3F)- | SV4F (a V4F)- | SM22F (a M22F)- | SM23F (a M23F)- | SM24F (a M24F)- | SM32F (a M32F)- | SM33F (a M33F)- | SM34F (a M34F)- | SM42F (a M42F)- | SM43F (a M43F)- | SM44F (a M44F)- -- shadow textures- | SSTexture1D- | SSTexture2D- | SSTextureCube- | SSTexture1DArray- | SSTexture2DArray- | SSTexture2DRect- -- float textures- | SFTexture1D- | SFTexture2D (a TextureData)- | SFTexture3D- | SFTextureCube- | SFTexture1DArray- | SFTexture2DArray- | SFTexture2DMS- | SFTexture2DMSArray- | SFTextureBuffer- | SFTexture2DRect- -- int textures- | SITexture1D- | SITexture2D- | SITexture3D- | SITextureCube- | SITexture1DArray- | SITexture2DArray- | SITexture2DMS- | SITexture2DMSArray- | SITextureBuffer- | SITexture2DRect- -- uint textures- | SUTexture1D- | SUTexture2D- | SUTexture3D- | SUTextureCube- | SUTexture1DArray- | SUTexture2DArray- | SUTexture2DMS- | SUTexture2DMSArray- | SUTextureBuffer- | SUTexture2DRect---- buffer handling-{-- user can fills a buffer (continuous memory region)- each buffer have a data descriptor, what describes the- buffer content. e.g. a buffer can contain more arrays of stream types--}---- user will provide stream data using this setup function-type BufferSetter = (Ptr () -> IO ()) -> IO ()---- specifies array component type (stream type in storage side)--- this type can be overridden in GPU side, e.g ArrWord8 can be seen as TFloat or TWord also-data ArrayType- = ArrWord8- | ArrWord16- | ArrWord32- | ArrInt8- | ArrInt16- | ArrInt32- | ArrFloat- | ArrHalf -- Hint: half float is not supported in haskell- deriving (Read,Typeable,Show,Eq,Ord)--sizeOfArrayType :: ArrayType -> Int-sizeOfArrayType ArrWord8 = 1-sizeOfArrayType ArrWord16 = 2-sizeOfArrayType ArrWord32 = 4-sizeOfArrayType ArrInt8 = 1-sizeOfArrayType ArrInt16 = 2-sizeOfArrayType ArrInt32 = 4-sizeOfArrayType ArrFloat = 4-sizeOfArrayType ArrHalf = 2---- describes an array in a buffer-data Array -- array type, element count (NOT byte size!), setter- = Array ArrayType Int BufferSetter--data Primitive- = TriangleStrip- | TriangleList- | TriangleFan- | LineStrip- | LineList- | PointList- | TriangleStripAdjacency- | TriangleListAdjacency- | LineStripAdjacency- | LineListAdjacency- deriving (Read,Typeable,Eq,Ord,Bounded,Enum,Show)---- dev hint: this should be InputType--- we restrict StreamType using type class--- subset of InputType, describes a stream type (in GPU side)-data StreamType- = TWord- | TV2U- | TV3U- | TV4U- | TInt- | TV2I- | TV3I- | TV4I- | TFloat- | TV2F- | TV3F- | TV4F- | TM22F- | TM23F- | TM24F- | TM32F- | TM33F- | TM34F- | TM42F- | TM43F- | TM44F- deriving (Read,Typeable,Show,Eq,Ord)--toStreamType :: InputType -> Maybe StreamType-toStreamType Word = Just TWord-toStreamType V2U = Just TV2U-toStreamType V3U = Just TV3U-toStreamType V4U = Just TV4U-toStreamType Int = Just TInt-toStreamType V2I = Just TV2I-toStreamType V3I = Just TV3I-toStreamType V4I = Just TV4I-toStreamType Float = Just TFloat-toStreamType V2F = Just TV2F-toStreamType V3F = Just TV3F-toStreamType V4F = Just TV4F-toStreamType M22F = Just TM22F-toStreamType M23F = Just TM23F-toStreamType M24F = Just TM24F-toStreamType M32F = Just TM32F-toStreamType M33F = Just TM33F-toStreamType M34F = Just TM34F-toStreamType M42F = Just TM42F-toStreamType M43F = Just TM43F-toStreamType M44F = Just TM44F-toStreamType _ = Nothing--fromStreamType :: StreamType -> InputType-fromStreamType TWord = Word-fromStreamType TV2U = V2U-fromStreamType TV3U = V3U-fromStreamType TV4U = V4U-fromStreamType TInt = Int-fromStreamType TV2I = V2I-fromStreamType TV3I = V3I-fromStreamType TV4I = V4I-fromStreamType TFloat = Float-fromStreamType TV2F = V2F-fromStreamType TV3F = V3F-fromStreamType TV4F = V4F-fromStreamType TM22F = M22F-fromStreamType TM23F = M23F-fromStreamType TM24F = M24F-fromStreamType TM32F = M32F-fromStreamType TM33F = M33F-fromStreamType TM34F = M34F-fromStreamType TM42F = M42F-fromStreamType TM43F = M43F-fromStreamType TM44F = M44F---- user can specify streams using Stream type--- a stream can be constant (ConstXXX) or can came from a buffer-data Stream b- = ConstWord Word32- | ConstV2U V2U- | ConstV3U V3U- | ConstV4U V4U- | ConstInt Int32- | ConstV2I V2I- | ConstV3I V3I- | ConstV4I V4I- | ConstFloat Float- | ConstV2F V2F- | ConstV3F V3F- | ConstV4F V4F- | ConstM22F M22F- | ConstM23F M23F- | ConstM24F M24F- | ConstM32F M32F- | ConstM33F M33F- | ConstM34F M34F- | ConstM42F M42F- | ConstM43F M43F- | ConstM44F M44F- | Stream - { streamType :: StreamType- , streamBuffer :: b- , streamArrIdx :: Int- , streamStart :: Int- , streamLength :: Int- }---- stream of index values (for index buffer)-data IndexStream b- = IndexStream- { indexBuffer :: b- , indexArrIdx :: Int- , indexStart :: Int- , indexLength :: Int- }
− src/lib/LambdaCube/GL/Util.hs
@@ -1,990 +0,0 @@-module LambdaCube.GL.Util (- queryUniforms,- queryStreams,- mkUniformSetter,- mkSSetter,- compileShader,- printProgramLog,- glGetShaderiv1,- glGetProgramiv1,- Buffer(..),- ArrayDesc(..),- StreamSetter,- streamToInputType,- arrayTypeToGLType,- comparisonFunctionToGLType,- logicOperationToGLType,- blendEquationToGLType,- blendingFactorToGLType,- checkGL,- textureDataTypeToGLType,- textureDataTypeToGLArityType,- glGetIntegerv1,- setSampler,- checkFBO,- createGLTextureObject-) where--import Control.Applicative-import Control.Exception-import Control.Monad-import Data.ByteString.Char8 (ByteString)-import Data.IORef-import Data.List as L-import Data.Trie as T-import Foreign-import qualified Data.ByteString.Char8 as SB-import qualified Data.Vector as V-import Data.Vector.Unboxed.Mutable (IOVector)-import qualified Data.Vector.Unboxed.Mutable as MV--import Graphics.Rendering.OpenGL.Raw.Core32- ( GLchar- , GLenum- , GLint- , GLsizei- , GLuint- , gl_FALSE- , gl_TRUE- , glGetIntegerv-- -- ERROR CHECKING related- -- error handling- , glGetError- , glCheckFramebufferStatus- -- error checking- , gl_COMPILE_STATUS- , gl_DRAW_FRAMEBUFFER- , gl_FRAMEBUFFER_COMPLETE- , gl_FRAMEBUFFER_INCOMPLETE_ATTACHMENT- , gl_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER- , gl_FRAMEBUFFER_INCOMPLETE_LAYER_TARGETS- , gl_FRAMEBUFFER_INCOMPLETE_MULTISAMPLE- , gl_FRAMEBUFFER_INCOMPLETE_READ_BUFFER- , gl_FRAMEBUFFER_UNDEFINED- , gl_FRAMEBUFFER_UNSUPPORTED- , gl_INFO_LOG_LENGTH- , gl_INVALID_ENUM- , gl_INVALID_FRAMEBUFFER_OPERATION- , gl_INVALID_OPERATION- , gl_INVALID_VALUE- , gl_NO_ERROR- , gl_OUT_OF_MEMORY-- -- TEXTURE related- -- texture data- , glActiveTexture- , glBindTexture- , glGenTextures- , glTexImage2D- , glTexImage3D- , glTexParameteri- , gl_TEXTURE0-- -- texture parameters- , gl_CLAMP_TO_BORDER- , gl_CLAMP_TO_EDGE- , gl_MIRRORED_REPEAT- , gl_REPEAT- , gl_LINEAR- , gl_NEAREST-- , gl_TEXTURE_CUBE_MAP- , gl_TEXTURE_CUBE_MAP_POSITIVE_X- , gl_TEXTURE_CUBE_MAP_NEGATIVE_X- , gl_TEXTURE_CUBE_MAP_POSITIVE_Y- , gl_TEXTURE_CUBE_MAP_NEGATIVE_Y- , gl_TEXTURE_CUBE_MAP_POSITIVE_Z- , gl_TEXTURE_CUBE_MAP_NEGATIVE_Z- , gl_TEXTURE_2D- , gl_TEXTURE_2D_ARRAY- , gl_TEXTURE_MAG_FILTER- , gl_TEXTURE_MIN_FILTER- , gl_TEXTURE_WRAP_S- , gl_TEXTURE_WRAP_T- , gl_TEXTURE_BASE_LEVEL- , gl_TEXTURE_MAX_LEVEL-- -- texture format- , gl_R32F- , gl_R32I- , gl_R32UI- , gl_RED- , gl_RG- , gl_RG32F- , gl_RG32I- , gl_RG32UI- , gl_RGB- , gl_RGB32F- , gl_RGB32I- , gl_RGB32UI- , gl_RGBA- , gl_RGBA32F- , gl_RGBA32I- , gl_RGBA32UI-- -- SHADER related- -- shader program- , glCompileShader- , glGetActiveAttrib- , glGetActiveUniform- , glGetAttribLocation- , glGetProgramInfoLog- , glGetProgramiv- , glGetShaderInfoLog- , glGetShaderiv- , glGetUniformLocation- , glShaderSource-- -- stream data (stream parameter)- , glBindBuffer- , glDisableVertexAttribArray- , glEnableVertexAttribArray- , glVertexAttrib1fv- , glVertexAttrib2fv- , glVertexAttrib3fv- , glVertexAttrib4fv- , glVertexAttribI1iv- , glVertexAttribI1uiv- , glVertexAttribI2iv- , glVertexAttribI2uiv- , glVertexAttribI3iv- , glVertexAttribI3uiv- , glVertexAttribI4iv- , glVertexAttribI4uiv- , glVertexAttribIPointer- , glVertexAttribPointer- , gl_ACTIVE_ATTRIBUTES- , gl_ACTIVE_ATTRIBUTE_MAX_LENGTH- , gl_ARRAY_BUFFER-- -- stream value representation- , gl_BYTE- , gl_HALF_FLOAT- , gl_SHORT- , gl_UNSIGNED_BYTE- , gl_UNSIGNED_SHORT-- -- uniform data (constant parameter)- , glUniform1fv- , glUniform1i- , glUniform1iv- , glUniform1uiv- , glUniform2fv- , glUniform2iv- , glUniform2uiv- , glUniform3fv- , glUniform3iv- , glUniform3uiv- , glUniform4fv- , glUniform4iv- , glUniform4uiv- , glUniformMatrix2fv- , glUniformMatrix2x3fv- , glUniformMatrix2x4fv- , glUniformMatrix3fv- , glUniformMatrix3x2fv- , glUniformMatrix3x4fv- , glUniformMatrix4fv- , glUniformMatrix4x2fv- , glUniformMatrix4x3fv- , gl_ACTIVE_UNIFORMS- , gl_ACTIVE_UNIFORM_MAX_LENGTH-- -- uniform types (constant value types)- , gl_BOOL- , gl_BOOL_VEC2- , gl_BOOL_VEC3- , gl_BOOL_VEC4- , gl_FLOAT- , gl_FLOAT_MAT2- , gl_FLOAT_MAT2x3- , gl_FLOAT_MAT2x4- , gl_FLOAT_MAT3- , gl_FLOAT_MAT3x2- , gl_FLOAT_MAT3x4- , gl_FLOAT_MAT4- , gl_FLOAT_MAT4x2- , gl_FLOAT_MAT4x3- , gl_FLOAT_VEC2- , gl_FLOAT_VEC3- , gl_FLOAT_VEC4- , gl_INT- , gl_INT_SAMPLER_1D- , gl_INT_SAMPLER_1D_ARRAY- , gl_INT_SAMPLER_2D- , gl_INT_SAMPLER_2D_ARRAY- , gl_INT_SAMPLER_2D_MULTISAMPLE- , gl_INT_SAMPLER_2D_MULTISAMPLE_ARRAY- , gl_INT_SAMPLER_2D_RECT- , gl_INT_SAMPLER_3D- , gl_INT_SAMPLER_BUFFER- , gl_INT_SAMPLER_CUBE- , gl_INT_VEC2- , gl_INT_VEC3- , gl_INT_VEC4- , gl_SAMPLER_1D- , gl_SAMPLER_1D_ARRAY- , gl_SAMPLER_1D_ARRAY_SHADOW- , gl_SAMPLER_1D_SHADOW- , gl_SAMPLER_2D- , gl_SAMPLER_2D_ARRAY- , gl_SAMPLER_2D_ARRAY_SHADOW- , gl_SAMPLER_2D_MULTISAMPLE- , gl_SAMPLER_2D_MULTISAMPLE_ARRAY- , gl_SAMPLER_2D_RECT- , gl_SAMPLER_2D_RECT_SHADOW- , gl_SAMPLER_2D_SHADOW- , gl_SAMPLER_3D- , gl_SAMPLER_BUFFER- , gl_SAMPLER_CUBE- , gl_SAMPLER_CUBE_SHADOW- , gl_UNSIGNED_INT- , gl_UNSIGNED_INT_SAMPLER_1D- , gl_UNSIGNED_INT_SAMPLER_1D_ARRAY- , gl_UNSIGNED_INT_SAMPLER_2D- , gl_UNSIGNED_INT_SAMPLER_2D_ARRAY- , gl_UNSIGNED_INT_SAMPLER_2D_MULTISAMPLE- , gl_UNSIGNED_INT_SAMPLER_2D_MULTISAMPLE_ARRAY- , gl_UNSIGNED_INT_SAMPLER_2D_RECT- , gl_UNSIGNED_INT_SAMPLER_3D- , gl_UNSIGNED_INT_SAMPLER_BUFFER- , gl_UNSIGNED_INT_SAMPLER_CUBE- , gl_UNSIGNED_INT_VEC2- , gl_UNSIGNED_INT_VEC3- , gl_UNSIGNED_INT_VEC4-- -- CONTEXT PARAMETER realted- -- depth and stencil operation- , gl_ALWAYS- , gl_EQUAL- , gl_GEQUAL- , gl_GREATER- , gl_LEQUAL- , gl_LESS- , gl_NEVER- , gl_NOTEQUAL-- -- blending function- , gl_FUNC_ADD- , gl_FUNC_REVERSE_SUBTRACT- , gl_FUNC_SUBTRACT- , gl_MAX- , gl_MIN-- -- blending- , gl_CONSTANT_ALPHA- , gl_CONSTANT_COLOR- , gl_DST_ALPHA- , gl_DST_COLOR- , gl_ONE- , gl_ONE_MINUS_CONSTANT_ALPHA- , gl_ONE_MINUS_CONSTANT_COLOR- , gl_ONE_MINUS_DST_ALPHA- , gl_ONE_MINUS_DST_COLOR- , gl_ONE_MINUS_SRC_ALPHA- , gl_ONE_MINUS_SRC_COLOR- , gl_SRC_ALPHA- , gl_SRC_ALPHA_SATURATE- , gl_SRC_COLOR- , gl_ZERO-- -- logic operation- , gl_AND- , gl_AND_INVERTED- , gl_AND_REVERSE- , gl_CLEAR- , gl_COPY- , gl_COPY_INVERTED- , gl_EQUIV- , gl_INVERT- , gl_NAND- , gl_NOOP- , gl_NOR- , gl_OR- , gl_OR_INVERTED- , gl_OR_REVERSE- , gl_SET- , gl_XOR- )--import LambdaCube.Core.Type-import LambdaCube.Core.DeBruijn-import LambdaCube.GL.Type--setSampler :: GLint -> Int32 -> IO ()-setSampler i v = glUniform1i i $ fromIntegral v--z2 = V2 0 0 :: V2F-z3 = V3 0 0 0 :: V3F-z4 = V4 0 0 0 0 :: V4F---- uniform functions-queryUniforms :: GLuint -> IO (Trie GLint, Trie InputType)-queryUniforms po = do- ul <- getNameTypeSize po glGetActiveUniform glGetUniformLocation gl_ACTIVE_UNIFORMS gl_ACTIVE_UNIFORM_MAX_LENGTH- let uNames = [n | (n,_,_,_) <- ul]- uTypes = [fromGLType (e,s) | (_,_,e,s) <- ul]- uLocation = [i | (_,i,_,_) <- ul]- return $! (T.fromList $! zip uNames uLocation, T.fromList $! zip uNames uTypes)--mkUniformSetter :: RenderState -> InputType -> IO (GLint -> IO (), InputSetter, InputGetter)-mkUniformSetter _ Bool = do {t <- newIORef False; return $! (\i -> readIORef t >>= setUBool i, SBool $! Setter $ writeIORef t, SBool $ Getter $ readIORef t)}-mkUniformSetter _ V2B = do {t <- newIORef (V2 False False); return $! (\i -> readIORef t >>= setUV2B i, SV2B $! Setter $ writeIORef t, SV2B $ Getter $ readIORef t)}-mkUniformSetter _ V3B = do {t <- newIORef (V3 False False False); return $! (\i -> readIORef t >>= setUV3B i, SV3B $! Setter $ writeIORef t, SV3B $ Getter $ readIORef t)}-mkUniformSetter _ V4B = do {t <- newIORef (V4 False False False False); return $! (\i -> readIORef t >>= setUV4B i, SV4B $! Setter $ writeIORef t, SV4B $ Getter $ readIORef t)}-mkUniformSetter _ Word = do {t <- newIORef 0; return $! (\i -> readIORef t >>= setUWord i, SWord $! Setter $ writeIORef t, SWord $ Getter $ readIORef t)}-mkUniformSetter _ V2U = do {t <- newIORef (V2 0 0); return $! (\i -> readIORef t >>= setUV2U i, SV2U $! Setter $ writeIORef t, SV2U $ Getter $ readIORef t)}-mkUniformSetter _ V3U = do {t <- newIORef (V3 0 0 0); return $! (\i -> readIORef t >>= setUV3U i, SV3U $! Setter $ writeIORef t, SV3U $ Getter $ readIORef t)}-mkUniformSetter _ V4U = do {t <- newIORef (V4 0 0 0 0); return $! (\i -> readIORef t >>= setUV4U i, SV4U $! Setter $ writeIORef t, SV4U $ Getter $ readIORef t)}-mkUniformSetter _ Int = do {t <- newIORef 0; return $! (\i -> readIORef t >>= setUInt i, SInt $! Setter $ writeIORef t, SInt $ Getter $ readIORef t)}-mkUniformSetter _ V2I = do {t <- newIORef (V2 0 0); return $! (\i -> readIORef t >>= setUV2I i, SV2I $! Setter $ writeIORef t, SV2I $ Getter $ readIORef t)}-mkUniformSetter _ V3I = do {t <- newIORef (V3 0 0 0); return $! (\i -> readIORef t >>= setUV3I i, SV3I $! Setter $ writeIORef t, SV3I $ Getter $ readIORef t)}-mkUniformSetter _ V4I = do {t <- newIORef (V4 0 0 0 0); return $! (\i -> readIORef t >>= setUV4I i, SV4I $! Setter $ writeIORef t, SV4I $ Getter $ readIORef t)}-mkUniformSetter _ Float = do {t <- newIORef 0; return $! (\i -> readIORef t >>= setUFloat i, SFloat $! Setter $ writeIORef t, SFloat $ Getter $ readIORef t)}-mkUniformSetter _ V2F = do {t <- newIORef (V2 0 0); return $! (\i -> readIORef t >>= setUV2F i, SV2F $! Setter $ writeIORef t, SV2F $ Getter $ readIORef t)}-mkUniformSetter _ V3F = do {t <- newIORef (V3 0 0 0); return $! (\i -> readIORef t >>= setUV3F i, SV3F $! Setter $ writeIORef t, SV3F $ Getter $ readIORef t)}-mkUniformSetter _ V4F = do {t <- newIORef (V4 0 0 0 0); return $! (\i -> readIORef t >>= setUV4F i, SV4F $! Setter $ writeIORef t, SV4F $ Getter $ readIORef t)}-mkUniformSetter _ M22F = do {t <- newIORef (V2 z2 z2); return $! (\i -> readIORef t >>= setUM22F i, SM22F $! Setter $ writeIORef t, SM22F $ Getter $ readIORef t)}-mkUniformSetter _ M23F = do {t <- newIORef (V3 z2 z2 z2); return $! (\i -> readIORef t >>= setUM23F i, SM23F $! Setter $ writeIORef t, SM23F $ Getter $ readIORef t)}-mkUniformSetter _ M24F = do {t <- newIORef (V4 z2 z2 z2 z2); return $! (\i -> readIORef t >>= setUM24F i, SM24F $! Setter $ writeIORef t, SM24F $ Getter $ readIORef t)}-mkUniformSetter _ M32F = do {t <- newIORef (V2 z3 z3); return $! (\i -> readIORef t >>= setUM32F i, SM32F $! Setter $ writeIORef t, SM32F $ Getter $ readIORef t)}-mkUniformSetter _ M33F = do {t <- newIORef (V3 z3 z3 z3); return $! (\i -> readIORef t >>= setUM33F i, SM33F $! Setter $ writeIORef t, SM33F $ Getter $ readIORef t)}-mkUniformSetter _ M34F = do {t <- newIORef (V4 z3 z3 z3 z3); return $! (\i -> readIORef t >>= setUM34F i, SM34F $! Setter $ writeIORef t, SM34F $ Getter $ readIORef t)}-mkUniformSetter _ M42F = do {t <- newIORef (V2 z4 z4); return $! (\i -> readIORef t >>= setUM42F i, SM42F $! Setter $ writeIORef t, SM42F $ Getter $ readIORef t)}-mkUniformSetter _ M43F = do {t <- newIORef (V3 z4 z4 z4); return $! (\i -> readIORef t >>= setUM43F i, SM43F $! Setter $ writeIORef t, SM43F $ Getter $ readIORef t)}-mkUniformSetter _ M44F = do {t <- newIORef (V4 z4 z4 z4 z4); return $! (\i -> readIORef t >>= setUM44F i, SM44F $! Setter $ writeIORef t, SM44F $ Getter $ readIORef t)}-mkUniformSetter rendState FTexture2D = do- let texUnitState = textureUnitState rendState- t <- newIORef (TextureData 0)- return $! (\i -> readIORef t >>= setTextureData texUnitState i, SFTexture2D $! Setter $ writeIORef t, SFTexture2D $ Getter $ readIORef t)---- FIXME: implement properly-setTextureData :: IOVector Int -> GLint -> TextureData -> IO ()-setTextureData texUnitState texUnitIdx (TextureData texObj) = do- let texUnitIdx' = fromIntegral texUnitIdx- texObj' = fromIntegral texObj- curTexObj <- MV.read texUnitState texUnitIdx'- when (curTexObj /= texObj') $ do- MV.write texUnitState texUnitIdx' texObj'- glActiveTexture $ gl_TEXTURE0 + fromIntegral texUnitIdx- glBindTexture gl_TEXTURE_2D texObj- --putStrLn (" -- uniform setup - Texture bind (TexUnit " ++ show (texUnitIdx,texObj) ++ " TexObj)")--b2w :: Bool -> GLuint-b2w True = 1-b2w False = 0--setUBool :: GLint -> Bool -> IO ()-setUV2B :: GLint -> V2B -> IO ()-setUV3B :: GLint -> V3B -> IO ()-setUV4B :: GLint -> V4B -> IO ()-setUBool i v = with (b2w v) $! \p -> glUniform1uiv i 1 p-setUV2B i (V2 x y) = with (V2 (b2w x) (b2w y)) $! \p -> glUniform2uiv i 1 $! castPtr p-setUV3B i (V3 x y z) = with (V3 (b2w x) (b2w y) (b2w z)) $! \p -> glUniform3uiv i 1 $! castPtr p-setUV4B i (V4 x y z w) = with (V4 (b2w x) (b2w y) (b2w z) (b2w w)) $! \p -> glUniform4uiv i 1 $! castPtr p--setUWord :: GLint -> Word32 -> IO ()-setUV2U :: GLint -> V2U -> IO ()-setUV3U :: GLint -> V3U -> IO ()-setUV4U :: GLint -> V4U -> IO ()-setUWord i v = with v $! \p -> glUniform1uiv i 1 $! castPtr p-setUV2U i v = with v $! \p -> glUniform2uiv i 1 $! castPtr p-setUV3U i v = with v $! \p -> glUniform3uiv i 1 $! castPtr p-setUV4U i v = with v $! \p -> glUniform4uiv i 1 $! castPtr p--setUInt :: GLint -> Int32 -> IO ()-setUV2I :: GLint -> V2I -> IO ()-setUV3I :: GLint -> V3I -> IO ()-setUV4I :: GLint -> V4I -> IO ()-setUInt i v = with v $! \p -> glUniform1iv i 1 $! castPtr p-setUV2I i v = with v $! \p -> glUniform2iv i 1 $! castPtr p-setUV3I i v = with v $! \p -> glUniform3iv i 1 $! castPtr p-setUV4I i v = with v $! \p -> glUniform4iv i 1 $! castPtr p--setUFloat :: GLint -> Float -> IO ()-setUV2F :: GLint -> V2F -> IO ()-setUV3F :: GLint -> V3F -> IO ()-setUV4F :: GLint -> V4F -> IO ()-setUFloat i v = with v $! \p -> glUniform1fv i 1 $! castPtr p-setUV2F i v = with v $! \p -> glUniform2fv i 1 $! castPtr p-setUV3F i v = with v $! \p -> glUniform3fv i 1 $! castPtr p-setUV4F i v = with v $! \p -> glUniform4fv i 1 $! castPtr p--setUM22F :: GLint -> M22F -> IO ()-setUM23F :: GLint -> M23F -> IO ()-setUM24F :: GLint -> M24F -> IO ()-setUM22F i v = with v $! \p -> glUniformMatrix2fv i 1 (fromIntegral gl_FALSE) $! castPtr p-setUM23F i v = with v $! \p -> glUniformMatrix2x3fv i 1 (fromIntegral gl_FALSE) $! castPtr p-setUM24F i v = with v $! \p -> glUniformMatrix2x4fv i 1 (fromIntegral gl_FALSE) $! castPtr p--setUM32F :: GLint -> M32F -> IO ()-setUM33F :: GLint -> M33F -> IO ()-setUM34F :: GLint -> M34F -> IO ()-setUM32F i v = with v $! \p -> glUniformMatrix3x2fv i 1 (fromIntegral gl_FALSE) $! castPtr p-setUM33F i v = with v $! \p -> glUniformMatrix3fv i 1 (fromIntegral gl_FALSE) $! castPtr p-setUM34F i v = with v $! \p -> glUniformMatrix3x4fv i 1 (fromIntegral gl_FALSE) $! castPtr p--setUM42F :: GLint -> M42F -> IO ()-setUM43F :: GLint -> M43F -> IO ()-setUM44F :: GLint -> M44F -> IO ()-setUM42F i v = with v $! \p -> glUniformMatrix4x2fv i 1 (fromIntegral gl_FALSE) $! castPtr p-setUM43F i v = with v $! \p -> glUniformMatrix4x3fv i 1 (fromIntegral gl_FALSE) $! castPtr p-setUM44F i v = with v $! \p -> glUniformMatrix4fv i 1 (fromIntegral gl_FALSE) $! castPtr p---- attribute functions-queryStreams :: GLuint -> IO (Trie GLuint, Trie InputType)-queryStreams po = do- al <- getNameTypeSize po glGetActiveAttrib glGetAttribLocation gl_ACTIVE_ATTRIBUTES gl_ACTIVE_ATTRIBUTE_MAX_LENGTH- let aNames = [n | (n,_,_,_) <- al]- aTypes = [fromGLType (e,s) | (_,_,e,s) <- al]- aLocation = [fromIntegral i | (_,i,_,_) <- al]- return $! (T.fromList $! zip aNames aLocation, T.fromList $! zip aNames aTypes)---- should handle constant value and buffer value as well-mkSSetter :: InputType -> GLuint -> StreamSetter-mkSSetter Word i (ConstWord v) = setAWord i v-mkSSetter V2U i (ConstV2U v) = setAV2U i v-mkSSetter V3U i (ConstV3U v) = setAV3U i v-mkSSetter V4U i (ConstV4U v) = setAV4U i v-mkSSetter Word i (Stream TWord b a s l) = setBufInteger 1 i b a s-mkSSetter V2U i (Stream TV2U b a s l) = setBufInteger 2 i b a s-mkSSetter V3U i (Stream TV3U b a s l) = setBufInteger 3 i b a s-mkSSetter V4U i (Stream TV4U b a s l) = setBufInteger 4 i b a s- -mkSSetter Int i (ConstInt v) = setAInt i v-mkSSetter V2I i (ConstV2I v) = setAV2I i v-mkSSetter V3I i (ConstV3I v) = setAV3I i v-mkSSetter V4I i (ConstV4I v) = setAV4I i v-mkSSetter Int i (Stream TInt b a s l) = setBufInteger 1 i b a s-mkSSetter V2I i (Stream TV2I b a s l) = setBufInteger 2 i b a s-mkSSetter V3I i (Stream TV3I b a s l) = setBufInteger 3 i b a s-mkSSetter V4I i (Stream TV4I b a s l) = setBufInteger 4 i b a s- -mkSSetter Float i (ConstFloat v) = setAFloat i v-mkSSetter V2F i (ConstV2F v) = setAV2F i v-mkSSetter V3F i (ConstV3F v) = setAV3F i v-mkSSetter V4F i (ConstV4F v) = setAV4F i v-mkSSetter Float i (Stream TFloat b a s l) = setBufFloat 1 i b a s-mkSSetter V2F i (Stream TV2F b a s l) = setBufFloat 2 i b a s-mkSSetter V3F i (Stream TV3F b a s l) = setBufFloat 3 i b a s-mkSSetter V4F i (Stream TV4F b a s l) = setBufFloat 4 i b a s- -mkSSetter M22F i (ConstM22F v) = setAM22F i v-mkSSetter M23F i (ConstM23F v) = setAM23F i v-mkSSetter M24F i (ConstM24F v) = setAM24F i v-mkSSetter M22F i (Stream TM22F b a s l) = setBufFloat 4 i b a s-mkSSetter M23F i (Stream TM23F b a s l) = setBufFloat 6 i b a s-mkSSetter M24F i (Stream TM24F b a s l) = setBufFloat 8 i b a s- -mkSSetter M32F i (ConstM32F v) = setAM32F i v-mkSSetter M33F i (ConstM33F v) = setAM33F i v-mkSSetter M34F i (ConstM34F v) = setAM34F i v-mkSSetter M32F i (Stream TM32F b a s l) = setBufFloat 6 i b a s-mkSSetter M33F i (Stream TM33F b a s l) = setBufFloat 9 i b a s-mkSSetter M34F i (Stream TM34F b a s l) = setBufFloat 12 i b a s- -mkSSetter M42F i (ConstM42F v) = setAM42F i v-mkSSetter M43F i (ConstM43F v) = setAM43F i v-mkSSetter M44F i (ConstM44F v) = setAM44F i v-mkSSetter M42F i (Stream TM42F b a s l) = setBufFloat 8 i b a s-mkSSetter M43F i (Stream TM43F b a s l) = setBufFloat 12 i b a s-mkSSetter M44F i (Stream TM44F b a s l) = setBufFloat 16 i b a s-mkSSetter _ _ _ = fail "mkSSetter type mismatch!"--arrayTypeToGLType :: ArrayType -> GLenum-arrayTypeToGLType ArrWord8 = gl_UNSIGNED_BYTE-arrayTypeToGLType ArrWord16 = gl_UNSIGNED_SHORT-arrayTypeToGLType ArrWord32 = gl_UNSIGNED_INT-arrayTypeToGLType ArrInt8 = gl_BYTE-arrayTypeToGLType ArrInt16 = gl_SHORT-arrayTypeToGLType ArrInt32 = gl_INT-arrayTypeToGLType ArrFloat = gl_FLOAT-arrayTypeToGLType ArrHalf = gl_HALF_FLOAT--setBufFloat :: GLint -> GLuint -> Buffer -> Int -> Int -> IO ()-setBufFloat compCnt i (Buffer arrs bo) arrIdx start = do- let ArrayDesc arrType arrLen arrOffs arrSize = arrs V.! arrIdx- glType = arrayTypeToGLType arrType- ptr = intPtrToPtr $! fromIntegral (arrOffs + start * fromIntegral compCnt * sizeOfArrayType arrType)- glBindBuffer gl_ARRAY_BUFFER bo- glEnableVertexAttribArray i- glVertexAttribPointer i compCnt glType (fromIntegral gl_FALSE) 0 ptr--setBufInteger :: GLint -> GLuint -> Buffer -> Int -> Int -> IO ()---setBufInteger = setBufFloat -- FIXME: GL 2.1 does not have glVertexAttribIPointer-setBufInteger compCnt i (Buffer arrs bo) arrIdx start = do- let ArrayDesc arrType arrLen arrOffs arrSize = arrs V.! arrIdx- glType = arrayTypeToGLType arrType- ptr = intPtrToPtr $! fromIntegral (arrOffs + start * fromIntegral compCnt * sizeOfArrayType arrType)- glBindBuffer gl_ARRAY_BUFFER bo- glEnableVertexAttribArray i- -- GL 3.X version- glVertexAttribIPointer i compCnt glType 0 ptr--setAWord :: GLuint -> Word32 -> IO ()-setAV2U :: GLuint -> V2U -> IO ()-setAV3U :: GLuint -> V3U -> IO ()-setAV4U :: GLuint -> V4U -> IO ()-setAWord i v = glDisableVertexAttribArray i >> (with v $! \p -> glVertexAttribI1uiv i $! castPtr p)-setAV2U i v = glDisableVertexAttribArray i >> (with v $! \p -> glVertexAttribI2uiv i $! castPtr p)-setAV3U i v = glDisableVertexAttribArray i >> (with v $! \p -> glVertexAttribI3uiv i $! castPtr p)-setAV4U i v = glDisableVertexAttribArray i >> (with v $! \p -> glVertexAttribI4uiv i $! castPtr p)--setAInt :: GLuint -> Int32 -> IO ()-setAV2I :: GLuint -> V2I -> IO ()-setAV3I :: GLuint -> V3I -> IO ()-setAV4I :: GLuint -> V4I -> IO ()-setAInt i v = glDisableVertexAttribArray i >> (with v $! \p -> glVertexAttribI1iv i $! castPtr p)-setAV2I i v = glDisableVertexAttribArray i >> (with v $! \p -> glVertexAttribI2iv i $! castPtr p)-setAV3I i v = glDisableVertexAttribArray i >> (with v $! \p -> glVertexAttribI3iv i $! castPtr p)-setAV4I i v = glDisableVertexAttribArray i >> (with v $! \p -> glVertexAttribI4iv i $! castPtr p)--setAFloat :: GLuint -> Float -> IO ()-setAV2F :: GLuint -> V2F -> IO ()-setAV3F :: GLuint -> V3F -> IO ()-setAV4F :: GLuint -> V4F -> IO ()-setAFloat i v = glDisableVertexAttribArray i >> (with v $! \p -> glVertexAttrib1fv i $! castPtr p)-setAV2F i v = glDisableVertexAttribArray i >> (with v $! \p -> glVertexAttrib2fv i $! castPtr p)-setAV3F i v = glDisableVertexAttribArray i >> (with v $! \p -> glVertexAttrib3fv i $! castPtr p)-setAV4F i v = glDisableVertexAttribArray i >> (with v $! \p -> glVertexAttrib4fv i $! castPtr p)--setAM22F :: GLuint -> M22F -> IO ()-setAM23F :: GLuint -> M23F -> IO ()-setAM24F :: GLuint -> M24F -> IO ()-setAM22F i (V2 x y) = setAV2F i x >> setAV2F (i+1) y-setAM23F i (V3 x y z) = setAV2F i x >> setAV2F (i+1) y >> setAV2F (i+2) z-setAM24F i (V4 x y z w) = setAV2F i x >> setAV2F (i+1) y >> setAV2F (i+2) z >> setAV2F (i+3) w--setAM32F :: GLuint -> M32F -> IO ()-setAM33F :: GLuint -> M33F -> IO ()-setAM34F :: GLuint -> M34F -> IO ()-setAM32F i (V2 x y) = setAV3F i x >> setAV3F (i+1) y-setAM33F i (V3 x y z) = setAV3F i x >> setAV3F (i+1) y >> setAV3F (i+2) z-setAM34F i (V4 x y z w) = setAV3F i x >> setAV3F (i+1) y >> setAV3F (i+2) z >> setAV3F (i+3) w--setAM42F :: GLuint -> M42F -> IO ()-setAM43F :: GLuint -> M43F -> IO ()-setAM44F :: GLuint -> M44F -> IO ()-setAM42F i (V2 x y) = setAV4F i x >> setAV4F (i+1) y-setAM43F i (V3 x y z) = setAV4F i x >> setAV4F (i+1) y >> setAV4F (i+2) z-setAM44F i (V4 x y z w) = setAV4F i x >> setAV4F (i+1) y >> setAV4F (i+2) z >> setAV4F (i+3) w---- result list: [(name string,location,gl type,component count)]-getNameTypeSize :: GLuint -> (GLuint -> GLuint -> GLsizei -> Ptr GLsizei -> Ptr GLint -> Ptr GLenum -> Ptr GLchar -> IO ())- -> (GLuint -> Ptr GLchar -> IO GLint) -> GLenum -> GLenum -> IO [(ByteString,GLint,GLenum,GLint)]-getNameTypeSize o f g enum enumLen = do- nameLen <- glGetProgramiv1 enumLen o- allocaArray (fromIntegral nameLen) $! \namep -> alloca $! \sizep -> alloca $! \typep -> do- n <- glGetProgramiv1 enum o- forM [0..n-1] $! \i -> f o (fromIntegral i) (fromIntegral nameLen) nullPtr sizep typep namep >>- (,,,) <$> SB.packCString (castPtr namep) <*> g o namep <*> peek typep <*> peek sizep-{--filterSamplers :: [(ByteString,GLint,GLenum,GLint)] -> ([(ByteString,GLint,GLenum,GLint)],[(ByteString,GLint,GLenum,GLint)])-filterSamplers l = partition (\(_,_,e,_) -> elem e samplerTypes) l- where- samplerTypes = [gl_SAMPLER_2D]--}-fromGLType :: (GLenum,GLint) -> InputType-fromGLType (t,1)- | t == gl_BOOL = Bool- | t == gl_BOOL_VEC2 = V2B- | t == gl_BOOL_VEC3 = V3B- | t == gl_BOOL_VEC4 = V4B- | t == gl_UNSIGNED_INT = Word- | t == gl_UNSIGNED_INT_VEC2 = V2U- | t == gl_UNSIGNED_INT_VEC3 = V3U- | t == gl_UNSIGNED_INT_VEC4 = V4U- | t == gl_INT = Int- | t == gl_INT_VEC2 = V2I- | t == gl_INT_VEC3 = V3I- | t == gl_INT_VEC4 = V4I- | t == gl_FLOAT = Float- | t == gl_FLOAT_VEC2 = V2F- | t == gl_FLOAT_VEC3 = V3F- | t == gl_FLOAT_VEC4 = V4F- | t == gl_FLOAT_MAT2 = M22F- | t == gl_FLOAT_MAT2x3 = M23F- | t == gl_FLOAT_MAT2x4 = M24F- | t == gl_FLOAT_MAT3x2 = M32F- | t == gl_FLOAT_MAT3 = M33F- | t == gl_FLOAT_MAT3x4 = M34F- | t == gl_FLOAT_MAT4x2 = M42F- | t == gl_FLOAT_MAT4x3 = M43F- | t == gl_FLOAT_MAT4 = M44F- | t == gl_SAMPLER_1D_ARRAY_SHADOW = STexture1DArray- | t == gl_SAMPLER_1D_SHADOW = STexture1D- | t == gl_SAMPLER_2D_ARRAY_SHADOW = STexture2DArray- | t == gl_SAMPLER_2D_RECT_SHADOW = STexture2DRect- | t == gl_SAMPLER_2D_SHADOW = STexture2D- | t == gl_SAMPLER_CUBE_SHADOW = STextureCube- | t == gl_INT_SAMPLER_1D = ITexture1D- | t == gl_INT_SAMPLER_1D_ARRAY = ITexture1DArray- | t == gl_INT_SAMPLER_2D = ITexture2D- | t == gl_INT_SAMPLER_2D_ARRAY = ITexture2DArray- | t == gl_INT_SAMPLER_2D_MULTISAMPLE = ITexture2DMS- | t == gl_INT_SAMPLER_2D_MULTISAMPLE_ARRAY = ITexture2DMSArray- | t == gl_INT_SAMPLER_2D_RECT = ITexture2DRect- | t == gl_INT_SAMPLER_3D = ITexture3D- | t == gl_INT_SAMPLER_BUFFER = ITextureBuffer- | t == gl_INT_SAMPLER_CUBE = ITextureCube- | t == gl_SAMPLER_1D = FTexture1D- | t == gl_SAMPLER_1D_ARRAY = FTexture1DArray- | t == gl_SAMPLER_2D = FTexture2D- | t == gl_SAMPLER_2D_ARRAY = FTexture2DArray- | t == gl_SAMPLER_2D_MULTISAMPLE = FTexture2DMS- | t == gl_SAMPLER_2D_MULTISAMPLE_ARRAY = FTexture2DMSArray- | t == gl_SAMPLER_2D_RECT = FTexture2DRect- | t == gl_SAMPLER_3D = FTexture3D- | t == gl_SAMPLER_BUFFER = FTextureBuffer- | t == gl_SAMPLER_CUBE = FTextureCube- | t == gl_UNSIGNED_INT_SAMPLER_1D = UTexture1D- | t == gl_UNSIGNED_INT_SAMPLER_1D_ARRAY = UTexture1DArray- | t == gl_UNSIGNED_INT_SAMPLER_2D = UTexture2D- | t == gl_UNSIGNED_INT_SAMPLER_2D_ARRAY = UTexture2DArray- | t == gl_UNSIGNED_INT_SAMPLER_2D_MULTISAMPLE = UTexture2DMS- | t == gl_UNSIGNED_INT_SAMPLER_2D_MULTISAMPLE_ARRAY = UTexture2DMSArray- | t == gl_UNSIGNED_INT_SAMPLER_2D_RECT = UTexture2DRect- | t == gl_UNSIGNED_INT_SAMPLER_3D = UTexture3D- | t == gl_UNSIGNED_INT_SAMPLER_BUFFER = UTextureBuffer- | t == gl_UNSIGNED_INT_SAMPLER_CUBE = UTextureCube- | otherwise = error "Failed fromGLType"-fromGLUniformType _ = error "Failed fromGLType"--printShaderLog :: GLuint -> IO ()-printShaderLog o = do- i <- glGetShaderiv1 gl_INFO_LOG_LENGTH o- when (i > 0) $- alloca $ \sizePtr -> allocaArray (fromIntegral i) $! \ps -> do- glGetShaderInfoLog o (fromIntegral i) sizePtr ps- size <- peek sizePtr- log <- SB.packCStringLen (castPtr ps, fromIntegral size)- SB.putStrLn log--glGetShaderiv1 :: GLenum -> GLuint -> IO GLint-glGetShaderiv1 pname o = alloca $! \pi -> glGetShaderiv o pname pi >> peek pi--glGetProgramiv1 :: GLenum -> GLuint -> IO GLint-glGetProgramiv1 pname o = alloca $! \pi -> glGetProgramiv o pname pi >> peek pi--printProgramLog :: GLuint -> IO ()-printProgramLog o = do- i <- glGetProgramiv1 gl_INFO_LOG_LENGTH o- when (i > 0) $- alloca $ \sizePtr -> allocaArray (fromIntegral i) $! \ps -> do- glGetProgramInfoLog o (fromIntegral i) sizePtr ps- size <- peek sizePtr- log <- SB.packCStringLen (castPtr ps, fromIntegral size)- SB.putStrLn log--compileShader :: GLuint -> [ByteString] -> IO ()-compileShader o srcl = withMany SB.useAsCString srcl $! \l -> withArray l $! \p -> do- glShaderSource o (fromIntegral $! length srcl) (castPtr p) nullPtr- glCompileShader o- printShaderLog o- status <- glGetShaderiv1 gl_COMPILE_STATUS o- when (status /= fromIntegral gl_TRUE) $ fail "compileShader failed!"--checkGL :: IO ByteString-checkGL = do- let f e | e == gl_INVALID_ENUM = "INVALID_ENUM"- | e == gl_INVALID_VALUE = "INVALID_VALUE"- | e == gl_INVALID_OPERATION = "INVALID_OPERATION"- | e == gl_INVALID_FRAMEBUFFER_OPERATION = "INVALID_FRAMEBUFFER_OPERATION"- | e == gl_OUT_OF_MEMORY = "OUT_OF_MEMORY"- | e == gl_NO_ERROR = "OK"- | otherwise = "Unknown error"- e <- glGetError- return $ f e--streamToInputType :: Stream Buffer -> InputType-streamToInputType (ConstWord _) = Word-streamToInputType (ConstV2U _) = V2U-streamToInputType (ConstV3U _) = V3U-streamToInputType (ConstV4U _) = V4U-streamToInputType (ConstInt _) = Int-streamToInputType (ConstV2I _) = V2I-streamToInputType (ConstV3I _) = V3I-streamToInputType (ConstV4I _) = V4I-streamToInputType (ConstFloat _) = Float-streamToInputType (ConstV2F _) = V2F-streamToInputType (ConstV3F _) = V3F-streamToInputType (ConstV4F _) = V4F-streamToInputType (ConstM22F _) = M22F-streamToInputType (ConstM23F _) = M23F-streamToInputType (ConstM24F _) = M24F-streamToInputType (ConstM32F _) = M32F-streamToInputType (ConstM33F _) = M33F-streamToInputType (ConstM34F _) = M34F-streamToInputType (ConstM42F _) = M42F-streamToInputType (ConstM43F _) = M43F-streamToInputType (ConstM44F _) = M44F-streamToInputType (Stream t (Buffer a _) i _ _)- | 0 <= i && i < V.length a &&- if elem t integralTypes then elem at integralArrTypes else True- = fromStreamType t- | otherwise = throw $ userError "streamToInputType failed"- where- at = arrType $! (a V.! i)- integralTypes = [TWord, TV2U, TV3U, TV4U, TInt, TV2I, TV3I, TV4I]- integralArrTypes = [ArrWord8, ArrWord16, ArrWord32, ArrInt8, ArrInt16, ArrInt32]--comparisonFunctionToGLType :: ComparisonFunction -> GLenum-comparisonFunctionToGLType Always = gl_ALWAYS-comparisonFunctionToGLType Equal = gl_EQUAL-comparisonFunctionToGLType Gequal = gl_GEQUAL-comparisonFunctionToGLType Greater = gl_GREATER-comparisonFunctionToGLType Lequal = gl_LEQUAL-comparisonFunctionToGLType Less = gl_LESS-comparisonFunctionToGLType Never = gl_NEVER-comparisonFunctionToGLType Notequal = gl_NOTEQUAL--logicOperationToGLType :: LogicOperation -> GLenum-logicOperationToGLType And = gl_AND-logicOperationToGLType AndInverted = gl_AND_INVERTED-logicOperationToGLType AndReverse = gl_AND_REVERSE-logicOperationToGLType Clear = gl_CLEAR-logicOperationToGLType Copy = gl_COPY-logicOperationToGLType CopyInverted = gl_COPY_INVERTED-logicOperationToGLType Equiv = gl_EQUIV-logicOperationToGLType Invert = gl_INVERT-logicOperationToGLType Nand = gl_NAND-logicOperationToGLType Noop = gl_NOOP-logicOperationToGLType Nor = gl_NOR-logicOperationToGLType Or = gl_OR-logicOperationToGLType OrInverted = gl_OR_INVERTED-logicOperationToGLType OrReverse = gl_OR_REVERSE-logicOperationToGLType Set = gl_SET-logicOperationToGLType Xor = gl_XOR--blendEquationToGLType :: BlendEquation -> GLenum-blendEquationToGLType FuncAdd = gl_FUNC_ADD-blendEquationToGLType FuncReverseSubtract = gl_FUNC_REVERSE_SUBTRACT-blendEquationToGLType FuncSubtract = gl_FUNC_SUBTRACT-blendEquationToGLType Max = gl_MAX-blendEquationToGLType Min = gl_MIN--blendingFactorToGLType :: BlendingFactor -> GLenum-blendingFactorToGLType ConstantAlpha = gl_CONSTANT_ALPHA-blendingFactorToGLType ConstantColor = gl_CONSTANT_COLOR-blendingFactorToGLType DstAlpha = gl_DST_ALPHA-blendingFactorToGLType DstColor = gl_DST_COLOR-blendingFactorToGLType One = gl_ONE-blendingFactorToGLType OneMinusConstantAlpha = gl_ONE_MINUS_CONSTANT_ALPHA-blendingFactorToGLType OneMinusConstantColor = gl_ONE_MINUS_CONSTANT_COLOR-blendingFactorToGLType OneMinusDstAlpha = gl_ONE_MINUS_DST_ALPHA-blendingFactorToGLType OneMinusDstColor = gl_ONE_MINUS_DST_COLOR-blendingFactorToGLType OneMinusSrcAlpha = gl_ONE_MINUS_SRC_ALPHA-blendingFactorToGLType OneMinusSrcColor = gl_ONE_MINUS_SRC_COLOR-blendingFactorToGLType SrcAlpha = gl_SRC_ALPHA-blendingFactorToGLType SrcAlphaSaturate = gl_SRC_ALPHA_SATURATE-blendingFactorToGLType SrcColor = gl_SRC_COLOR-blendingFactorToGLType Zero = gl_ZERO--{--data ColorArity = Red | RG | RGB | RGBA deriving (Show,Eq,Ord)-data TextureDataType- = FloatT ColorArity- | IntT ColorArity- | WordT ColorArity- | ShadowT- deriving (Show, Eq, Ord)--}-textureDataTypeToGLType :: TextureDataType -> GLenum-textureDataTypeToGLType (FloatT Red) = gl_R32F-textureDataTypeToGLType (IntT Red) = gl_R32I-textureDataTypeToGLType (WordT Red) = gl_R32UI-textureDataTypeToGLType (FloatT RG) = gl_RG32F-textureDataTypeToGLType (IntT RG) = gl_RG32I-textureDataTypeToGLType (WordT RG) = gl_RG32UI-textureDataTypeToGLType (FloatT RGB) = gl_RGB32F-textureDataTypeToGLType (IntT RGB) = gl_RGB32I-textureDataTypeToGLType (WordT RGB) = gl_RGB32UI-textureDataTypeToGLType (FloatT RGBA) = gl_RGBA32F-textureDataTypeToGLType (IntT RGBA) = gl_RGBA32I-textureDataTypeToGLType (WordT RGBA) = gl_RGBA32UI-textureDataTypeToGLType a = error $ "FIXME: This texture format is not yet supported " ++ show a--textureDataTypeToGLArityType :: TextureDataType -> GLenum-textureDataTypeToGLArityType (FloatT Red) = gl_RED-textureDataTypeToGLArityType (IntT Red) = gl_RED-textureDataTypeToGLArityType (WordT Red) = gl_RED-textureDataTypeToGLArityType (FloatT RG) = gl_RG-textureDataTypeToGLArityType (IntT RG) = gl_RG-textureDataTypeToGLArityType (WordT RG) = gl_RG-textureDataTypeToGLArityType (FloatT RGB) = gl_RGB-textureDataTypeToGLArityType (IntT RGB) = gl_RGB-textureDataTypeToGLArityType (WordT RGB) = gl_RGB-textureDataTypeToGLArityType (FloatT RGBA) = gl_RGBA-textureDataTypeToGLArityType (IntT RGBA) = gl_RGBA-textureDataTypeToGLArityType (WordT RGBA) = gl_RGBA-textureDataTypeToGLArityType a = error $ "FIXME: This texture format is not yet supported " ++ show a-{--Texture and renderbuffer color formats (R):- R11F_G11F_B10F- R16- R16F- R16I- R16UI- R32F- R32I- R32UI- R8- R8I- R8UI- RG16- RG16F- RG16I- RG16UI- RG32F- RG32I- RG32UI- RG8- RG8I- RG8UI- RGB10_A2- RGB10_A2UI- RGBA16- RGBA16F- RGBA16I- RGBA16UI- RGBA32F- RGBA32I- RGBA32UI- RGBA8- RGBA8I- RGBA8UI- SRGB8_ALPHA8--}--glGetIntegerv1 :: GLenum -> IO GLint-glGetIntegerv1 e = alloca $ \pi -> glGetIntegerv e pi >> peek pi--checkFBO :: IO ByteString-checkFBO = do- let f e | e == gl_FRAMEBUFFER_UNDEFINED = "FRAMEBUFFER_UNDEFINED"- | e == gl_FRAMEBUFFER_INCOMPLETE_ATTACHMENT = "FRAMEBUFFER_INCOMPLETE_ATTACHMENT"- | e == gl_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER = "FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER"- | e == gl_FRAMEBUFFER_INCOMPLETE_READ_BUFFER = "FRAMEBUFFER_INCOMPLETE_READ_BUFFER"- | e == gl_FRAMEBUFFER_UNSUPPORTED = "FRAMEBUFFER_UNSUPPORTED"- | e == gl_FRAMEBUFFER_INCOMPLETE_MULTISAMPLE = "FRAMEBUFFER_INCOMPLETE_MULTISAMPLE"- | e == gl_FRAMEBUFFER_INCOMPLETE_LAYER_TARGETS = "FRAMEBUFFER_INCOMPLETE_LAYER_TARGETS"- | e == gl_FRAMEBUFFER_COMPLETE = "FRAMEBUFFER_COMPLETE"- | otherwise = "Unknown error"- e <- glCheckFramebufferStatus gl_DRAW_FRAMEBUFFER- return $ f e--{--data TextureDataType - gl internal representation- = FloatT ColorArity- | IntT ColorArity- | WordT ColorArity- | ShadowT- deriving (Show, Eq, Ord)--data TextureType - gl texture target- = Texture1D TextureDataType Int- | Texture2D TextureDataType Int- | Texture3D TextureDataType- | TextureCube TextureDataType- | TextureRect TextureDataType- | Texture2DMS TextureDataType Int- | TextureBuffer TextureDataType- deriving (Show, Eq, Ord)--}-createGLTextureObject :: DAG -> Exp -> IO GLuint-createGLTextureObject dag (Sampler txFilter txEdgeMode tx) = do- let Texture txType txSize txMipMap txGPList = toExp dag tx- wrapMode = case txEdgeMode of- Repeat -> gl_REPEAT- MirroredRepeat -> gl_MIRRORED_REPEAT- ClampToEdge -> gl_CLAMP_TO_EDGE- ClampToBorder -> gl_CLAMP_TO_BORDER- filterMode = case txFilter of- PointFilter -> gl_NEAREST- LinearFilter -> gl_LINEAR- to <- alloca $! \pto -> glGenTextures 1 pto >> peek pto- {-- void glTexImage1D( GLenum target, GLint level, GLint internalformat, GLsizei width, GLint border, GLenum format, GLenum type, void *data );- void glTexImage2D( GLenum target, GLint level, GLint internalformat, GLsizei width, GLsizei height, GLint border, GLenum format, GLenum type, void *data );- void glTexImage3D( GLenum target, GLint level, GLint internalformat, GLsizei width, GLsizei height, GLsizei depth, GLint border, GLenum format, GLenum type, void *data );- void glTexImage2DMultisample( GLenum target, GLsizei samples, GLint internalformat, GLsizei width, GLsizei height, GLboolean fixedsamplelocations );- void glTexImage3DMultisample( GLenum target, GLsizei samples, GLint internalformat, GLsizei width, GLsizei height, GLsizei depth, GLboolean fixedsamplelocations );- -}- -- FIXME: for now we support only single 2D texture- case txType of- {-- Texture1D dTy n -> return ()- Texture2D dTy n -> return ()- Texture3D dTy -> return ()- TextureCube dTy -> return ()- TextureRect dTy -> return ()- Texture2DMS dTy n -> return ()- TextureBuffer dTy -> return ()- -}-{-- let (width,height) = bitmapSize bitmap- wrapMode = case isClamped of- True -> gl_CLAMP_TO_EDGE- False -> gl_REPEAT- (minFilter,maxLevel) = case isMip of- False -> (gl_LINEAR,0)- True -> (gl_LINEAR_MIPMAP_LINEAR, floor $ log (fromIntegral $ max width height) / log 2)- glTexParameteri gl_TEXTURE_2D gl_TEXTURE_WRAP_S $ fromIntegral wrapMode- glTexParameteri gl_TEXTURE_2D gl_TEXTURE_WRAP_T $ fromIntegral wrapMode- glTexParameteri gl_TEXTURE_2D gl_TEXTURE_MIN_FILTER $ fromIntegral minFilter- glTexParameteri gl_TEXTURE_2D gl_TEXTURE_MAG_FILTER $ fromIntegral gl_LINEAR- glTexParameteri gl_TEXTURE_2D gl_TEXTURE_BASE_LEVEL 0- glTexParameteri gl_TEXTURE_2D gl_TEXTURE_MAX_LEVEL $ fromIntegral maxLevel- withBitmap bitmap $ \(w,h) nchn 0 ptr -> do- let internalFormat = fromIntegral gl_RGBA8- dataFormat = fromIntegral $ case nchn of- 3 -> gl_RGB- 4 -> gl_RGBA- _ -> error "unsupported texture format!"- glTexImage2D gl_TEXTURE_2D 0 internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat gl_UNSIGNED_BYTE $ castPtr ptr- when isMip $ glGenerateMipmap gl_TEXTURE_2D--}- TextureCube dTy -> if txMipMap /= NoMip then error "FIXME: Only NoMip textures are supported yet!" else - if length txGPList /= 1 then error "Invalid texture source specification!" else do- let internalFormat = fromIntegral $ textureDataTypeToGLType dTy- dataFormat = fromIntegral $ textureDataTypeToGLArityType dTy- VV2U (V2 w h) = txSize- glBindTexture gl_TEXTURE_CUBE_MAP to- glTexParameteri gl_TEXTURE_CUBE_MAP gl_TEXTURE_WRAP_S $ fromIntegral wrapMode- glTexParameteri gl_TEXTURE_CUBE_MAP gl_TEXTURE_WRAP_T $ fromIntegral wrapMode- glTexParameteri gl_TEXTURE_CUBE_MAP gl_TEXTURE_MAG_FILTER $ fromIntegral filterMode- glTexParameteri gl_TEXTURE_CUBE_MAP gl_TEXTURE_MIN_FILTER $ fromIntegral filterMode- glTexParameteri gl_TEXTURE_CUBE_MAP gl_TEXTURE_BASE_LEVEL 0- glTexParameteri gl_TEXTURE_CUBE_MAP gl_TEXTURE_MAX_LEVEL 0- let l = [ gl_TEXTURE_CUBE_MAP_POSITIVE_X - , gl_TEXTURE_CUBE_MAP_NEGATIVE_X- , gl_TEXTURE_CUBE_MAP_POSITIVE_Y- , gl_TEXTURE_CUBE_MAP_NEGATIVE_Y- , gl_TEXTURE_CUBE_MAP_POSITIVE_Z- , gl_TEXTURE_CUBE_MAP_NEGATIVE_Z- ]- forM_ l $ \t -> glTexImage2D t 0 internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat gl_UNSIGNED_BYTE nullPtr-- -- temporary texture support: 2D NoMip Float/Int/Word Red/RG/RGBA- Texture2D dTy layerCnt -> if txMipMap /= NoMip then error "FIXME: Only NoMip textures are supported yet!" else - if length txGPList /= 1 then error "Invalid texture source specification!" else do- let internalFormat = fromIntegral $ textureDataTypeToGLType dTy- dataFormat = fromIntegral $ textureDataTypeToGLArityType dTy- VV2U (V2 w h) = txSize- txTarget = if layerCnt > 1 then gl_TEXTURE_2D_ARRAY else gl_TEXTURE_2D- glBindTexture txTarget to- -- temp- glTexParameteri txTarget gl_TEXTURE_WRAP_S $ fromIntegral wrapMode- glTexParameteri txTarget gl_TEXTURE_WRAP_T $ fromIntegral wrapMode- glTexParameteri txTarget gl_TEXTURE_MAG_FILTER $ fromIntegral filterMode- glTexParameteri txTarget gl_TEXTURE_MIN_FILTER $ fromIntegral filterMode- glTexParameteri txTarget gl_TEXTURE_BASE_LEVEL 0- glTexParameteri txTarget gl_TEXTURE_MAX_LEVEL 0- -- temp end- case layerCnt > 1 of- True -> glTexImage3D gl_TEXTURE_2D_ARRAY 0 internalFormat (fromIntegral w) (fromIntegral h) (fromIntegral layerCnt) 0 dataFormat gl_UNSIGNED_BYTE nullPtr- False -> glTexImage2D gl_TEXTURE_2D 0 internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat gl_UNSIGNED_BYTE nullPtr- return ()- _ -> error $ "FIXME: This texture format is not yet supported: " ++ show txType- return to
+ testclient/TestData.hs view
@@ -0,0 +1,242 @@+-- generated file, do not modify!+-- 2016-02-12T16:05:13.383716000000Z++{-# LANGUAGE OverloadedStrings, RecordWildCards #-}+module TestData where++import Data.Int+import Data.Word+import Data.Map+import Data.Vector (Vector(..))+import LambdaCube.Linear++import Data.Text+import Data.Aeson hiding (Value,Bool)+import Data.Aeson.Types hiding (Value,Bool)+import Control.Monad++import LambdaCube.IR+import LambdaCube.Mesh+import LambdaCube.PipelineSchema++data ClientInfo+ = ClientInfo+ { clientName :: String+ , clientBackend :: Backend+ }++ deriving (Show, Eq, Ord)++data Frame+ = Frame+ { renderCount :: Int+ , frameUniforms :: Map String Value+ , frameTextures :: Map String Int+ }++ deriving (Show, Eq, Ord)++data Scene+ = Scene+ { objectArrays :: Map String (Vector Int)+ , renderTargetWidth :: Int+ , renderTargetHeight :: Int+ , frames :: Vector Frame+ }++ deriving (Show, Eq, Ord)++data PipelineInfo+ = PipelineInfo+ { pipelineName :: String+ , pipeline :: Pipeline+ }++ deriving (Show, Eq, Ord)++data RenderJob+ = RenderJob+ { meshes :: Vector Mesh+ , textures :: Vector String+ , schema :: PipelineSchema+ , scenes :: Vector Scene+ , pipelines :: Vector PipelineInfo+ }++ deriving (Show, Eq, Ord)++data FrameResult+ = FrameResult+ { frRenderTimes :: Vector Float+ , frImageWidth :: Int+ , frImageHeight :: Int+ }++ deriving (Show, Eq, Ord)++data RenderJobResult+ = RenderJobResult FrameResult+ | RenderJobError String+ deriving (Show, Eq, Ord)+++instance ToJSON ClientInfo where+ toJSON v = case v of+ ClientInfo{..} -> object+ [ "tag" .= ("ClientInfo" :: Text)+ , "clientName" .= clientName+ , "clientBackend" .= clientBackend+ ]++instance FromJSON ClientInfo where+ parseJSON (Object obj) = do+ tag <- obj .: "tag"+ case tag :: Text of+ "ClientInfo" -> do+ clientName <- obj .: "clientName"+ clientBackend <- obj .: "clientBackend"+ pure $ ClientInfo+ { clientName = clientName+ , clientBackend = clientBackend+ } + parseJSON _ = mzero++instance ToJSON Frame where+ toJSON v = case v of+ Frame{..} -> object+ [ "tag" .= ("Frame" :: Text)+ , "renderCount" .= renderCount+ , "frameUniforms" .= frameUniforms+ , "frameTextures" .= frameTextures+ ]++instance FromJSON Frame where+ parseJSON (Object obj) = do+ tag <- obj .: "tag"+ case tag :: Text of+ "Frame" -> do+ renderCount <- obj .: "renderCount"+ frameUniforms <- obj .: "frameUniforms"+ frameTextures <- obj .: "frameTextures"+ pure $ Frame+ { renderCount = renderCount+ , frameUniforms = frameUniforms+ , frameTextures = frameTextures+ } + parseJSON _ = mzero++instance ToJSON Scene where+ toJSON v = case v of+ Scene{..} -> object+ [ "tag" .= ("Scene" :: Text)+ , "objectArrays" .= objectArrays+ , "renderTargetWidth" .= renderTargetWidth+ , "renderTargetHeight" .= renderTargetHeight+ , "frames" .= frames+ ]++instance FromJSON Scene where+ parseJSON (Object obj) = do+ tag <- obj .: "tag"+ case tag :: Text of+ "Scene" -> do+ objectArrays <- obj .: "objectArrays"+ renderTargetWidth <- obj .: "renderTargetWidth"+ renderTargetHeight <- obj .: "renderTargetHeight"+ frames <- obj .: "frames"+ pure $ Scene+ { objectArrays = objectArrays+ , renderTargetWidth = renderTargetWidth+ , renderTargetHeight = renderTargetHeight+ , frames = frames+ } + parseJSON _ = mzero++instance ToJSON PipelineInfo where+ toJSON v = case v of+ PipelineInfo{..} -> object+ [ "tag" .= ("PipelineInfo" :: Text)+ , "pipelineName" .= pipelineName+ , "pipeline" .= pipeline+ ]++instance FromJSON PipelineInfo where+ parseJSON (Object obj) = do+ tag <- obj .: "tag"+ case tag :: Text of+ "PipelineInfo" -> do+ pipelineName <- obj .: "pipelineName"+ pipeline <- obj .: "pipeline"+ pure $ PipelineInfo+ { pipelineName = pipelineName+ , pipeline = pipeline+ } + parseJSON _ = mzero++instance ToJSON RenderJob where+ toJSON v = case v of+ RenderJob{..} -> object+ [ "tag" .= ("RenderJob" :: Text)+ , "meshes" .= meshes+ , "textures" .= textures+ , "schema" .= schema+ , "scenes" .= scenes+ , "pipelines" .= pipelines+ ]++instance FromJSON RenderJob where+ parseJSON (Object obj) = do+ tag <- obj .: "tag"+ case tag :: Text of+ "RenderJob" -> do+ meshes <- obj .: "meshes"+ textures <- obj .: "textures"+ schema <- obj .: "schema"+ scenes <- obj .: "scenes"+ pipelines <- obj .: "pipelines"+ pure $ RenderJob+ { meshes = meshes+ , textures = textures+ , schema = schema+ , scenes = scenes+ , pipelines = pipelines+ } + parseJSON _ = mzero++instance ToJSON FrameResult where+ toJSON v = case v of+ FrameResult{..} -> object+ [ "tag" .= ("FrameResult" :: Text)+ , "frRenderTimes" .= frRenderTimes+ , "frImageWidth" .= frImageWidth+ , "frImageHeight" .= frImageHeight+ ]++instance FromJSON FrameResult where+ parseJSON (Object obj) = do+ tag <- obj .: "tag"+ case tag :: Text of+ "FrameResult" -> do+ frRenderTimes <- obj .: "frRenderTimes"+ frImageWidth <- obj .: "frImageWidth"+ frImageHeight <- obj .: "frImageHeight"+ pure $ FrameResult+ { frRenderTimes = frRenderTimes+ , frImageWidth = frImageWidth+ , frImageHeight = frImageHeight+ } + parseJSON _ = mzero++instance ToJSON RenderJobResult where+ toJSON v = case v of+ RenderJobResult arg0 -> object [ "tag" .= ("RenderJobResult" :: Text), "arg0" .= arg0]+ RenderJobError arg0 -> object [ "tag" .= ("RenderJobError" :: Text), "arg0" .= arg0]++instance FromJSON RenderJobResult where+ parseJSON (Object obj) = do+ tag <- obj .: "tag"+ case tag :: Text of+ "RenderJobResult" -> RenderJobResult <$> obj .: "arg0"+ "RenderJobError" -> RenderJobError <$> obj .: "arg0"+ parseJSON _ = mzero+
+ testclient/client.hs view
@@ -0,0 +1,191 @@+{-# LANGUAGE PackageImports, LambdaCase, OverloadedStrings, RecordWildCards #-}++import Control.Concurrent+import Control.Concurrent.MVar+import Control.Monad+import Control.Monad.Catch+import Data.Text (Text)+import Data.Vector (Vector,(!))+import Data.ByteString.Char8 (unpack,pack)+import qualified Data.ByteString as SB+import qualified Data.Vector as V+import qualified Data.Map as Map+import qualified Data.ByteString.Base64 as B64++import System.Exit+import Data.Time.Clock+import Data.Aeson+import Foreign++import qualified Network.WebSockets as WS+import Network.Socket++import "GLFW-b" Graphics.UI.GLFW as GLFW+import "OpenGLRaw" Graphics.GL.Core33+import Codec.Picture as Juicy++import LambdaCube.IR+import LambdaCube.PipelineSchema+import LambdaCube.Mesh+import LambdaCube.GL+import LambdaCube.GL.Mesh+import TestData++main = do+ win <- initWindow "LambdaCube 3D OpenGL 3.3 Backend" 256 256++ GLFW.setWindowCloseCallback win $ Just $ \_ -> do+ GLFW.destroyWindow win+ GLFW.terminate+ exitSuccess++ -- connect to the test server+ forever $ catchAll (setupConnection win) $ \_ -> do+ GLFW.pollEvents+ threadDelay 100000++setupConnection win = withSocketsDo $ WS.runClient "192.168.0.12" 9160 "/" $ \conn -> catchAll (execConnection win conn) $ \e -> do+ WS.sendTextData conn . encode $ RenderJobError $ displayException e++execConnection win conn = do+ putStrLn "Connected!"+ -- register backend+ WS.sendTextData conn . encode $ ClientInfo+ { clientName = "Haskell OpenGL 3.3"+ , clientBackend = OpenGL33+ }+ chan <- newEmptyMVar :: IO (MVar RenderJob)+ -- wait for incoming render jobs+ _ <- forkIO $ forever $ do+ -- get the pipeline from the server+ decodeStrict <$> WS.receiveData conn >>= \case+ Nothing -> putStrLn "unknown message"+ Just renderJob -> putMVar chan renderJob+ -- process render jobs+ forever $ do+ tryTakeMVar chan >>= \case+ Nothing -> return ()+ Just rj -> processRenderJob win conn rj+ WS.sendPing conn ("hello" :: Text)+ GLFW.pollEvents+ threadDelay 100000+ putStrLn "disconnected"+ WS.sendClose conn ("Bye!" :: Text)++doAfter = flip (>>)++processRenderJob win conn renderJob@RenderJob{..} = do+ putStrLn "got render job"+ gpuData@GPUData{..} <- allocateGPUData renderJob+ -- foreach pipeline+ doAfter (disposeGPUData gpuData) $ forM_ pipelines $ \PipelineInfo{..} -> do+ putStrLn $ "use pipeline: " ++ pipelineName+ renderer <- allocRenderer pipeline+ -- foreach scene+ doAfter (disposeRenderer renderer) $ forM_ scenes $ \Scene{..} -> do+ storage <- allocStorage schema+ -- add objects+ forM_ (Map.toList objectArrays) $ \(name,objs) -> forM_ objs $ addMeshToObjectArray storage name [] . (gpuMeshes !)+ -- set render target size+ GLFW.setWindowSize win renderTargetWidth renderTargetHeight+ setScreenSize storage (fromIntegral renderTargetWidth) (fromIntegral renderTargetHeight)+ -- connect renderer with storage+ doAfter (disposeStorage storage) $ setStorage renderer storage >>= \case+ Just err -> putStrLn err+ Nothing -> do+ -- foreach frame+ forM_ frames $ \Frame{..} -> do+ -- setup uniforms+ updateUniforms storage $ do+ forM_ (Map.toList frameTextures) $ \(name,tex) -> pack name @= return (gpuTextures ! tex)+ forM_ (Map.toList frameUniforms) $ uncurry setUniformValue+ -- rendering+ renderTimes <- V.replicateM renderCount . timeDiff $ do+ renderFrame renderer+ GLFW.swapBuffers win+ GLFW.pollEvents+ -- send render job result to server+ WS.sendTextData conn . encode . RenderJobResult $ FrameResult+ { frRenderTimes = renderTimes+ , frImageWidth = renderTargetWidth+ , frImageHeight = renderTargetHeight+ }+ -- send the last render result using Base64 encoding+ WS.sendBinaryData conn . B64.encode =<< getFrameBuffer renderTargetWidth renderTargetHeight++-- utility code++initWindow :: String -> Int -> Int -> IO Window+initWindow title width height = do+ GLFW.init+ GLFW.defaultWindowHints+ mapM_ GLFW.windowHint+ [ WindowHint'ContextVersionMajor 3+ , WindowHint'ContextVersionMinor 3+ , WindowHint'OpenGLProfile OpenGLProfile'Core+ , WindowHint'OpenGLForwardCompat True+ ]+ Just win <- GLFW.createWindow width height title Nothing Nothing+ GLFW.makeContextCurrent $ Just win+ return win++getFrameBuffer w h = do+ glFinish+ glBindFramebuffer GL_READ_FRAMEBUFFER 0+ glReadBuffer GL_FRONT_LEFT+ glBlitFramebuffer 0 0 (fromIntegral w) (fromIntegral h) 0 (fromIntegral h) (fromIntegral w) 0 GL_COLOR_BUFFER_BIT GL_NEAREST+ glReadBuffer GL_BACK_LEFT+ withFrameBuffer 0 0 w h $ \p -> SB.packCStringLen (castPtr p,w*h*4)++withFrameBuffer :: Int -> Int -> Int -> Int -> (Ptr Word8 -> IO a) -> IO a+withFrameBuffer x y w h fn = allocaBytes (w*h*4) $ \p -> do+ glPixelStorei GL_UNPACK_LSB_FIRST 0+ glPixelStorei GL_UNPACK_SWAP_BYTES 0+ glPixelStorei GL_UNPACK_ROW_LENGTH 0+ glPixelStorei GL_UNPACK_IMAGE_HEIGHT 0+ glPixelStorei GL_UNPACK_SKIP_ROWS 0+ glPixelStorei GL_UNPACK_SKIP_PIXELS 0+ glPixelStorei GL_UNPACK_SKIP_IMAGES 0+ glPixelStorei GL_UNPACK_ALIGNMENT 1 -- normally 4!+ glReadPixels (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h) GL_RGBA GL_UNSIGNED_BYTE $ castPtr p+ fn p++data GPUData+ = GPUData+ { gpuTextures :: Vector TextureData+ , gpuMeshes :: Vector GPUMesh+ }++allocateGPUData RenderJob{..} = GPUData <$> mapM uploadTex2D textures <*> mapM uploadMeshToGPU meshes+ where uploadTex2D = uploadTexture2DToGPU . either error id . decodeImage . either error id . B64.decode . pack++disposeGPUData GPUData{..} = mapM_ disposeTexture gpuTextures >> mapM_ disposeMesh gpuMeshes++timeDiff m = (\s e -> realToFrac $ diffUTCTime e s) <$> getCurrentTime <* m <*> getCurrentTime++setUniformValue name = \case+ VBool v -> pack name @= return v+ VV2B v -> pack name @= return v+ VV3B v -> pack name @= return v+ VV4B v -> pack name @= return v+ VWord v -> pack name @= return v+ VV2U v -> pack name @= return v+ VV3U v -> pack name @= return v+ VV4U v -> pack name @= return v+ VInt v -> pack name @= return v+ VV2I v -> pack name @= return v+ VV3I v -> pack name @= return v+ VV4I v -> pack name @= return v+ VFloat v -> pack name @= return v+ VV2F v -> pack name @= return v+ VV3F v -> pack name @= return v+ VV4F v -> pack name @= return v+ VM22F v -> pack name @= return v+ VM23F v -> pack name @= return v+ VM24F v -> pack name @= return v+ VM32F v -> pack name @= return v+ VM33F v -> pack name @= return v+ VM34F v -> pack name @= return v+ VM42F v -> pack name @= return v+ VM43F v -> pack name @= return v+ VM44F v -> pack name @= return v