diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. diff --git a/examples/Hello.hs b/examples/Hello.hs new file mode 100644 --- /dev/null +++ b/examples/Hello.hs @@ -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 diff --git a/examples/HelloEmbedded.hs b/examples/HelloEmbedded.hs new file mode 100644 --- /dev/null +++ b/examples/HelloEmbedded.hs @@ -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 diff --git a/examples/HelloOBJ.hs b/examples/HelloOBJ.hs new file mode 100644 --- /dev/null +++ b/examples/HelloOBJ.hs @@ -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 diff --git a/examples/MtlParser.hs b/examples/MtlParser.hs new file mode 100644 --- /dev/null +++ b/examples/MtlParser.hs @@ -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 diff --git a/examples/cube.mtl b/examples/cube.mtl new file mode 100644 --- /dev/null +++ b/examples/cube.mtl @@ -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 diff --git a/examples/cube.obj b/examples/cube.obj new file mode 100644 --- /dev/null +++ b/examples/cube.obj @@ -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 diff --git a/examples/hello.json b/examples/hello.json new file mode 100644 --- /dev/null +++ b/examples/hello.json @@ -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"} diff --git a/examples/hello.lc b/examples/hello.lc new file mode 100644 --- /dev/null +++ b/examples/hello.lc @@ -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")) diff --git a/examples/hello_obj.json b/examples/hello_obj.json new file mode 100644 --- /dev/null +++ b/examples/hello_obj.json @@ -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"} diff --git a/examples/hello_obj.lc b/examples/hello_obj.lc new file mode 100644 --- /dev/null +++ b/examples/hello_obj.lc @@ -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")) diff --git a/examples/logo.png b/examples/logo.png new file mode 100644 Binary files /dev/null and b/examples/logo.png differ diff --git a/lambdacube-gl.cabal b/lambdacube-gl.cabal --- a/lambdacube-gl.cabal +++ b/lambdacube-gl.cabal @@ -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 - 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.* diff --git a/src/LambdaCube/GL.hs b/src/LambdaCube/GL.hs new file mode 100644 --- /dev/null +++ b/src/LambdaCube/GL.hs @@ -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 diff --git a/src/LambdaCube/GL/Backend.hs b/src/LambdaCube/GL/Backend.hs new file mode 100644 --- /dev/null +++ b/src/LambdaCube/GL/Backend.hs @@ -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) +-} diff --git a/src/LambdaCube/GL/Data.hs b/src/LambdaCube/GL/Data.hs new file mode 100644 --- /dev/null +++ b/src/LambdaCube/GL/Data.hs @@ -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 diff --git a/src/LambdaCube/GL/Input.hs b/src/LambdaCube/GL/Input.hs new file mode 100644 --- /dev/null +++ b/src/LambdaCube/GL/Input.hs @@ -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 diff --git a/src/LambdaCube/GL/Mesh.hs b/src/LambdaCube/GL/Mesh.hs new file mode 100644 --- /dev/null +++ b/src/LambdaCube/GL/Mesh.hs @@ -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 diff --git a/src/LambdaCube/GL/Type.hs b/src/LambdaCube/GL/Type.hs new file mode 100644 --- /dev/null +++ b/src/LambdaCube/GL/Type.hs @@ -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 diff --git a/src/LambdaCube/GL/Util.hs b/src/LambdaCube/GL/Util.hs new file mode 100644 --- /dev/null +++ b/src/LambdaCube/GL/Util.hs @@ -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)!" diff --git a/src/lib/LambdaCube/GL.hs b/src/lib/LambdaCube/GL.hs deleted file mode 100644 --- a/src/lib/LambdaCube/GL.hs +++ /dev/null @@ -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" diff --git a/src/lib/LambdaCube/GL/Backend.hs b/src/lib/LambdaCube/GL/Backend.hs deleted file mode 100644 --- a/src/lib/LambdaCube/GL/Backend.hs +++ /dev/null @@ -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 - } diff --git a/src/lib/LambdaCube/GL/Compile.hs b/src/lib/LambdaCube/GL/Compile.hs deleted file mode 100644 --- a/src/lib/LambdaCube/GL/Compile.hs +++ /dev/null @@ -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 () diff --git a/src/lib/LambdaCube/GL/Data.hs b/src/lib/LambdaCube/GL/Data.hs deleted file mode 100644 --- a/src/lib/LambdaCube/GL/Data.hs +++ /dev/null @@ -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 () diff --git a/src/lib/LambdaCube/GL/GLSLCodeGen.hs b/src/lib/LambdaCube/GL/GLSLCodeGen.hs deleted file mode 100644 --- a/src/lib/LambdaCube/GL/GLSLCodeGen.hs +++ /dev/null @@ -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 diff --git a/src/lib/LambdaCube/GL/Mesh.hs b/src/lib/LambdaCube/GL/Mesh.hs deleted file mode 100644 --- a/src/lib/LambdaCube/GL/Mesh.hs +++ /dev/null @@ -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 diff --git a/src/lib/LambdaCube/GL/Type.hs b/src/lib/LambdaCube/GL/Type.hs deleted file mode 100644 --- a/src/lib/LambdaCube/GL/Type.hs +++ /dev/null @@ -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 - } diff --git a/src/lib/LambdaCube/GL/Util.hs b/src/lib/LambdaCube/GL/Util.hs deleted file mode 100644 --- a/src/lib/LambdaCube/GL/Util.hs +++ /dev/null @@ -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 diff --git a/testclient/TestData.hs b/testclient/TestData.hs new file mode 100644 --- /dev/null +++ b/testclient/TestData.hs @@ -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 + diff --git a/testclient/client.hs b/testclient/client.hs new file mode 100644 --- /dev/null +++ b/testclient/client.hs @@ -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