├── examples ├── logo.png ├── README ├── cube.mtl ├── hello.lc ├── pickIntDraw.lc ├── pickInt.lc ├── hello_obj.lc ├── cube.obj ├── pickIntDraw.json ├── hello.json ├── MtlParser.hs ├── pickInt.json ├── Hello.hs ├── HelloEmbedded.hs ├── hello_obj.json ├── HelloOBJ.hs └── pickInt.hs ├── .gitignore ├── stack.yaml ├── CHANGELOG.md ├── README.md ├── LICENSE ├── src └── LambdaCube │ ├── GL.hs │ └── GL │ ├── Data.hs │ ├── Mesh.hs │ ├── Type.hs │ ├── Input.hs │ ├── Util.hs │ └── Backend.hs ├── lambdacube-gl.cabal └── testclient ├── TestData.hs └── client.hs /examples/logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lambdacube3d/lambdacube-gl/HEAD/examples/logo.png -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | dist 3 | dist-newstyle 4 | *.hi 5 | *.o 6 | .stack-work 7 | .ghc.environment.* 8 | -------------------------------------------------------------------------------- /examples/README: -------------------------------------------------------------------------------- 1 | see: 2 | http://lambdacube3d.com/getting-started 3 | 4 | requirements: 5 | lambdacube-gl 6 | GLFW-b 7 | 8 | cabal install lambdacube-gl GLFW-b 9 | 10 | compile and run: 11 | ghc Hello 12 | ./Hello 13 | -------------------------------------------------------------------------------- /examples/cube.mtl: -------------------------------------------------------------------------------- 1 | newmtl material0 2 | Ns 10.0000 3 | Ni 1.5000 4 | d 1.0000 5 | Tr 0.0000 6 | Tf 1.0000 1.0000 1.0000 7 | illum 2 8 | Ka 0.0000 0.0000 0.0000 9 | Kd 0.5880 0.5880 0.5880 10 | Ks 0.0000 0.0000 0.0000 11 | Ke 0.0000 0.0000 0.0000 12 | map_Ka logo.png 13 | map_Kd logo.png 14 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-10.4 2 | packages: 3 | - '.' 4 | 5 | extra-deps: 6 | - wavefront-0.7.1.1 7 | - vect-0.4.7 8 | - github: lambdacube3d/lambdacube-ir 9 | commit: 8a0a17abedc9d6b46b41d744c1a2be53efa6336b 10 | subdirs: 11 | - lambdacube-ir.haskell 12 | 13 | flags: 14 | lambdacube-gl: 15 | example: true 16 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # 0.5.2.5 2 | 3 | - Fix space leak, as per #11 4 | 5 | # 0.5.2.4 6 | 7 | - disable warnings for unused uniforms updates 8 | 9 | # 0.5.2.3 10 | 11 | - fix: [Render to texture is broken](https://github.com/lambdacube3d/lambdacube-gl/issues/5) 12 | 13 | 14 | # 0.5.2.2 15 | 16 | - update time version constraint 17 | 18 | 19 | # 0.5.2.0 20 | 21 | - minor optimization: less draw calls by grouping and state tracking 22 | - expose `sortSlotObjects` to control the object's render order 23 | 24 | 25 | # 0.5.1.2 26 | 27 | - relax base version constraint: >=4.7 && <5 28 | -------------------------------------------------------------------------------- /examples/hello.lc: -------------------------------------------------------------------------------- 1 | makeFrame (time :: Float) 2 | (texture :: Texture) 3 | (prims :: PrimitiveStream Triangle (Vec 2 Float, Vec 2 Float)) 4 | 5 | = imageFrame ((emptyColorImage (V4 0 0 0.4 1))) 6 | `overlay` 7 | prims 8 | & mapPrimitives (\(p,uv) -> (rotMatrixZ time *. (V4 p%x p%y (-1) 1), uv)) 9 | & rasterizePrimitives (TriangleCtx CullNone PolygonFill NoOffset LastVertex) ((Smooth)) 10 | & mapFragments (\((uv)) -> ((texture2D (Sampler PointFilter MirroredRepeat texture) uv))) 11 | & accumulateWith ((ColorOp NoBlending (V4 True True True True))) 12 | 13 | main = renderFrame $ 14 | makeFrame (Uniform "time") 15 | (Texture2DSlot "diffuseTexture") 16 | (fetch "objects" (Attribute "position", Attribute "uv")) 17 | -------------------------------------------------------------------------------- /examples/pickIntDraw.lc: -------------------------------------------------------------------------------- 1 | type FB = FrameBuffer 1 '[ 'Color (Vec 4 Float)] 2 | 3 | scene :: String -> FB -> FB 4 | scene name prevFB = 5 | Accumulate ((ColorOp NoBlending (one :: Vec 4 Bool))) 6 | (mapFragments (\(uv, rgba) -> ((rgba))) 7 | $ rasterizePrimitives (TriangleCtx CullFront PolygonFill NoOffset LastVertex) (Flat, Flat) 8 | $ mapPrimitives 9 | (\(pos, color, id)-> 10 | ( (Uniform "viewProj" :: Mat 4 4 Float) *. (V4 pos%x pos%y 0 1) 11 | , V2 0.0 0.0 12 | , color)) 13 | $ fetch name ( Attribute "position" :: Vec 3 Float 14 | , Attribute "color" :: Vec 4 Float 15 | , Attribute "id" :: Int)) 16 | prevFB 17 | 18 | main :: Output 19 | main = ScreenOut $ 20 | scene "objects" $ 21 | FrameBuffer ((colorImage1 (V4 0 0 0 0))) 22 | -------------------------------------------------------------------------------- /examples/pickInt.lc: -------------------------------------------------------------------------------- 1 | type FB = FrameBuffer 1 '[ 'Color (Vec 4 Int)] 2 | 3 | scene :: String -> FB -> FB 4 | scene name prevFB = 5 | Accumulate ((ColorOp NoBlending (one :: Vec 4 Bool))) 6 | (mapFragments (\(uv, rgba) -> ((rgba))) 7 | $ rasterizePrimitives (TriangleCtx CullFront PolygonFill NoOffset LastVertex) (Flat, Flat) 8 | $ mapPrimitives 9 | (\(pos, color, id)-> 10 | ( (Uniform "viewProj" :: Mat 4 4 Float) *. (V4 pos%x pos%y 0 1) 11 | , V2 0.0 0.0 12 | , V4 0 0 0 id)) 13 | $ fetch name ( Attribute "position" :: Vec 3 Float 14 | , Attribute "color" :: Vec 4 Float 15 | , Attribute "id" :: Int)) 16 | prevFB 17 | 18 | main :: Output 19 | main = TextureOut (V2 800 600) $ 20 | scene "objects" $ 21 | FrameBuffer ((colorImage1 (V4 0 0 0 0))) 22 | -------------------------------------------------------------------------------- /examples/hello_obj.lc: -------------------------------------------------------------------------------- 1 | makeFrame (time :: Float) 2 | (color :: Vec 4 Float) 3 | (texture :: Texture) 4 | (prims :: PrimitiveStream Triangle (Vec 4 Float, Vec 3 Float, Vec 3 Float)) 5 | 6 | = imageFrame (emptyDepthImage 1, emptyColorImage (V4 0 0 0.4 1)) 7 | `overlay` 8 | prims 9 | & 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) )) 10 | & rasterizePrimitives (TriangleCtx CullBack PolygonFill NoOffset LastVertex) ((Smooth)) 11 | & mapFragments (\((uv)) -> ((color * texture2D (Sampler PointFilter MirroredRepeat texture) uv ))) 12 | & accumulateWith (DepthOp Less True, ColorOp NoBlending (V4 True True True True)) 13 | 14 | main = renderFrame $ 15 | makeFrame (Uniform "time") 16 | (Uniform "diffuseColor") 17 | (Texture2DSlot "diffuseTexture") 18 | (fetch "objects" (Attribute "position", Attribute "normal", Attribute "uvw")) 19 | -------------------------------------------------------------------------------- /examples/cube.obj: -------------------------------------------------------------------------------- 1 | # cube.obj 2 | # 3 | 4 | o cube 5 | mtllib cube.mtl 6 | 7 | v -0.500000 -0.500000 0.500000 8 | v 0.500000 -0.500000 0.500000 9 | v -0.500000 0.500000 0.500000 10 | v 0.500000 0.500000 0.500000 11 | v -0.500000 0.500000 -0.500000 12 | v 0.500000 0.500000 -0.500000 13 | v -0.500000 -0.500000 -0.500000 14 | v 0.500000 -0.500000 -0.500000 15 | 16 | vt 0.000000 0.000000 17 | vt 1.000000 0.000000 18 | vt 0.000000 1.000000 19 | vt 1.000000 1.000000 20 | 21 | vn 0.000000 0.000000 1.000000 22 | vn 0.000000 1.000000 0.000000 23 | vn 0.000000 0.000000 -1.000000 24 | vn 0.000000 -1.000000 0.000000 25 | vn 1.000000 0.000000 0.000000 26 | vn -1.000000 0.000000 0.000000 27 | 28 | g cube 29 | usemtl material0 30 | s 1 31 | f 1/1/1 2/2/1 3/3/1 32 | f 3/3/1 2/2/1 4/4/1 33 | s 2 34 | f 3/1/2 4/2/2 5/3/2 35 | f 5/3/2 4/2/2 6/4/2 36 | s 3 37 | f 5/4/3 6/3/3 7/2/3 38 | f 7/2/3 6/3/3 8/1/3 39 | s 4 40 | f 7/1/4 8/2/4 1/3/4 41 | f 1/3/4 8/2/4 2/4/4 42 | s 5 43 | f 2/1/5 8/2/5 4/3/5 44 | f 4/3/5 8/2/5 6/4/5 45 | s 6 46 | f 7/1/6 1/2/6 5/3/6 47 | f 5/3/6 1/2/6 3/4/6 48 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # lambdacube-gl 2 | [![Gitter chat](https://badges.gitter.im/lambdacube3d/lambdacube3d.png)](https://gitter.im/LambdaCube-3D/Lobby) 3 | 4 | Haskell OpenGL backend for LambdaCube 3D. 5 | 6 | ## Building instructions 7 | 8 | 0. On **Linux** install the following libraries. 9 | i.e. on Ubuntu: 10 | ``` 11 | sudo apt install libgl1-mesa-dev libxi-dev libxcursor-dev libxinerama-dev libxrandr-dev zlib1g-dev 12 | ``` 13 | For other Linux distributions make sure the corresponing packages are installed. 14 | 15 | *These libraries required for OpenGL development.* 16 | 17 | 1. Install Haskell [Stack](http://www.haskellstack.org) by following it's simple [install manual](https://docs.haskellstack.org/en/stable/README/#how-to-install). 18 | 19 | 2. Checkout the this repository then run the following commands. 20 | ``` 21 | stack setup 22 | stack build 23 | ``` 24 | 3. Run the examples. 25 | ``` 26 | cd examples 27 | stack exec lambdacube-gl-hello 28 | stack exec lambdacube-gl-hello-obj 29 | ``` 30 | 31 | ## Tutorials and Examples 32 | 33 | - [Getting started](http://lambdacube3d.com/getting-started) 34 | - [Workshop material](https://github.com/csabahruska/lambdacube-workshop) 35 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015, Csaba Hruska, Peter Divianszky 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Csaba Hruska, Peter Divianszky nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /examples/pickIntDraw.json: -------------------------------------------------------------------------------- 1 | {"textures":[],"commands":[{"tag":"SetRenderTarget","arg0":0},{"tag":"ClearRenderTarget","arg0":[{"tag":"ClearImage","clearValue":{"tag":"VV4F","arg0":{"w":0,"z":0,"x":0,"y":0}},"imageSemantic":{"tag":"Color"}}]},{"tag":"SetProgram","arg0":0},{"tag":"SetRasterContext","arg0":{"arg3":{"tag":"LastVertex"},"tag":"TriangleCtx","arg0":{"tag":"CullFront","arg0":{"tag":"CCW"}},"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":{"color":{"tag":"V4F"},"id":{"tag":"Int"},"position":{"tag":"V3F"}},"slotName":"objects","slotUniforms":{"viewProj":{"tag":"M44F"}},"slotPrograms":[0]}],"programs":[{"programInTextures":{},"tag":"Program","programOutput":[{"tag":"Parameter","ty":{"tag":"V4F"},"name":"f0"}],"programStreams":{"vi3":{"tag":"Parameter","ty":{"tag":"Int"},"name":"id"},"vi2":{"tag":"Parameter","ty":{"tag":"V4F"},"name":"color"},"vi1":{"tag":"Parameter","ty":{"tag":"V3F"},"name":"position"}},"fragmentShader":"#version 330 core\nvec4 texture2D(sampler2D s,vec2 uv) {\n return texture(s,uv);\n}\nflat in vec2 vo1;\nflat in vec4 vo2;\nout vec4 f0;\nvoid main() {\n f0 = vo2;\n}","vertexShader":"#version 330 core\nvec4 texture2D(sampler2D s,vec2 uv) {\n return texture(s,uv);\n}\nuniform mat4 viewProj;\nin vec3 vi1;\nin vec4 vi2;\nin int vi3;\nflat out vec2 vo1;\nflat out vec4 vo2;\nvoid main() {\n gl_Position = (viewProj) * (vec4 ((vi1).x,(vi1).y,0.0,1.0));\n vo1 = vec2 (0.0,0.0);\n vo2 = vi2;\n}","geometryShader":null,"programUniforms":{"viewProj":{"tag":"M44F"}}}],"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.6.1.0"} -------------------------------------------------------------------------------- /src/LambdaCube/GL.hs: -------------------------------------------------------------------------------- 1 | module LambdaCube.GL ( 2 | -- Schema 3 | module LambdaCube.PipelineSchema, 4 | -- IR 5 | V2(..),V3(..),V4(..), 6 | -- Array, Buffer, Texture 7 | Array(..), 8 | ArrayType(..), 9 | Buffer, 10 | BufferSetter, 11 | IndexStream(..), 12 | Stream(..), 13 | StreamSetter, 14 | FetchPrimitive(..), 15 | InputType(..), 16 | Primitive(..), 17 | SetterFun, 18 | TextureData, 19 | InputSetter(..), 20 | fromStreamType, 21 | sizeOfArrayType, 22 | toStreamType, 23 | compileBuffer, 24 | disposeBuffer, 25 | updateBuffer, 26 | bufferSize, 27 | arraySize, 28 | arrayType, 29 | uploadTexture2DToGPU, 30 | uploadTexture2DToGPU', 31 | disposeTexture, 32 | 33 | -- GL: Renderer, Storage, Object 34 | GLUniformName, 35 | GLRenderer, 36 | GLStorage, 37 | Object, 38 | schema, 39 | schemaFromPipeline, 40 | allocRenderer, 41 | disposeRenderer, 42 | setStorage, 43 | renderFrame, 44 | allocStorage, 45 | disposeStorage, 46 | uniformSetter, 47 | addObject, 48 | removeObject, 49 | enableObject, 50 | setObjectOrder, 51 | objectUniformSetter, 52 | setScreenSize, 53 | sortSlotObjects, 54 | 55 | uniformBool, 56 | uniformV2B, 57 | uniformV3B, 58 | uniformV4B, 59 | 60 | uniformWord, 61 | uniformV2U, 62 | uniformV3U, 63 | uniformV4U, 64 | 65 | uniformInt, 66 | uniformV2I, 67 | uniformV3I, 68 | uniformV4I, 69 | 70 | uniformFloat, 71 | uniformV2F, 72 | uniformV3F, 73 | uniformV4F, 74 | 75 | uniformM22F, 76 | uniformM23F, 77 | uniformM24F, 78 | uniformM32F, 79 | uniformM33F, 80 | uniformM34F, 81 | uniformM42F, 82 | uniformM43F, 83 | uniformM44F, 84 | 85 | uniformFTexture2D, 86 | 87 | -- schema builder utility functions 88 | (@:), 89 | defObjectArray, 90 | defUniforms, 91 | makeSchema, 92 | 93 | (@=), 94 | updateUniforms, 95 | updateObjectUniforms 96 | ) where 97 | 98 | import LambdaCube.GL.Type 99 | import LambdaCube.GL.Backend 100 | import LambdaCube.GL.Data 101 | import LambdaCube.GL.Input 102 | import LambdaCube.IR 103 | import LambdaCube.Linear 104 | import LambdaCube.PipelineSchema 105 | import LambdaCube.PipelineSchemaUtil 106 | -------------------------------------------------------------------------------- /examples/hello.json: -------------------------------------------------------------------------------- 1 | {"textures":[],"commands":[{"tag":"SetRenderTarget","arg0":0},{"tag":"ClearRenderTarget","arg0":[{"tag":"ClearImage","clearValue":{"tag":"VV4F","arg0":{"w":1,"z":0.4,"x":0.0,"y":0.0}},"imageSemantic":{"tag":"Color"}}]},{"tag":"SetProgram","arg0":0},{"tag":"SetSamplerUniform","arg0":"diffuseTexture","arg1":0},{"tag":"SetRasterContext","arg0":{"arg3":{"tag":"LastVertex"},"tag":"TriangleCtx","arg0":{"tag":"CullNone"},"arg1":{"tag":"PolygonFill"},"arg2":{"tag":"NoOffset"}}},{"tag":"SetAccumulationContext","arg0":{"accViewportName":null,"tag":"AccumulationContext","accOperations":[{"tag":"ColorOp","arg0":{"tag":"NoBlending"},"arg1":{"tag":"VV4B","arg0":{"w":true,"z":true,"x":true,"y":true}}}]}},{"tag":"RenderSlot","arg0":0}],"slots":[{"tag":"Slot","slotPrimitive":{"tag":"Triangles"},"slotStreams":{"uv":{"tag":"V2F"},"position":{"tag":"V2F"}},"slotName":"objects","slotUniforms":{"time":{"tag":"Float"},"diffuseTexture":{"tag":"FTexture2D"}},"slotPrograms":[0]}],"programs":[{"programInTextures":{"diffuseTexture":{"tag":"FTexture2D"}},"tag":"Program","programOutput":[{"tag":"Parameter","ty":{"tag":"V4F"},"name":"f0"}],"programStreams":{"vi2":{"tag":"Parameter","ty":{"tag":"V2F"},"name":"uv"},"vi1":{"tag":"Parameter","ty":{"tag":"V2F"},"name":"position"}},"fragmentShader":"#version 330 core\nvec4 texture2D(sampler2D s\n ,vec2 uv) {\n return texture(s,uv);\n}\nuniform sampler2D diffuseTexture;\nsmooth in vec2 vo1;\nout vec4 f0;\nvoid main() {\n f0 = texture2D (diffuseTexture\n ,vo1);\n}","vertexShader":"#version 330 core\nvec4 texture2D(sampler2D s\n ,vec2 uv) {\n return texture(s,uv);\n}\nuniform float time;\nin vec2 vi1;\nin vec2 vi2;\nsmooth out vec2 vo1;\nmat4 rotMatrixZ(float z0) {\n return mat4 (vec4 (cos (z0)\n ,sin (z0)\n ,0.0\n ,0.0)\n ,vec4 ((0.0) - (sin (z0))\n ,cos (z0)\n ,0.0\n ,0.0)\n ,vec4 (0.0,0.0,1.0,0.0)\n ,vec4 (0.0,0.0,0.0,1.0));\n}\nvoid main() {\n gl_Position = (rotMatrixZ\n (time)) * (vec4 ((vi1).x\n ,(vi1).y\n ,-1.0\n ,1.0));\n vo1 = vi2;\n}","geometryShader":null,"programUniforms":{"time":{"tag":"Float"},"diffuseTexture":{"tag":"FTexture2D"}}}],"samplers":[],"tag":"Pipeline","backend":{"tag":"OpenGL33"},"streams":[],"targets":[{"tag":"RenderTarget","renderTargets":[{"tag":"TargetItem","targetSemantic":{"tag":"Color"},"targetRef":{"tag":"Framebuffer","arg0":{"tag":"Color"}}}]}],"info":"generated by lambdacube-compiler 0.5.0.0"} -------------------------------------------------------------------------------- /examples/MtlParser.hs: -------------------------------------------------------------------------------- 1 | module MtlParser 2 | ( ObjMaterial (..) 3 | , MtlLib 4 | , parseMtl 5 | , readMtl 6 | ) where 7 | 8 | import Data.Map (Map) 9 | import qualified Data.Map as Map 10 | import Data.Maybe 11 | import Control.Monad.State.Strict 12 | import Control.Monad.Writer 13 | import Data.Text (pack,Text) 14 | 15 | type Vec3 = (Float,Float,Float) 16 | 17 | type MtlLib = Map Text ObjMaterial 18 | 19 | data ObjMaterial 20 | = ObjMaterial 21 | { mtl_Name :: Text 22 | , mtl_Ka :: Vec3 -- ambient color 23 | , mtl_Kd :: Vec3 -- diffuse color 24 | , mtl_Ks :: Vec3 -- specular color 25 | , mtl_illum :: Int 26 | , mtl_Tr :: Float -- transparency 27 | , mtl_Ns :: Float -- specular exponent 28 | , mtl_map_Kd :: Maybe String -- diffuse texture file name 29 | } 30 | deriving (Eq,Show) 31 | 32 | newMaterial name = ObjMaterial 33 | { mtl_Name = name 34 | , mtl_Ka = (1, 1, 1) 35 | , mtl_Kd = (1, 1, 1) 36 | , mtl_Ks = (0, 0, 0) 37 | , mtl_illum = 1 38 | , mtl_Tr = 1 39 | , mtl_Ns = 0 40 | , mtl_map_Kd = Nothing 41 | } 42 | 43 | type Mtl = WriterT [ObjMaterial] (State (Maybe ObjMaterial)) 44 | 45 | readMaybe :: Read a => String -> Maybe a 46 | readMaybe s = case reads s of 47 | [(val, "")] -> Just val 48 | _ -> Nothing 49 | 50 | readVec3 :: String -> String -> String -> Maybe Vec3 51 | readVec3 r g b = (,,) <$> readMaybe r <*> readMaybe g <*> readMaybe b 52 | 53 | setAttr = modify' . fmap 54 | addMaterial = gets maybeToList >>= tell 55 | 56 | parseLine :: String -> Mtl () 57 | parseLine s = case words $ takeWhile (/='#') s of 58 | ["newmtl",name] -> do 59 | addMaterial 60 | put $ Just $ newMaterial $ pack name 61 | ["map_Kd",textureName] -> setAttr (\s -> s {mtl_map_Kd = Just textureName}) 62 | ["Ka",r,g,b] | Just rgb <- readVec3 r g b -> setAttr (\s -> s {mtl_Ka = rgb}) 63 | ["Kd",r,g,b] | Just rgb <- readVec3 r g b -> setAttr (\s -> s {mtl_Kd = rgb}) 64 | ["Ks",r,g,b] | Just rgb <- readVec3 r g b -> setAttr (\s -> s {mtl_Ks = rgb}) 65 | ["illum",a] | Just v <- readMaybe a -> setAttr (\s -> s {mtl_illum = v}) 66 | ["Tr",a] | Just v <- readMaybe a -> setAttr (\s -> s {mtl_Tr = v}) 67 | ["Ns",a] | Just v <- readMaybe a -> setAttr (\s -> s {mtl_Ns = v}) 68 | _ -> return () 69 | 70 | parseMtl :: String -> MtlLib 71 | parseMtl src = Map.fromList [(mtl_Name m,m) | m <- evalState (execWriterT (mapM_ parseLine (lines src) >> addMaterial)) Nothing] 72 | 73 | readMtl :: String -> IO MtlLib 74 | readMtl fname = parseMtl <$> readFile fname 75 | -------------------------------------------------------------------------------- /examples/pickInt.json: -------------------------------------------------------------------------------- 1 | {"textures":[{"textureBaseLevel":0,"textureSize":{"tag":"VV2U","arg0":{"x":800,"y":600}},"tag":"TextureDescriptor","textureMaxLevel":0,"textureSampler":{"samplerMaxLod":null,"samplerLodBias":0,"tag":"SamplerDescriptor","samplerBorderColor":{"tag":"VV4F","arg0":{"w":1,"z":0,"x":0,"y":0}},"samplerMinFilter":{"tag":"Nearest"},"samplerWrapT":{"tag":"Repeat"},"samplerMagFilter":{"tag":"Nearest"},"samplerWrapR":null,"samplerCompareFunc":null,"samplerWrapS":{"tag":"Repeat"},"samplerMinLod":null},"textureType":{"tag":"Texture2D","arg0":{"tag":"IntT","arg0":{"tag":"RGBA"}},"arg1":1},"textureSemantic":{"tag":"Color"}}],"commands":[{"tag":"SetRenderTarget","arg0":0},{"tag":"ClearRenderTarget","arg0":[{"tag":"ClearImage","clearValue":{"tag":"VV4I","arg0":{"w":0,"z":0,"x":0,"y":0}},"imageSemantic":{"tag":"Color"}}]},{"tag":"SetProgram","arg0":0},{"tag":"SetRasterContext","arg0":{"arg3":{"tag":"LastVertex"},"tag":"TriangleCtx","arg0":{"tag":"CullFront","arg0":{"tag":"CCW"}},"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":{"color":{"tag":"V4F"},"id":{"tag":"Int"},"position":{"tag":"V3F"}},"slotName":"objects","slotUniforms":{"viewProj":{"tag":"M44F"}},"slotPrograms":[0]}],"programs":[{"programInTextures":{},"tag":"Program","programOutput":[{"tag":"Parameter","ty":{"tag":"V4I"},"name":"f0"}],"programStreams":{"vi3":{"tag":"Parameter","ty":{"tag":"Int"},"name":"id"},"vi2":{"tag":"Parameter","ty":{"tag":"V4F"},"name":"color"},"vi1":{"tag":"Parameter","ty":{"tag":"V3F"},"name":"position"}},"fragmentShader":"#version 330 core\nvec4 texture2D(sampler2D s,vec2 uv) {\n return texture(s,uv);\n}\nflat in vec2 vo1;\nflat in ivec4 vo2;\nout ivec4 f0;\nvoid main() {\n f0 = vo2;\n}","vertexShader":"#version 330 core\nvec4 texture2D(sampler2D s,vec2 uv) {\n return texture(s,uv);\n}\nuniform mat4 viewProj;\nin vec3 vi1;\nin vec4 vi2;\nin int vi3;\nflat out vec2 vo1;\nflat out ivec4 vo2;\nvoid main() {\n gl_Position = (viewProj) * (vec4 ((vi1).x,(vi1).y,0.0,1.0));\n vo1 = vec2 (0.0,0.0);\n vo2 = ivec4 (0,0,0,vi3);\n}","geometryShader":null,"programUniforms":{"viewProj":{"tag":"M44F"}}}],"samplers":[],"tag":"Pipeline","backend":{"tag":"OpenGL33"},"streams":[],"targets":[{"tag":"RenderTarget","renderTargets":[{"tag":"TargetItem","targetSemantic":{"tag":"Color"},"targetRef":{"tag":"TextureImage","arg0":0,"arg1":0,"arg2":null}}]}],"info":"generated by lambdacube-compiler 0.6.1.0"} -------------------------------------------------------------------------------- /examples/Hello.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PackageImports, LambdaCase, OverloadedStrings #-} 2 | import "GLFW-b" Graphics.UI.GLFW as GLFW 3 | import qualified Data.Map as Map 4 | import qualified Data.Vector as V 5 | 6 | import LambdaCube.GL as LambdaCubeGL -- renderer 7 | import LambdaCube.GL.Mesh as LambdaCubeGL 8 | 9 | import Codec.Picture as Juicy 10 | 11 | import Data.Aeson 12 | import qualified Data.ByteString as SB 13 | 14 | ---------------------------------------------------- 15 | -- See: http://lambdacube3d.com/getting-started 16 | ---------------------------------------------------- 17 | 18 | main :: IO () 19 | main = do 20 | Just pipelineDesc <- decodeStrict <$> SB.readFile "hello.json" 21 | 22 | win <- initWindow "LambdaCube 3D DSL Hello World" 640 640 23 | 24 | -- setup render data 25 | let inputSchema = makeSchema $ do 26 | defObjectArray "objects" Triangles $ do 27 | "position" @: Attribute_V2F 28 | "uv" @: Attribute_V2F 29 | defUniforms $ do 30 | "time" @: Float 31 | "diffuseTexture" @: FTexture2D 32 | 33 | storage <- LambdaCubeGL.allocStorage inputSchema 34 | 35 | -- upload geometry to GPU and add to pipeline input 36 | LambdaCubeGL.uploadMeshToGPU triangleA >>= LambdaCubeGL.addMeshToObjectArray storage "objects" [] 37 | LambdaCubeGL.uploadMeshToGPU triangleB >>= LambdaCubeGL.addMeshToObjectArray storage "objects" [] 38 | 39 | -- load image and upload texture 40 | Right img <- Juicy.readImage "logo.png" 41 | textureData <- LambdaCubeGL.uploadTexture2DToGPU img 42 | 43 | -- allocate GL pipeline 44 | renderer <- LambdaCubeGL.allocRenderer pipelineDesc 45 | LambdaCubeGL.setStorage renderer storage >>= \case -- check schema compatibility 46 | Just err -> putStrLn err 47 | Nothing -> loop 48 | where loop = do 49 | -- update graphics input 50 | GLFW.getWindowSize win >>= \(w,h) -> LambdaCubeGL.setScreenSize storage (fromIntegral w) (fromIntegral h) 51 | LambdaCubeGL.updateUniforms storage $ do 52 | "diffuseTexture" @= return textureData 53 | "time" @= do 54 | Just t <- GLFW.getTime 55 | return (realToFrac t :: Float) 56 | -- render 57 | LambdaCubeGL.renderFrame renderer 58 | GLFW.swapBuffers win 59 | GLFW.pollEvents 60 | 61 | let keyIsPressed k = fmap (==KeyState'Pressed) $ GLFW.getKey win k 62 | escape <- keyIsPressed Key'Escape 63 | if escape then return () else loop 64 | 65 | LambdaCubeGL.disposeRenderer renderer 66 | LambdaCubeGL.disposeStorage storage 67 | GLFW.destroyWindow win 68 | GLFW.terminate 69 | 70 | -- geometry data: triangles 71 | triangleA :: LambdaCubeGL.Mesh 72 | triangleA = Mesh 73 | { mAttributes = Map.fromList 74 | [ ("position", A_V2F $ V.fromList [V2 1 1, V2 1 (-1), V2 (-1) (-1)]) 75 | , ("uv", A_V2F $ V.fromList [V2 1 1, V2 0 1, V2 0 0]) 76 | ] 77 | , mPrimitive = P_Triangles 78 | } 79 | 80 | triangleB :: LambdaCubeGL.Mesh 81 | triangleB = Mesh 82 | { mAttributes = Map.fromList 83 | [ ("position", A_V2F $ V.fromList [V2 1 1, V2 (-1) (-1), V2 (-1) 1]) 84 | , ("uv", A_V2F $ V.fromList [V2 1 1, V2 0 0, V2 1 0]) 85 | ] 86 | , mPrimitive = P_Triangles 87 | } 88 | 89 | initWindow :: String -> Int -> Int -> IO Window 90 | initWindow title width height = do 91 | GLFW.init 92 | GLFW.defaultWindowHints 93 | mapM_ GLFW.windowHint 94 | [ WindowHint'ContextVersionMajor 3 95 | , WindowHint'ContextVersionMinor 3 96 | , WindowHint'OpenGLProfile OpenGLProfile'Core 97 | , WindowHint'OpenGLForwardCompat True 98 | ] 99 | Just win <- GLFW.createWindow width height title Nothing Nothing 100 | GLFW.makeContextCurrent $ Just win 101 | return win 102 | -------------------------------------------------------------------------------- /examples/HelloEmbedded.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PackageImports, LambdaCase, OverloadedStrings #-} 2 | import "GLFW-b" Graphics.UI.GLFW as GLFW 3 | import qualified Data.Map as Map 4 | import qualified Data.Vector as V 5 | 6 | import LambdaCube.GL as LambdaCubeGL -- renderer 7 | import LambdaCube.GL.Mesh as LambdaCubeGL 8 | 9 | import Codec.Picture as Juicy 10 | 11 | import LambdaCube.Compiler as LambdaCube -- compiler 12 | 13 | ---------------------------------------------------- 14 | -- See: http://lambdacube3d.com/getting-started 15 | ---------------------------------------------------- 16 | 17 | main :: IO () 18 | main = do 19 | -- compile hello.lc to graphics pipeline description 20 | pipelineDesc <- LambdaCube.compileMain ["."] OpenGL33 "hello.lc" >>= \case 21 | Left err -> fail $ "compile error:\n" ++ ppShow err 22 | Right pd -> return pd 23 | 24 | win <- initWindow "LambdaCube 3D DSL Hello World" 640 640 25 | 26 | -- setup render data 27 | let inputSchema = makeSchema $ do 28 | defObjectArray "objects" Triangles $ do 29 | "position" @: Attribute_V2F 30 | "uv" @: Attribute_V2F 31 | defUniforms $ do 32 | "time" @: Float 33 | "diffuseTexture" @: FTexture2D 34 | 35 | storage <- LambdaCubeGL.allocStorage inputSchema 36 | 37 | -- upload geometry to GPU and add to pipeline input 38 | LambdaCubeGL.uploadMeshToGPU triangleA >>= LambdaCubeGL.addMeshToObjectArray storage "objects" [] 39 | LambdaCubeGL.uploadMeshToGPU triangleB >>= LambdaCubeGL.addMeshToObjectArray storage "objects" [] 40 | 41 | -- load image and upload texture 42 | Right img <- Juicy.readImage "logo.png" 43 | textureData <- LambdaCubeGL.uploadTexture2DToGPU img 44 | 45 | -- allocate GL pipeline 46 | renderer <- LambdaCubeGL.allocRenderer pipelineDesc 47 | LambdaCubeGL.setStorage renderer storage >>= \case -- check schema compatibility 48 | Just err -> putStrLn err 49 | Nothing -> loop 50 | where loop = do 51 | -- update graphics input 52 | GLFW.getWindowSize win >>= \(w,h) -> LambdaCubeGL.setScreenSize storage (fromIntegral w) (fromIntegral h) 53 | LambdaCubeGL.updateUniforms storage $ do 54 | "diffuseTexture" @= return textureData 55 | "time" @= do 56 | Just t <- GLFW.getTime 57 | return (realToFrac t :: Float) 58 | -- render 59 | LambdaCubeGL.renderFrame renderer 60 | GLFW.swapBuffers win 61 | GLFW.pollEvents 62 | 63 | let keyIsPressed k = fmap (==KeyState'Pressed) $ GLFW.getKey win k 64 | escape <- keyIsPressed Key'Escape 65 | if escape then return () else loop 66 | 67 | LambdaCubeGL.disposeRenderer renderer 68 | LambdaCubeGL.disposeStorage storage 69 | GLFW.destroyWindow win 70 | GLFW.terminate 71 | 72 | -- geometry data: triangles 73 | triangleA :: LambdaCubeGL.Mesh 74 | triangleA = Mesh 75 | { mAttributes = Map.fromList 76 | [ ("position", A_V2F $ V.fromList [V2 1 1, V2 1 (-1), V2 (-1) (-1)]) 77 | , ("uv", A_V2F $ V.fromList [V2 1 1, V2 0 1, V2 0 0]) 78 | ] 79 | , mPrimitive = P_Triangles 80 | } 81 | 82 | triangleB :: LambdaCubeGL.Mesh 83 | triangleB = Mesh 84 | { mAttributes = Map.fromList 85 | [ ("position", A_V2F $ V.fromList [V2 1 1, V2 (-1) (-1), V2 (-1) 1]) 86 | , ("uv", A_V2F $ V.fromList [V2 1 1, V2 0 0, V2 1 0]) 87 | ] 88 | , mPrimitive = P_Triangles 89 | } 90 | 91 | initWindow :: String -> Int -> Int -> IO Window 92 | initWindow title width height = do 93 | GLFW.init 94 | GLFW.defaultWindowHints 95 | mapM_ GLFW.windowHint 96 | [ WindowHint'ContextVersionMajor 3 97 | , WindowHint'ContextVersionMinor 3 98 | , WindowHint'OpenGLProfile OpenGLProfile'Core 99 | , WindowHint'OpenGLForwardCompat True 100 | ] 101 | Just win <- GLFW.createWindow width height title Nothing Nothing 102 | GLFW.makeContextCurrent $ Just win 103 | return win 104 | -------------------------------------------------------------------------------- /lambdacube-gl.cabal: -------------------------------------------------------------------------------- 1 | name: lambdacube-gl 2 | version: 0.5.3.0 3 | synopsis: OpenGL 3.3 Core Profile backend for LambdaCube 3D 4 | description: OpenGL 3.3 Core Profile backend for LambdaCube 3D 5 | homepage: http://lambdacube3d.com 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Csaba Hruska, Peter Divianszky 9 | maintainer: csaba.hruska@gmail.com 10 | -- copyright: 11 | category: Graphics 12 | build-type: Simple 13 | 14 | extra-source-files: CHANGELOG.md 15 | examples/Hello.hs 16 | examples/HelloEmbedded.hs 17 | examples/HelloOBJ.hs 18 | examples/MtlParser.hs 19 | examples/hello.json 20 | examples/hello.lc 21 | examples/hello_obj.json 22 | examples/hello_obj.lc 23 | examples/logo.png 24 | examples/cube.obj 25 | examples/cube.mtl 26 | 27 | cabal-version: >=1.10 28 | 29 | Flag example 30 | Description: Build with example 31 | Default: False 32 | 33 | Flag testclient 34 | Description: Build with backend test client 35 | Default: False 36 | 37 | source-repository head 38 | type: git 39 | location: https://github.com/lambdacube3d/lambdacube-gl 40 | 41 | library 42 | exposed-modules: 43 | LambdaCube.GL 44 | LambdaCube.GL.Backend 45 | LambdaCube.GL.Data 46 | LambdaCube.GL.Input 47 | LambdaCube.GL.Mesh 48 | LambdaCube.GL.Type 49 | LambdaCube.GL.Util 50 | -- other-modules: 51 | -- other-extensions: 52 | build-depends: 53 | base >=4.9 && <5, 54 | containers >=0.5.7 && <0.6, 55 | mtl >=2.2 && <2.3, 56 | bytestring >=0.10 && <0.11, 57 | vector >=0.12 && <0.13, 58 | vector-algorithms >=0.7 && <0.8, 59 | JuicyPixels >=3.2.8 && <3.3, 60 | OpenGLRaw >=3.2 && <4, 61 | lambdacube-ir == 0.3.* 62 | hs-source-dirs: src 63 | default-language: Haskell2010 64 | 65 | executable lambdacube-gl-hello 66 | if flag(example) 67 | Buildable: True 68 | else 69 | Buildable: False 70 | 71 | hs-source-dirs: examples 72 | main-is: Hello.hs 73 | default-language: Haskell2010 74 | 75 | -- CAUTION: When the build-depends change, please bump the git submodule in lambdacube-docker repository 76 | build-depends: 77 | base < 5, 78 | containers >=0.5 && <0.6, 79 | bytestring >=0.10 && <0.11, 80 | vector >=0.12 && <0.13, 81 | JuicyPixels >=3.2 && <3.3, 82 | aeson >= 1.1.2, 83 | GLFW-b >= 1.4, 84 | lambdacube-gl, 85 | lambdacube-ir == 0.3.* 86 | 87 | executable lambdacube-gl-pickint 88 | if flag(example) 89 | Buildable: True 90 | else 91 | Buildable: False 92 | 93 | hs-source-dirs: examples 94 | main-is: pickInt.hs 95 | default-language: Haskell2010 96 | 97 | build-depends: 98 | GLFW-b >= 1.4, 99 | JuicyPixels >=3.2, 100 | OpenGLRaw, 101 | aeson >= 1.1.2, 102 | base, 103 | bytestring >=0.10, 104 | containers >=0.5, 105 | lambdacube-gl, 106 | lambdacube-ir, 107 | vect, 108 | vector >=0.12 109 | 110 | executable lambdacube-gl-hello-obj 111 | if flag(example) 112 | Buildable: True 113 | else 114 | Buildable: False 115 | 116 | hs-source-dirs: examples 117 | main-is: HelloOBJ.hs 118 | default-language: Haskell2010 119 | 120 | -- CAUTION: When the build-depends change, please bump the git submodule in lambdacube-docker repository 121 | build-depends: 122 | base < 5, 123 | containers >=0.5 && <0.6, 124 | mtl >=2.2 && <2.3, 125 | text >= 1.2 && <1.3, 126 | bytestring >=0.10 && <0.11, 127 | vector >=0.12 && <0.13, 128 | JuicyPixels >=3.2 && <3.3, 129 | aeson >= 1.1.2, 130 | GLFW-b >= 1.4, 131 | wavefront >= 0.7 && <1, 132 | lambdacube-gl, 133 | lambdacube-ir == 0.3.* 134 | 135 | executable lambdacube-gl-test-client 136 | if flag(testclient) 137 | Buildable: True 138 | else 139 | Buildable: False 140 | 141 | hs-source-dirs: testclient 142 | main-is: client.hs 143 | default-language: Haskell2010 144 | 145 | other-modules: TestData 146 | 147 | -- CAUTION: When the build-depends change, please bump the git submodule in lambdacube-docker repository 148 | build-depends: 149 | base < 5, 150 | containers >=0.5 && <0.6, 151 | text >= 1.2 && <1.3, 152 | time >= 1.5 && <1.7, 153 | exceptions >= 0.8 && <0.9, 154 | bytestring >=0.10 && <0.11, 155 | base64-bytestring >=1 && <1.1, 156 | vector >=0.12 && <0.13, 157 | JuicyPixels >=3.2 && <3.3, 158 | aeson >= 1.1.2, 159 | websockets >= 0.10 && <1, 160 | network >= 2.6 && <2.7, 161 | OpenGLRaw >=3.2 && <4, 162 | GLFW-b >= 1.4, 163 | lambdacube-gl, 164 | lambdacube-ir == 0.3.* 165 | -------------------------------------------------------------------------------- /src/LambdaCube/GL/Data.hs: -------------------------------------------------------------------------------- 1 | module LambdaCube.GL.Data where 2 | 3 | import Control.Applicative 4 | import Control.Monad 5 | import Data.IORef 6 | import Data.List as L 7 | import Data.Maybe 8 | import Foreign 9 | --import qualified Data.IntMap as IM 10 | import qualified Data.Map as Map 11 | import qualified Data.Set as Set 12 | import qualified Data.Vector as V 13 | import qualified Data.Vector.Storable as SV 14 | 15 | --import Control.DeepSeq 16 | 17 | import Graphics.GL.Core33 18 | import Data.Word 19 | import Codec.Picture 20 | import Codec.Picture.Types 21 | 22 | import LambdaCube.GL.Type 23 | import LambdaCube.GL.Util 24 | 25 | -- Buffer 26 | disposeBuffer :: Buffer -> IO () 27 | disposeBuffer (Buffer _ bo) = withArray [bo] $ glDeleteBuffers 1 28 | 29 | compileBuffer :: [Array] -> IO Buffer 30 | compileBuffer arrs = do 31 | let calcDesc (offset,setters,descs) (Array arrType cnt setter) = 32 | let size = cnt * sizeOfArrayType arrType 33 | in (size + offset, (offset,size,setter):setters, ArrayDesc arrType cnt offset size:descs) 34 | (bufSize,arrSetters,arrDescs) = foldl' calcDesc (0,[],[]) arrs 35 | bo <- alloca $! \pbo -> glGenBuffers 1 pbo >> peek pbo 36 | glBindBuffer GL_ARRAY_BUFFER bo 37 | glBufferData GL_ARRAY_BUFFER (fromIntegral bufSize) nullPtr GL_STATIC_DRAW 38 | forM_ arrSetters $! \(offset,size,setter) -> setter $! glBufferSubData GL_ARRAY_BUFFER (fromIntegral offset) (fromIntegral size) 39 | glBindBuffer GL_ARRAY_BUFFER 0 40 | return $! Buffer (V.fromList $! reverse arrDescs) bo 41 | 42 | updateBuffer :: Buffer -> [(Int,Array)] -> IO () 43 | updateBuffer (Buffer arrDescs bo) arrs = do 44 | glBindBuffer GL_ARRAY_BUFFER bo 45 | forM arrs $ \(i,Array arrType cnt setter) -> do 46 | let ArrayDesc ty len offset size = arrDescs V.! i 47 | when (ty == arrType && cnt == len) $ 48 | setter $! glBufferSubData GL_ARRAY_BUFFER (fromIntegral offset) (fromIntegral size) 49 | glBindBuffer GL_ARRAY_BUFFER 0 50 | 51 | bufferSize :: Buffer -> Int 52 | bufferSize = V.length . bufArrays 53 | 54 | arraySize :: Buffer -> Int -> Int 55 | arraySize buf arrIdx = arrLength $! bufArrays buf V.! arrIdx 56 | 57 | arrayType :: Buffer -> Int -> ArrayType 58 | arrayType buf arrIdx = arrType $! bufArrays buf V.! arrIdx 59 | 60 | -- Texture 61 | disposeTexture :: TextureData -> IO () 62 | disposeTexture (TextureData to) = withArray [to] $ glDeleteTextures 1 63 | 64 | -- FIXME: Temporary implemenation 65 | uploadTexture2DToGPU :: DynamicImage -> IO TextureData 66 | uploadTexture2DToGPU = uploadTexture2DToGPU' True False True False 67 | 68 | uploadTexture2DToGPU' :: Bool -> Bool -> Bool -> Bool -> DynamicImage -> IO TextureData 69 | uploadTexture2DToGPU' isFiltered isSRGB isMip isClamped bitmap' = do 70 | let bitmap = case bitmap' of 71 | ImageRGB8 i@(Image w h _) -> bitmap' 72 | ImageRGBA8 i@(Image w h _) -> bitmap' 73 | ImageYCbCr8 i@(Image w h _) -> ImageRGB8 $ convertImage i 74 | di -> ImageRGBA8 $ convertRGBA8 di 75 | 76 | glPixelStorei GL_UNPACK_ALIGNMENT 1 77 | to <- alloca $! \pto -> glGenTextures 1 pto >> peek pto 78 | glBindTexture GL_TEXTURE_2D to 79 | let (width,height) = bitmapSize bitmap 80 | bitmapSize (ImageRGB8 (Image w h _)) = (w,h) 81 | bitmapSize (ImageRGBA8 (Image w h _)) = (w,h) 82 | bitmapSize _ = error "unsupported image type :(" 83 | withBitmap (ImageRGB8 (Image w h v)) f = SV.unsafeWith v $ f (w,h) 3 0 84 | withBitmap (ImageRGBA8 (Image w h v)) f = SV.unsafeWith v $ f (w,h) 4 0 85 | withBitmap _ _ = error "unsupported image type :(" 86 | texFilter = if isFiltered then GL_LINEAR else GL_NEAREST 87 | wrapMode = case isClamped of 88 | True -> GL_CLAMP_TO_EDGE 89 | False -> GL_REPEAT 90 | (minFilter,maxLevel) = case isFiltered && isMip of 91 | False -> (texFilter,0) 92 | True -> (GL_LINEAR_MIPMAP_LINEAR, floor $ log (fromIntegral $ max width height) / log 2) 93 | glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S $ fromIntegral wrapMode 94 | glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T $ fromIntegral wrapMode 95 | glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER $ fromIntegral minFilter 96 | glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER $ fromIntegral texFilter 97 | glTexParameteri GL_TEXTURE_2D GL_TEXTURE_BASE_LEVEL 0 98 | glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAX_LEVEL $ fromIntegral maxLevel 99 | withBitmap bitmap $ \(w,h) nchn 0 ptr -> do 100 | 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) 101 | dataFormat = fromIntegral $ case nchn of 102 | 3 -> GL_RGB 103 | 4 -> GL_RGBA 104 | _ -> error "unsupported texture format!" 105 | glTexImage2D GL_TEXTURE_2D 0 internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat GL_UNSIGNED_BYTE $ castPtr ptr 106 | when isMip $ glGenerateMipmap GL_TEXTURE_2D 107 | return $ TextureData to 108 | -------------------------------------------------------------------------------- /examples/hello_obj.json: -------------------------------------------------------------------------------- 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"} -------------------------------------------------------------------------------- /src/LambdaCube/GL/Mesh.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TupleSections, RecordWildCards #-} 2 | module LambdaCube.GL.Mesh ( 3 | addMeshToObjectArray, 4 | uploadMeshToGPU, 5 | disposeMesh, 6 | updateMesh, 7 | Mesh(..), 8 | MeshPrimitive(..), 9 | MeshAttribute(..), 10 | GPUMesh(..), GPUData(..), 11 | ) where 12 | 13 | import Data.Maybe 14 | import Control.Applicative 15 | import Control.Monad 16 | import Foreign.Ptr 17 | import Data.Int 18 | import Foreign.Storable 19 | import Foreign.Marshal.Utils 20 | import System.IO.Unsafe 21 | import Data.Map (Map) 22 | import qualified Data.Map as Map 23 | import qualified Data.Vector as V 24 | import qualified Data.Vector.Storable as SV 25 | import qualified Data.Vector.Storable.Mutable as MV 26 | import qualified Data.ByteString.Char8 as SB 27 | import qualified Data.ByteString.Lazy as LB 28 | 29 | import LambdaCube.GL 30 | import LambdaCube.GL.Type as T 31 | import LambdaCube.IR as IR 32 | import LambdaCube.Linear as IR 33 | import LambdaCube.Mesh 34 | 35 | data GPUData 36 | = GPUData 37 | { dPrimitive :: Primitive 38 | , dStreams :: Map String (Stream Buffer) 39 | , dIndices :: Maybe (IndexStream Buffer) 40 | , dBuffers :: [Buffer] 41 | } 42 | 43 | data GPUMesh 44 | = GPUMesh 45 | { meshData :: Mesh 46 | , gpuData :: GPUData 47 | } 48 | 49 | addMeshToObjectArray :: GLStorage -> String -> [String] -> GPUMesh -> IO Object 50 | addMeshToObjectArray input slotName objUniNames (GPUMesh _ (GPUData prim streams indices _)) = do 51 | -- select proper attributes 52 | let (ObjectArraySchema slotPrim slotStreams) = fromMaybe (error $ "addMeshToObjectArray - missing object array: " ++ slotName) $ Map.lookup slotName $! objectArrays $! schema input 53 | filterStream n _ = Map.member n slotStreams 54 | addObject input slotName prim indices (Map.filterWithKey filterStream streams) objUniNames 55 | 56 | withV w a f = w a (\p -> f $ castPtr p) 57 | 58 | meshAttrToArray :: MeshAttribute -> Array 59 | meshAttrToArray (A_Float v) = Array ArrFloat (1 * V.length v) $ withV SV.unsafeWith $ V.convert v 60 | meshAttrToArray (A_V2F v) = Array ArrFloat (2 * V.length v) $ withV SV.unsafeWith $ V.convert v 61 | meshAttrToArray (A_V3F v) = Array ArrFloat (3 * V.length v) $ withV SV.unsafeWith $ V.convert v 62 | meshAttrToArray (A_V4F v) = Array ArrFloat (4 * V.length v) $ withV SV.unsafeWith $ V.convert v 63 | meshAttrToArray (A_M22F v) = Array ArrFloat (4 * V.length v) $ withV SV.unsafeWith $ V.convert v 64 | meshAttrToArray (A_M33F v) = Array ArrFloat (9 * V.length v) $ withV SV.unsafeWith $ V.convert v 65 | meshAttrToArray (A_M44F v) = Array ArrFloat (16 * V.length v) $ withV SV.unsafeWith $ V.convert v 66 | meshAttrToArray (A_Int v) = Array ArrInt32 (1 * V.length v) $ withV SV.unsafeWith $ V.convert v 67 | meshAttrToArray (A_Word v) = Array ArrWord32 (1 * V.length v) $ withV SV.unsafeWith $ V.convert v 68 | 69 | meshAttrToStream :: Buffer -> Int -> MeshAttribute -> Stream Buffer 70 | meshAttrToStream b i (A_Float v) = Stream Attribute_Float b i 0 (V.length v) 71 | meshAttrToStream b i (A_V2F v) = Stream Attribute_V2F b i 0 (V.length v) 72 | meshAttrToStream b i (A_V3F v) = Stream Attribute_V3F b i 0 (V.length v) 73 | meshAttrToStream b i (A_V4F v) = Stream Attribute_V4F b i 0 (V.length v) 74 | meshAttrToStream b i (A_M22F v) = Stream Attribute_M22F b i 0 (V.length v) 75 | meshAttrToStream b i (A_M33F v) = Stream Attribute_M33F b i 0 (V.length v) 76 | meshAttrToStream b i (A_M44F v) = Stream Attribute_M44F b i 0 (V.length v) 77 | meshAttrToStream b i (A_Int v) = Stream Attribute_Int b i 0 (V.length v) 78 | meshAttrToStream b i (A_Word v) = Stream Attribute_Word b i 0 (V.length v) 79 | 80 | updateMesh :: GPUMesh -> [(String,MeshAttribute)] -> Maybe MeshPrimitive -> IO () 81 | updateMesh (GPUMesh (Mesh dMA dMP) (GPUData _ dS dI _)) al mp = do 82 | -- check type match 83 | let arrayChk (Array t1 s1 _) (Array t2 s2 _) = t1 == t2 && s1 == s2 84 | 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] 85 | if not ok then putStrLn "updateMesh: attribute mismatch!" 86 | else do 87 | forM_ al $ \(n,a) -> do 88 | case Map.lookup n dS of 89 | Just (Stream _ b i _ _) -> updateBuffer b [(i,meshAttrToArray a)] 90 | _ -> return () 91 | {- 92 | case mp of 93 | Nothing -> return () 94 | Just p -> do 95 | let ok2 = case (dMP,p) of 96 | (Just (P_TriangleStripI v1, P_TriangleStripI v2) -> V.length v1 == V.length v2 97 | (P_TrianglesI v1, P_TrianglesI v2) -> V.length v1 == V.length v2 98 | (a,b) -> a == b 99 | -} 100 | 101 | uploadMeshToGPU :: Mesh -> IO GPUMesh 102 | uploadMeshToGPU mesh@(Mesh attrs mPrim) = do 103 | let mkIndexBuf v = do 104 | iBuf <- compileBuffer [Array ArrWord32 (V.length v) $ withV SV.unsafeWith $ V.convert v] 105 | return $! Just $! IndexStream iBuf 0 0 (V.length v) 106 | vBuf <- compileBuffer [meshAttrToArray a | a <- Map.elems attrs] 107 | (indices,prim) <- case mPrim of 108 | P_Points -> return (Nothing,PointList) 109 | P_TriangleStrip -> return (Nothing,TriangleStrip) 110 | P_Triangles -> return (Nothing,TriangleList) 111 | P_TriangleStripI v -> (,TriangleStrip) <$> mkIndexBuf v 112 | P_TrianglesI v -> (,TriangleList) <$> mkIndexBuf v 113 | let streams = Map.fromList $! zipWith (\i (n,a) -> (n,meshAttrToStream vBuf i a)) [0..] (Map.toList attrs) 114 | return $! GPUMesh mesh (GPUData prim streams indices (vBuf:[iBuf | IndexStream iBuf _ _ _ <- maybeToList indices])) 115 | 116 | disposeMesh :: GPUMesh -> IO () 117 | disposeMesh (GPUMesh _ GPUData{..}) = mapM_ disposeBuffer dBuffers 118 | -------------------------------------------------------------------------------- /testclient/TestData.hs: -------------------------------------------------------------------------------- 1 | -- generated file, do not modify! 2 | -- 2016-02-12T16:05:13.383716000000Z 3 | 4 | {-# LANGUAGE OverloadedStrings, RecordWildCards #-} 5 | module TestData where 6 | 7 | import Data.Int 8 | import Data.Word 9 | import Data.Map 10 | import Data.Vector (Vector(..)) 11 | import LambdaCube.Linear 12 | 13 | import Data.Text 14 | import Data.Aeson hiding (Value,Bool) 15 | import Data.Aeson.Types hiding (Value,Bool) 16 | import Control.Monad 17 | 18 | import LambdaCube.IR 19 | import LambdaCube.Mesh 20 | import LambdaCube.PipelineSchema 21 | 22 | data ClientInfo 23 | = ClientInfo 24 | { clientName :: String 25 | , clientBackend :: Backend 26 | } 27 | 28 | deriving (Show, Eq, Ord) 29 | 30 | data Frame 31 | = Frame 32 | { renderCount :: Int 33 | , frameUniforms :: Map String Value 34 | , frameTextures :: Map String Int 35 | } 36 | 37 | deriving (Show, Eq, Ord) 38 | 39 | data Scene 40 | = Scene 41 | { objectArrays :: Map String (Vector Int) 42 | , renderTargetWidth :: Int 43 | , renderTargetHeight :: Int 44 | , frames :: Vector Frame 45 | } 46 | 47 | deriving (Show, Eq, Ord) 48 | 49 | data PipelineInfo 50 | = PipelineInfo 51 | { pipelineName :: String 52 | , pipeline :: Pipeline 53 | } 54 | 55 | deriving (Show, Eq, Ord) 56 | 57 | data RenderJob 58 | = RenderJob 59 | { meshes :: Vector Mesh 60 | , textures :: Vector String 61 | , schema :: PipelineSchema 62 | , scenes :: Vector Scene 63 | , pipelines :: Vector PipelineInfo 64 | } 65 | 66 | deriving (Show, Eq, Ord) 67 | 68 | data FrameResult 69 | = FrameResult 70 | { frRenderTimes :: Vector Float 71 | , frImageWidth :: Int 72 | , frImageHeight :: Int 73 | } 74 | 75 | deriving (Show, Eq, Ord) 76 | 77 | data RenderJobResult 78 | = RenderJobResult FrameResult 79 | | RenderJobError String 80 | deriving (Show, Eq, Ord) 81 | 82 | 83 | instance ToJSON ClientInfo where 84 | toJSON v = case v of 85 | ClientInfo{..} -> object 86 | [ "tag" .= ("ClientInfo" :: Text) 87 | , "clientName" .= clientName 88 | , "clientBackend" .= clientBackend 89 | ] 90 | 91 | instance FromJSON ClientInfo where 92 | parseJSON (Object obj) = do 93 | tag <- obj .: "tag" 94 | case tag :: Text of 95 | "ClientInfo" -> do 96 | clientName <- obj .: "clientName" 97 | clientBackend <- obj .: "clientBackend" 98 | pure $ ClientInfo 99 | { clientName = clientName 100 | , clientBackend = clientBackend 101 | } 102 | parseJSON _ = mzero 103 | 104 | instance ToJSON Frame where 105 | toJSON v = case v of 106 | Frame{..} -> object 107 | [ "tag" .= ("Frame" :: Text) 108 | , "renderCount" .= renderCount 109 | , "frameUniforms" .= frameUniforms 110 | , "frameTextures" .= frameTextures 111 | ] 112 | 113 | instance FromJSON Frame where 114 | parseJSON (Object obj) = do 115 | tag <- obj .: "tag" 116 | case tag :: Text of 117 | "Frame" -> do 118 | renderCount <- obj .: "renderCount" 119 | frameUniforms <- obj .: "frameUniforms" 120 | frameTextures <- obj .: "frameTextures" 121 | pure $ Frame 122 | { renderCount = renderCount 123 | , frameUniforms = frameUniforms 124 | , frameTextures = frameTextures 125 | } 126 | parseJSON _ = mzero 127 | 128 | instance ToJSON Scene where 129 | toJSON v = case v of 130 | Scene{..} -> object 131 | [ "tag" .= ("Scene" :: Text) 132 | , "objectArrays" .= objectArrays 133 | , "renderTargetWidth" .= renderTargetWidth 134 | , "renderTargetHeight" .= renderTargetHeight 135 | , "frames" .= frames 136 | ] 137 | 138 | instance FromJSON Scene where 139 | parseJSON (Object obj) = do 140 | tag <- obj .: "tag" 141 | case tag :: Text of 142 | "Scene" -> do 143 | objectArrays <- obj .: "objectArrays" 144 | renderTargetWidth <- obj .: "renderTargetWidth" 145 | renderTargetHeight <- obj .: "renderTargetHeight" 146 | frames <- obj .: "frames" 147 | pure $ Scene 148 | { objectArrays = objectArrays 149 | , renderTargetWidth = renderTargetWidth 150 | , renderTargetHeight = renderTargetHeight 151 | , frames = frames 152 | } 153 | parseJSON _ = mzero 154 | 155 | instance ToJSON PipelineInfo where 156 | toJSON v = case v of 157 | PipelineInfo{..} -> object 158 | [ "tag" .= ("PipelineInfo" :: Text) 159 | , "pipelineName" .= pipelineName 160 | , "pipeline" .= pipeline 161 | ] 162 | 163 | instance FromJSON PipelineInfo where 164 | parseJSON (Object obj) = do 165 | tag <- obj .: "tag" 166 | case tag :: Text of 167 | "PipelineInfo" -> do 168 | pipelineName <- obj .: "pipelineName" 169 | pipeline <- obj .: "pipeline" 170 | pure $ PipelineInfo 171 | { pipelineName = pipelineName 172 | , pipeline = pipeline 173 | } 174 | parseJSON _ = mzero 175 | 176 | instance ToJSON RenderJob where 177 | toJSON v = case v of 178 | RenderJob{..} -> object 179 | [ "tag" .= ("RenderJob" :: Text) 180 | , "meshes" .= meshes 181 | , "textures" .= textures 182 | , "schema" .= schema 183 | , "scenes" .= scenes 184 | , "pipelines" .= pipelines 185 | ] 186 | 187 | instance FromJSON RenderJob where 188 | parseJSON (Object obj) = do 189 | tag <- obj .: "tag" 190 | case tag :: Text of 191 | "RenderJob" -> do 192 | meshes <- obj .: "meshes" 193 | textures <- obj .: "textures" 194 | schema <- obj .: "schema" 195 | scenes <- obj .: "scenes" 196 | pipelines <- obj .: "pipelines" 197 | pure $ RenderJob 198 | { meshes = meshes 199 | , textures = textures 200 | , schema = schema 201 | , scenes = scenes 202 | , pipelines = pipelines 203 | } 204 | parseJSON _ = mzero 205 | 206 | instance ToJSON FrameResult where 207 | toJSON v = case v of 208 | FrameResult{..} -> object 209 | [ "tag" .= ("FrameResult" :: Text) 210 | , "frRenderTimes" .= frRenderTimes 211 | , "frImageWidth" .= frImageWidth 212 | , "frImageHeight" .= frImageHeight 213 | ] 214 | 215 | instance FromJSON FrameResult where 216 | parseJSON (Object obj) = do 217 | tag <- obj .: "tag" 218 | case tag :: Text of 219 | "FrameResult" -> do 220 | frRenderTimes <- obj .: "frRenderTimes" 221 | frImageWidth <- obj .: "frImageWidth" 222 | frImageHeight <- obj .: "frImageHeight" 223 | pure $ FrameResult 224 | { frRenderTimes = frRenderTimes 225 | , frImageWidth = frImageWidth 226 | , frImageHeight = frImageHeight 227 | } 228 | parseJSON _ = mzero 229 | 230 | instance ToJSON RenderJobResult where 231 | toJSON v = case v of 232 | RenderJobResult arg0 -> object [ "tag" .= ("RenderJobResult" :: Text), "arg0" .= arg0] 233 | RenderJobError arg0 -> object [ "tag" .= ("RenderJobError" :: Text), "arg0" .= arg0] 234 | 235 | instance FromJSON RenderJobResult where 236 | parseJSON (Object obj) = do 237 | tag <- obj .: "tag" 238 | case tag :: Text of 239 | "RenderJobResult" -> RenderJobResult <$> obj .: "arg0" 240 | "RenderJobError" -> RenderJobError <$> obj .: "arg0" 241 | parseJSON _ = mzero 242 | 243 | -------------------------------------------------------------------------------- /examples/HelloOBJ.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PackageImports, LambdaCase, OverloadedStrings, RecordWildCards #-} 2 | import System.Environment 3 | import "GLFW-b" Graphics.UI.GLFW as GLFW 4 | import Data.Text (unpack,Text) 5 | import Data.List (groupBy,nub) 6 | import Data.Maybe 7 | import Control.Monad 8 | import Data.Map (Map) 9 | import qualified Data.Map as Map 10 | import qualified Data.Vector as V 11 | import qualified Data.ByteString as SB 12 | 13 | import LambdaCube.GL as LambdaCubeGL -- renderer 14 | import LambdaCube.GL.Mesh as LambdaCubeGL 15 | 16 | import Codec.Picture as Juicy 17 | import Data.Aeson 18 | import Codec.Wavefront 19 | 20 | import MtlParser 21 | 22 | ---------------------------------------------------- 23 | -- See: http://lambdacube3d.com/getting-started 24 | ---------------------------------------------------- 25 | 26 | objToMesh :: WavefrontOBJ -> [(Mesh,Maybe Text)] 27 | objToMesh WavefrontOBJ{..} = [(toMesh faceGroup, elMtl . head $ faceGroup) | faceGroup <- faces] where 28 | faces = groupBy (\a b -> elMtl a == elMtl b) (V.toList objFaces) 29 | toMesh l = Mesh 30 | { mAttributes = Map.fromList 31 | [ ("position", A_V4F position) 32 | , ("normal", A_V3F normal) 33 | , ("uvw", A_V3F texcoord) 34 | ] 35 | , mPrimitive = P_Triangles 36 | } where 37 | triangulate (Triangle a b c) = [a,b,c] 38 | triangulate (Quad a b c d) = [a,b,c, c,d,a] 39 | 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 40 | defaultPosition = Location 0 0 0 0 41 | defaultNormal = Normal 0 0 0 42 | defaultTexCoord = TexCoord 0 0 0 43 | v !- i = v V.!? (i-1) 44 | toVertex FaceIndex{..} = ( let Location x y z w = fromMaybe defaultPosition (objLocations !- faceLocIndex) in V4 x y z w 45 | , let Normal x y z = fromMaybe defaultNormal ((objNormals !-) =<< faceNorIndex) in V3 x y z 46 | , let TexCoord x y z = fromMaybe defaultTexCoord ((objTexCoords !-) =<< faceTexCoordIndex) in V3 x y z 47 | ) 48 | (position,normal,texcoord) = V.unzip3 . V.concat . map (V.fromList . map toVertex . triangulate . elValue) $ l 49 | 50 | 51 | loadOBJ :: String -> IO (Either String ([(Mesh,Maybe Text)],MtlLib)) 52 | loadOBJ fname = fromFile fname >>= \case -- load geometry 53 | Left err -> putStrLn err >> return (Left err) 54 | Right obj@WavefrontOBJ{..} -> do 55 | -- load materials 56 | mtlLib <- mconcat . V.toList <$> mapM (readMtl . unpack) objMtlLibs 57 | return $ Right (objToMesh obj,mtlLib) 58 | 59 | loadOBJToGPU :: String -> IO (Either String ([(GPUMesh, Maybe Text)], MtlLib)) 60 | loadOBJToGPU fname = loadOBJ fname >>= \case 61 | Left err -> return $ Left err 62 | Right (subModels,mtlLib) -> do 63 | gpuSubModels <- forM subModels $ \(mesh,mat) -> LambdaCubeGL.uploadMeshToGPU mesh >>= \a -> return (a,mat) 64 | return $ Right (gpuSubModels,mtlLib) 65 | 66 | uploadMtlLib :: MtlLib -> IO (Map Text (ObjMaterial,TextureData)) 67 | uploadMtlLib mtlLib = do 68 | -- collect used textures 69 | let usedTextures = nub . concatMap (maybeToList . mtl_map_Kd) $ Map.elems mtlLib 70 | whiteImage = Juicy.ImageRGB8 $ Juicy.generateImage (\_ _ -> Juicy.PixelRGB8 255 255 255) 1 1 71 | 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 72 | checkerTex <- LambdaCubeGL.uploadTexture2DToGPU checkerImage 73 | -- load images and upload to gpu 74 | textureLib <- forM (Map.fromList $ zip usedTextures usedTextures) $ \fname -> Juicy.readImage fname >>= \case 75 | Left err -> putStrLn err >> return checkerTex 76 | Right img -> LambdaCubeGL.uploadTexture2DToGPU img 77 | whiteTex <- LambdaCubeGL.uploadTexture2DToGPU whiteImage 78 | -- pair textures and materials 79 | return $ (\a -> (a, maybe whiteTex (fromMaybe checkerTex . flip Map.lookup textureLib) . mtl_map_Kd $ a)) <$> mtlLib 80 | 81 | addOBJToObjectArray :: GLStorage -> String -> [(GPUMesh, Maybe Text)] -> Map Text (ObjMaterial,TextureData) -> IO [LambdaCubeGL.Object] 82 | addOBJToObjectArray storage slotName objMesh mtlLib = forM objMesh $ \(mesh,mat) -> do 83 | obj <- LambdaCubeGL.addMeshToObjectArray storage slotName ["diffuseTexture","diffuseColor"] mesh -- diffuseTexture and diffuseColor values can change on each model 84 | case mat >>= flip Map.lookup mtlLib of 85 | Nothing -> return () 86 | Just (ObjMaterial{..},t) -> LambdaCubeGL.updateObjectUniforms obj $ do 87 | "diffuseTexture" @= return t -- set model's diffuse texture 88 | "diffuseColor" @= let (r,g,b) = mtl_Kd in return (V4 r g b mtl_Tr) 89 | return obj 90 | 91 | main :: IO () 92 | main = do 93 | Just pipelineDesc <- decodeStrict <$> SB.readFile "hello_obj.json" 94 | 95 | win <- initWindow "LambdaCube 3D DSL OBJ viewer" 640 640 96 | 97 | -- setup render data 98 | let inputSchema = makeSchema $ do 99 | defObjectArray "objects" Triangles $ do 100 | "position" @: Attribute_V4F 101 | "normal" @: Attribute_V3F 102 | "uvw" @: Attribute_V3F 103 | defUniforms $ do 104 | "time" @: Float 105 | "diffuseTexture" @: FTexture2D 106 | "diffuseColor" @: V4F 107 | 108 | storage <- LambdaCubeGL.allocStorage inputSchema 109 | 110 | objName <- head . (++ ["cube.obj"]) <$> getArgs 111 | -- load OBJ geometry and material descriptions 112 | Right (objMesh,mtlLib) <- loadOBJToGPU objName 113 | -- load materials textures 114 | gpuMtlLib <- uploadMtlLib mtlLib 115 | -- add OBJ to pipeline input 116 | addOBJToObjectArray storage "objects" objMesh gpuMtlLib 117 | 118 | -- allocate GL pipeline 119 | renderer <- LambdaCubeGL.allocRenderer pipelineDesc 120 | LambdaCubeGL.setStorage renderer storage >>= \case -- check schema compatibility 121 | Just err -> putStrLn err 122 | Nothing -> loop 123 | where loop = do 124 | -- update graphics input 125 | GLFW.getWindowSize win >>= \(w,h) -> LambdaCubeGL.setScreenSize storage (fromIntegral w) (fromIntegral h) 126 | LambdaCubeGL.updateUniforms storage $ do 127 | "time" @= do 128 | Just t <- GLFW.getTime 129 | return (realToFrac t :: Float) 130 | -- render 131 | LambdaCubeGL.renderFrame renderer 132 | GLFW.swapBuffers win 133 | GLFW.pollEvents 134 | 135 | let keyIsPressed k = fmap (==KeyState'Pressed) $ GLFW.getKey win k 136 | escape <- keyIsPressed Key'Escape 137 | if escape then return () else loop 138 | 139 | LambdaCubeGL.disposeRenderer renderer 140 | LambdaCubeGL.disposeStorage storage 141 | GLFW.destroyWindow win 142 | GLFW.terminate 143 | 144 | initWindow :: String -> Int -> Int -> IO Window 145 | initWindow title width height = do 146 | GLFW.init 147 | GLFW.defaultWindowHints 148 | mapM_ GLFW.windowHint 149 | [ WindowHint'ContextVersionMajor 3 150 | , WindowHint'ContextVersionMinor 3 151 | , WindowHint'OpenGLProfile OpenGLProfile'Core 152 | , WindowHint'OpenGLForwardCompat True 153 | ] 154 | Just win <- GLFW.createWindow width height title Nothing Nothing 155 | GLFW.makeContextCurrent $ Just win 156 | return win 157 | -------------------------------------------------------------------------------- /testclient/client.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PackageImports, LambdaCase, OverloadedStrings, RecordWildCards #-} 2 | 3 | import Control.Concurrent 4 | import Control.Concurrent.MVar 5 | import Control.Monad 6 | import Control.Monad.Catch 7 | import Data.Text (Text) 8 | import Data.Vector (Vector,(!)) 9 | import Data.ByteString.Char8 (unpack,pack) 10 | import qualified Data.ByteString as SB 11 | import qualified Data.Vector as V 12 | import qualified Data.Map as Map 13 | import qualified Data.ByteString.Base64 as B64 14 | 15 | import System.Exit 16 | import Data.Time.Clock 17 | import Data.Aeson 18 | import Foreign 19 | 20 | import qualified Network.WebSockets as WS 21 | import Network.Socket 22 | 23 | import "GLFW-b" Graphics.UI.GLFW as GLFW 24 | import "OpenGLRaw" Graphics.GL.Core33 25 | import Codec.Picture as Juicy 26 | 27 | import LambdaCube.IR 28 | import LambdaCube.PipelineSchema 29 | import LambdaCube.Mesh 30 | import LambdaCube.GL 31 | import LambdaCube.GL.Mesh 32 | import TestData 33 | 34 | main = do 35 | win <- initWindow "LambdaCube 3D OpenGL 3.3 Backend" 256 256 36 | 37 | GLFW.setWindowCloseCallback win $ Just $ \_ -> do 38 | GLFW.destroyWindow win 39 | GLFW.terminate 40 | exitSuccess 41 | 42 | -- connect to the test server 43 | forever $ catchAll (setupConnection win) $ \_ -> do 44 | GLFW.pollEvents 45 | threadDelay 100000 46 | 47 | setupConnection win = withSocketsDo $ WS.runClient "192.168.0.12" 9160 "/" $ \conn -> catchAll (execConnection win conn) $ \e -> do 48 | WS.sendTextData conn . encode $ RenderJobError $ displayException e 49 | 50 | execConnection win conn = do 51 | putStrLn "Connected!" 52 | -- register backend 53 | WS.sendTextData conn . encode $ ClientInfo 54 | { clientName = "Haskell OpenGL 3.3" 55 | , clientBackend = OpenGL33 56 | } 57 | chan <- newEmptyMVar :: IO (MVar RenderJob) 58 | -- wait for incoming render jobs 59 | _ <- forkIO $ forever $ do 60 | -- get the pipeline from the server 61 | decodeStrict <$> WS.receiveData conn >>= \case 62 | Nothing -> putStrLn "unknown message" 63 | Just renderJob -> putMVar chan renderJob 64 | -- process render jobs 65 | forever $ do 66 | tryTakeMVar chan >>= \case 67 | Nothing -> return () 68 | Just rj -> processRenderJob win conn rj 69 | WS.sendPing conn ("hello" :: Text) 70 | GLFW.pollEvents 71 | threadDelay 100000 72 | putStrLn "disconnected" 73 | WS.sendClose conn ("Bye!" :: Text) 74 | 75 | doAfter = flip (>>) 76 | 77 | processRenderJob win conn renderJob@RenderJob{..} = do 78 | putStrLn "got render job" 79 | gpuData@GPUData{..} <- allocateGPUData renderJob 80 | -- foreach pipeline 81 | doAfter (disposeGPUData gpuData) $ forM_ pipelines $ \PipelineInfo{..} -> do 82 | putStrLn $ "use pipeline: " ++ pipelineName 83 | renderer <- allocRenderer pipeline 84 | -- foreach scene 85 | doAfter (disposeRenderer renderer) $ forM_ scenes $ \Scene{..} -> do 86 | storage <- allocStorage schema 87 | -- add objects 88 | forM_ (Map.toList objectArrays) $ \(name,objs) -> forM_ objs $ addMeshToObjectArray storage name [] . (gpuMeshes !) 89 | -- set render target size 90 | GLFW.setWindowSize win renderTargetWidth renderTargetHeight 91 | setScreenSize storage (fromIntegral renderTargetWidth) (fromIntegral renderTargetHeight) 92 | -- connect renderer with storage 93 | doAfter (disposeStorage storage) $ setStorage renderer storage >>= \case 94 | Just err -> putStrLn err 95 | Nothing -> do 96 | -- foreach frame 97 | forM_ frames $ \Frame{..} -> do 98 | -- setup uniforms 99 | updateUniforms storage $ do 100 | forM_ (Map.toList frameTextures) $ \(name,tex) -> pack name @= return (gpuTextures ! tex) 101 | forM_ (Map.toList frameUniforms) $ uncurry setUniformValue 102 | -- rendering 103 | renderTimes <- V.replicateM renderCount . timeDiff $ do 104 | renderFrame renderer 105 | GLFW.swapBuffers win 106 | GLFW.pollEvents 107 | -- send render job result to server 108 | WS.sendTextData conn . encode . RenderJobResult $ FrameResult 109 | { frRenderTimes = renderTimes 110 | , frImageWidth = renderTargetWidth 111 | , frImageHeight = renderTargetHeight 112 | } 113 | -- send the last render result using Base64 encoding 114 | WS.sendBinaryData conn . B64.encode =<< getFrameBuffer renderTargetWidth renderTargetHeight 115 | 116 | -- utility code 117 | 118 | initWindow :: String -> Int -> Int -> IO Window 119 | initWindow title width height = do 120 | GLFW.init 121 | GLFW.defaultWindowHints 122 | mapM_ GLFW.windowHint 123 | [ WindowHint'ContextVersionMajor 3 124 | , WindowHint'ContextVersionMinor 3 125 | , WindowHint'OpenGLProfile OpenGLProfile'Core 126 | , WindowHint'OpenGLForwardCompat True 127 | ] 128 | Just win <- GLFW.createWindow width height title Nothing Nothing 129 | GLFW.makeContextCurrent $ Just win 130 | return win 131 | 132 | getFrameBuffer w h = do 133 | glFinish 134 | glBindFramebuffer GL_READ_FRAMEBUFFER 0 135 | glReadBuffer GL_FRONT_LEFT 136 | glBlitFramebuffer 0 0 (fromIntegral w) (fromIntegral h) 0 (fromIntegral h) (fromIntegral w) 0 GL_COLOR_BUFFER_BIT GL_NEAREST 137 | glReadBuffer GL_BACK_LEFT 138 | withFrameBuffer 0 0 w h $ \p -> SB.packCStringLen (castPtr p,w*h*4) 139 | 140 | withFrameBuffer :: Int -> Int -> Int -> Int -> (Ptr Word8 -> IO a) -> IO a 141 | withFrameBuffer x y w h fn = allocaBytes (w*h*4) $ \p -> do 142 | glPixelStorei GL_UNPACK_LSB_FIRST 0 143 | glPixelStorei GL_UNPACK_SWAP_BYTES 0 144 | glPixelStorei GL_UNPACK_ROW_LENGTH 0 145 | glPixelStorei GL_UNPACK_IMAGE_HEIGHT 0 146 | glPixelStorei GL_UNPACK_SKIP_ROWS 0 147 | glPixelStorei GL_UNPACK_SKIP_PIXELS 0 148 | glPixelStorei GL_UNPACK_SKIP_IMAGES 0 149 | glPixelStorei GL_UNPACK_ALIGNMENT 1 -- normally 4! 150 | glReadPixels (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h) GL_RGBA GL_UNSIGNED_BYTE $ castPtr p 151 | fn p 152 | 153 | data GPUData 154 | = GPUData 155 | { gpuTextures :: Vector TextureData 156 | , gpuMeshes :: Vector GPUMesh 157 | } 158 | 159 | allocateGPUData RenderJob{..} = GPUData <$> mapM uploadTex2D textures <*> mapM uploadMeshToGPU meshes 160 | where uploadTex2D = uploadTexture2DToGPU . either error id . decodeImage . either error id . B64.decode . pack 161 | 162 | disposeGPUData GPUData{..} = mapM_ disposeTexture gpuTextures >> mapM_ disposeMesh gpuMeshes 163 | 164 | timeDiff m = (\s e -> realToFrac $ diffUTCTime e s) <$> getCurrentTime <* m <*> getCurrentTime 165 | 166 | setUniformValue name = \case 167 | VBool v -> pack name @= return v 168 | VV2B v -> pack name @= return v 169 | VV3B v -> pack name @= return v 170 | VV4B v -> pack name @= return v 171 | VWord v -> pack name @= return v 172 | VV2U v -> pack name @= return v 173 | VV3U v -> pack name @= return v 174 | VV4U v -> pack name @= return v 175 | VInt v -> pack name @= return v 176 | VV2I v -> pack name @= return v 177 | VV3I v -> pack name @= return v 178 | VV4I v -> pack name @= return v 179 | VFloat v -> pack name @= return v 180 | VV2F v -> pack name @= return v 181 | VV3F v -> pack name @= return v 182 | VV4F v -> pack name @= return v 183 | VM22F v -> pack name @= return v 184 | VM23F v -> pack name @= return v 185 | VM24F v -> pack name @= return v 186 | VM32F v -> pack name @= return v 187 | VM33F v -> pack name @= return v 188 | VM34F v -> pack name @= return v 189 | VM42F v -> pack name @= return v 190 | VM43F v -> pack name @= return v 191 | VM44F v -> pack name @= return v 192 | -------------------------------------------------------------------------------- /examples/pickInt.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PackageImports, LambdaCase, OverloadedStrings, StandaloneDeriving, ViewPatterns #-} 2 | import Control.Monad 3 | import Data.Aeson 4 | import Data.Vect (Mat4(..), Vec3(..), Vec4(..)) 5 | import Graphics.GL.Core33 as GL 6 | import LambdaCube.GL as LambdaCubeGL 7 | import LambdaCube.GL.Mesh as LambdaCubeGL 8 | import Text.Printf 9 | import "GLFW-b" Graphics.UI.GLFW as GLFW 10 | import qualified Data.ByteString as SB 11 | import qualified Data.Map as Map 12 | import qualified Data.Vect as Vc 13 | import qualified Data.Vector as V 14 | import qualified Foreign as F 15 | import qualified Foreign.C.Types as F 16 | import qualified LambdaCube.GL.Type as LC 17 | import qualified LambdaCube.Linear as LCLin 18 | 19 | ---------------------------------------------------- 20 | -- See: http://lambdacube3d.com/getting-started 21 | ---------------------------------------------------- 22 | 23 | screenDim :: (Int, Int) 24 | screenDim = (800, 600) 25 | (screenW, screenH) = screenDim 26 | 27 | main :: IO () 28 | main = do 29 | Just pipePickDesc <- decodeStrict <$> SB.readFile "pickInt.json" 30 | Just pipeDrawDesc <- decodeStrict <$> SB.readFile "pickIntDraw.json" 31 | 32 | win <- initWindow "LambdaCube 3D integer picking" 800 600 33 | 34 | -- setup render data 35 | let inputSchema = makeSchema $ do 36 | defObjectArray "objects" Triangles $ do 37 | "position" @: Attribute_V2F 38 | "id" @: Attribute_Int 39 | "color" @: Attribute_V4F 40 | defUniforms $ do 41 | "viewProj" @: M44F 42 | 43 | storage <- LambdaCubeGL.allocStorage inputSchema 44 | 45 | -- upload geometry to GPU and add to pipeline input 46 | LambdaCubeGL.uploadMeshToGPU triangleA >>= LambdaCubeGL.addMeshToObjectArray storage "objects" [] 47 | LambdaCubeGL.uploadMeshToGPU triangleB >>= LambdaCubeGL.addMeshToObjectArray storage "objects" [] 48 | 49 | -- allocate GL pipeline 50 | pipePick <- LambdaCubeGL.allocRenderer pipePickDesc 51 | pipeDraw <- LambdaCubeGL.allocRenderer pipeDrawDesc 52 | errPick <- LambdaCubeGL.setStorage pipePick storage 53 | errDraw <- LambdaCubeGL.setStorage pipeDraw storage 54 | case (errPick, errDraw) of -- check schema compatibility 55 | (Just err, _) -> putStrLn err 56 | (_, Just err) -> putStrLn err 57 | (Nothing, Nothing) -> loop 58 | where loop = do 59 | -- update graphics input 60 | GLFW.getWindowSize win >>= \(w,h) -> LambdaCubeGL.setScreenSize storage (fromIntegral w) (fromIntegral h) 61 | LambdaCubeGL.updateUniforms storage $ do 62 | let (x, y) = (,) 0 0 63 | cvpos = Vec3 x (-y) 0 64 | toScreen = screenM screenW screenH 65 | "viewProj" @= pure (mat4ToM44F $! (Vc.fromProjective $! Vc.translation cvpos) Vc..*. toScreen) 66 | 67 | (curX, curY) <- GLFW.getCursorPos win 68 | let pickPoints = -- should be fb 0 fb 1 (pick) 69 | [ (clamp curX 800, clamp curY 600) 70 | , (0, 0) -- black 0 71 | , (200, 200) -- ..blue, ffff0000 2 72 | , (600, 400) -- ..red, ff0000ff 1 73 | ] :: [(Int, Int)] 74 | clamp v m = min (pred m) $ max 0 (floor v) 75 | 76 | -- render to render texture 77 | LambdaCubeGL.renderFrame pipePick 78 | case LC.glOutputs pipePick of 79 | [LC.GLOutputRenderTexture (fromIntegral -> fbo) _rendTex] -> do 80 | rtexPicks <- collectPicks fbo pickPoints 81 | printPicks pickPoints rtexPicks 82 | x -> error $ "Unexpected outputs: " ++ show x 83 | 84 | -- render to framebuffer & pick 85 | LambdaCubeGL.renderFrame pipeDraw 86 | colorPicks <- collectPicks 0 pickPoints 87 | printPicks pickPoints colorPicks 88 | 89 | GLFW.swapBuffers win 90 | GLFW.pollEvents 91 | 92 | let keyIsPressed k = fmap (==KeyState'Pressed) $ GLFW.getKey win k 93 | escape <- keyIsPressed Key'Escape 94 | if escape then return () else loop 95 | collectPicks :: Int -> [(Int, Int)] -> IO [Int] 96 | collectPicks fb picks = 97 | forM picks $ (fromIntegral <$>) . pickFrameBuffer fb screenDim 98 | printPicks pickPoints colorPicks = do 99 | forM_ (zip pickPoints colorPicks) $ \((x,y), col)-> do 100 | printf "%d:%d: %x " x y col 101 | putStrLn "" 102 | 103 | LambdaCubeGL.disposeRenderer pipePick 104 | LambdaCubeGL.disposeRenderer pipeDraw 105 | LambdaCubeGL.disposeStorage storage 106 | GLFW.destroyWindow win 107 | GLFW.terminate 108 | 109 | deriving instance Show (LC.GLOutput) 110 | deriving instance Show (LC.GLTexture) 111 | 112 | -- geometry data: triangles 113 | scale = 250.0 114 | s = scale 115 | 116 | triangleA :: LambdaCubeGL.Mesh 117 | triangleA = Mesh 118 | { mAttributes = Map.fromList 119 | [ ("position", A_V2F $ V.fromList [V2 s s, V2 s (-s), V2 (-s) (-s)]) 120 | , ("color", A_V4F $ V.fromList $ take 4 $ repeat $ V4 1 0 0 1) 121 | , ("id", A_Int $ V.fromList [1, 1, 1]) 122 | ] 123 | , mPrimitive = P_Triangles 124 | } 125 | 126 | triangleB :: LambdaCubeGL.Mesh 127 | triangleB = Mesh 128 | { mAttributes = Map.fromList 129 | [ ("position", A_V2F $ V.fromList [V2 s s, V2 (-s) (-s), V2 (-s) s]) 130 | , ("color", A_V4F $ V.fromList $ take 4 $ repeat $ V4 0 0 1 1) 131 | , ("id", A_Int $ V.fromList [2, 2, 2]) 132 | ] 133 | , mPrimitive = P_Triangles 134 | } 135 | 136 | vec4ToV4F :: Vec4 -> LCLin.V4F 137 | vec4ToV4F (Vc.Vec4 x y z w) = LCLin.V4 x y z w 138 | 139 | mat4ToM44F :: Mat4 -> LCLin.M44F 140 | mat4ToM44F (Mat4 a b c d) = LCLin.V4 (vec4ToV4F a) (vec4ToV4F b) (vec4ToV4F c) (vec4ToV4F d) 141 | 142 | screenM :: Int -> Int -> Mat4 143 | screenM w h = scaleM 144 | where (fw, fh) = (fromIntegral w, fromIntegral h) 145 | scaleM = Vc.Mat4 (Vc.Vec4 (1/fw) 0 0 0) 146 | (Vc.Vec4 0 (1/fh) 0 0) 147 | (Vc.Vec4 0 0 1 0) 148 | (Vc.Vec4 0 0 0 0.5) 149 | 150 | pickFrameBuffer 151 | :: Int -- ^ framebuffer 152 | -> (Int, Int) -- ^ FB dimensions 153 | -> (Int, Int) -- ^ pick coordinates 154 | -> IO F.Word32 -- ^ resultant pixel value 155 | pickFrameBuffer fb (w, h) (x, y) = do 156 | glFinish 157 | glBindFramebuffer GL_READ_FRAMEBUFFER $ fromIntegral fb 158 | let (fbmode, format) = 159 | if fb == 0 160 | then (GL_BACK_LEFT, GL_RGBA) 161 | else (GL_COLOR_ATTACHMENT0, GL_RGBA_INTEGER) 162 | glReadBuffer fbmode 163 | withFrameBuffer w format x (h - y - 1) 1 1 $ \p -> fromIntegral <$> F.peek (F.castPtr p :: F.Ptr F.Word32) 164 | 165 | withFrameBuffer :: Int -> GLenum -> Int -> Int -> Int -> Int -> (F.Ptr F.Word8 -> IO a) -> IO a 166 | withFrameBuffer rowLen format x y w h fn = F.allocaBytes (w*h*4) $ \p -> do 167 | glPixelStorei GL_UNPACK_LSB_FIRST 0 168 | glPixelStorei GL_UNPACK_SWAP_BYTES 0 169 | glPixelStorei GL_UNPACK_ROW_LENGTH $ fromIntegral rowLen 170 | glPixelStorei GL_UNPACK_IMAGE_HEIGHT 0 171 | glPixelStorei GL_UNPACK_SKIP_ROWS 0 172 | glPixelStorei GL_UNPACK_SKIP_PIXELS 0 173 | glPixelStorei GL_UNPACK_SKIP_IMAGES 0 174 | glPixelStorei GL_UNPACK_ALIGNMENT 1 175 | glReadPixels (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h) format GL_UNSIGNED_BYTE $ F.castPtr p 176 | glPixelStorei GL_UNPACK_ROW_LENGTH 0 177 | fn p 178 | 179 | initWindow :: String -> Int -> Int -> IO Window 180 | initWindow title width height = do 181 | GLFW.init 182 | GLFW.defaultWindowHints 183 | mapM_ GLFW.windowHint 184 | [ WindowHint'ContextVersionMajor 3 185 | , WindowHint'ContextVersionMinor 3 186 | , WindowHint'OpenGLProfile OpenGLProfile'Core 187 | , WindowHint'OpenGLForwardCompat True 188 | ] 189 | Just win <- GLFW.createWindow width height title Nothing Nothing 190 | GLFW.makeContextCurrent $ Just win 191 | return win 192 | 193 | -------------------------------------------------------------------------------- /src/LambdaCube/GL/Type.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification, FlexibleInstances, GeneralizedNewtypeDeriving, ScopedTypeVariables #-} 2 | module LambdaCube.GL.Type where 3 | 4 | import Data.IORef 5 | import Data.Int 6 | import Data.IntMap.Strict (IntMap) 7 | import Data.Set (Set) 8 | import Data.Map (Map) 9 | import Data.Vector (Vector) 10 | import Data.Word 11 | import Foreign.Ptr 12 | import Foreign.Storable 13 | import Data.ByteString 14 | 15 | import Graphics.GL.Core33 16 | 17 | import LambdaCube.Linear 18 | import LambdaCube.IR 19 | import LambdaCube.PipelineSchema 20 | 21 | type GLUniformName = ByteString 22 | 23 | --------------- 24 | -- Input API -- 25 | --------------- 26 | {- 27 | -- Buffer 28 | compileBuffer :: [Array] -> IO Buffer 29 | bufferSize :: Buffer -> Int 30 | arraySize :: Buffer -> Int -> Int 31 | arrayType :: Buffer -> Int -> ArrayType 32 | 33 | -- Object 34 | addObject :: Renderer -> ByteString -> Primitive -> Maybe (IndexStream Buffer) -> Trie (Stream Buffer) -> [ByteString] -> IO Object 35 | removeObject :: Renderer -> Object -> IO () 36 | objectUniformSetter :: Object -> Trie InputSetter 37 | -} 38 | 39 | data Buffer -- internal type 40 | = Buffer 41 | { bufArrays :: Vector ArrayDesc 42 | , bufGLObj :: GLuint 43 | } 44 | deriving (Show,Eq) 45 | 46 | data ArrayDesc 47 | = ArrayDesc 48 | { arrType :: ArrayType 49 | , arrLength :: Int -- item count 50 | , arrOffset :: Int -- byte position in buffer 51 | , arrSize :: Int -- size in bytes 52 | } 53 | deriving (Show,Eq) 54 | 55 | {- 56 | handles: 57 | uniforms 58 | textures 59 | buffers 60 | objects 61 | 62 | GLStorage can be attached to GLRenderer 63 | -} 64 | 65 | {- 66 | pipeline input: 67 | - independent from pipeline 68 | - per object features: enable/disable visibility, set render ordering 69 | -} 70 | data GLUniform = forall a. Storable a => GLUniform !InputType !(IORef a) 71 | 72 | instance Show GLUniform where 73 | show (GLUniform t _) = "GLUniform " ++ show t 74 | 75 | data OrderJob 76 | = Generate 77 | | Reorder 78 | | Ordered 79 | 80 | data GLSlot 81 | = GLSlot 82 | { objectMap :: !(IntMap Object) 83 | , sortedObjects :: !(Vector (Int,Object)) 84 | , orderJob :: !OrderJob 85 | } 86 | 87 | data GLStorage 88 | = GLStorage 89 | { schema :: PipelineSchema 90 | , slotMap :: Map String SlotName 91 | , slotVector :: Vector (IORef GLSlot) 92 | , objSeed :: IORef Int 93 | , uniformSetter :: Map GLUniformName InputSetter 94 | , uniformSetup :: Map String GLUniform 95 | , screenSize :: IORef (Word,Word) 96 | , pipelines :: IORef (Vector (Maybe GLRenderer)) -- attached pipelines 97 | } 98 | 99 | data Object -- internal type 100 | = Object 101 | { objSlot :: SlotName 102 | , objPrimitive :: Primitive 103 | , objIndices :: Maybe (IndexStream Buffer) 104 | , objAttributes :: Map String (Stream Buffer) 105 | , objUniSetter :: Map GLUniformName InputSetter 106 | , objUniSetup :: Map String GLUniform 107 | , objOrder :: IORef Int 108 | , objEnabled :: IORef Bool 109 | , objId :: Int 110 | , objCommands :: IORef (Vector (Vector [GLObjectCommand])) -- pipeline id, program name, commands 111 | } 112 | 113 | -------------- 114 | -- Pipeline -- 115 | -------------- 116 | 117 | data GLProgram 118 | = GLProgram 119 | { shaderObjects :: [GLuint] 120 | , programObject :: GLuint 121 | , inputUniforms :: Map String GLint 122 | , inputTextures :: Map String GLint -- all input textures (render texture + uniform texture) 123 | , inputTextureUniforms :: Set String 124 | , inputStreams :: Map String (GLuint,String) 125 | } 126 | 127 | data GLTexture 128 | = GLTexture 129 | { glTextureObject :: GLuint 130 | , glTextureTarget :: GLenum 131 | , glTextureSize :: V3U 132 | } deriving Eq 133 | 134 | data InputConnection 135 | = InputConnection 136 | { icId :: Int -- identifier (vector index) for attached pipeline 137 | , icInput :: GLStorage 138 | , icSlotMapPipelineToInput :: Vector SlotName -- GLRenderer to GLStorage slot name mapping 139 | , icSlotMapInputToPipeline :: Vector (Maybe SlotName) -- GLStorage to GLRenderer slot name mapping 140 | } 141 | 142 | data GLStream 143 | = GLStream 144 | { glStreamCommands :: IORef [GLObjectCommand] 145 | , glStreamPrimitive :: Primitive 146 | , glStreamAttributes :: Map String (Stream Buffer) 147 | , glStreamProgram :: ProgramName 148 | } 149 | 150 | data GLRenderer 151 | = GLRenderer 152 | { glPrograms :: Vector GLProgram 153 | , glTextures :: Vector GLTexture 154 | , glSamplers :: Vector GLSampler 155 | , glTargets :: Vector GLRenderTarget 156 | , glOutputs :: [GLOutput] 157 | , glCommands :: [GLCommand] 158 | , glSlotPrograms :: Vector [ProgramName] -- programs depend on a slot 159 | , glInput :: IORef (Maybe InputConnection) 160 | , glSlotNames :: Vector String 161 | , glVAO :: GLuint 162 | , glTexUnitMapping :: Map String (IORef GLint) -- maps texture uniforms to texture units 163 | , glStreams :: Vector GLStream 164 | , glDrawContextRef :: IORef GLDrawContext 165 | , glForceSetup :: IORef Bool 166 | , glVertexBufferRef :: IORef GLuint 167 | , glIndexBufferRef :: IORef GLuint 168 | , glDrawCallCounterRef :: IORef Int 169 | } 170 | 171 | data GLSampler 172 | = GLSampler 173 | { glSamplerObject :: GLuint 174 | } deriving Eq 175 | 176 | data GLRenderTarget 177 | = GLRenderTarget 178 | { framebufferObject :: GLuint 179 | , framebufferDrawbuffers :: Maybe [GLenum] 180 | , framebufferSize :: Maybe V3U 181 | } deriving Eq 182 | 183 | data GLOutput 184 | = GLOutputDrawBuffer 185 | { glOutputFBO :: GLuint 186 | , glOutputDrawBuffer :: GLenum 187 | } 188 | | GLOutputRenderTexture 189 | { glOutputFBO :: GLuint 190 | , glOutputRenderTexture :: GLTexture 191 | } 192 | 193 | type GLTextureUnit = Int 194 | type GLUniformBinding = GLint 195 | 196 | data GLSamplerUniform 197 | = GLSamplerUniform 198 | { glUniformBinding :: !GLUniformBinding 199 | , glUniformBindingRef :: IORef GLUniformBinding 200 | } 201 | 202 | instance Eq GLSamplerUniform where 203 | a == b = glUniformBinding a == glUniformBinding b 204 | 205 | data GLDrawContext 206 | = GLDrawContext 207 | { glRasterContext :: !RasterContext 208 | , glAccumulationContext :: !AccumulationContext 209 | , glRenderTarget :: !GLRenderTarget 210 | , glProgram :: !GLuint 211 | , glTextureMapping :: ![(GLTextureUnit,GLTexture)] 212 | , glSamplerMapping :: ![(GLTextureUnit,GLSampler)] 213 | , glSamplerUniformMapping :: ![(GLTextureUnit,GLSamplerUniform)] 214 | } 215 | 216 | data GLCommand 217 | = GLRenderSlot !GLDrawContext !SlotName !ProgramName 218 | | GLRenderStream !GLDrawContext !StreamName !ProgramName 219 | | GLClearRenderTarget !GLRenderTarget ![ClearImage] 220 | 221 | instance Show (IORef GLint) where 222 | show _ = "(IORef GLint)" 223 | 224 | data GLObjectCommand 225 | = GLSetUniform !GLint !GLUniform 226 | | GLBindTexture !GLenum !(IORef GLint) !GLUniform -- binds the texture from the gluniform to the specified texture unit and target 227 | | GLSetVertexAttribArray !GLuint !GLuint !GLint !GLenum !(Ptr ()) -- index buffer size type pointer 228 | | GLSetVertexAttribIArray !GLuint !GLuint !GLint !GLenum !(Ptr ()) -- index buffer size type pointer 229 | | GLSetVertexAttrib !GLuint !(Stream Buffer) -- index value 230 | | GLDrawArrays !GLenum !GLint !GLsizei -- mode first count 231 | | GLDrawElements !GLenum !GLsizei !GLenum !GLuint !(Ptr ()) -- mode count type buffer indicesPtr 232 | deriving Show 233 | 234 | type SetterFun a = a -> IO () 235 | 236 | -- user will provide scalar input data via this type 237 | data InputSetter 238 | = SBool (SetterFun Bool) 239 | | SV2B (SetterFun V2B) 240 | | SV3B (SetterFun V3B) 241 | | SV4B (SetterFun V4B) 242 | | SWord (SetterFun Word32) 243 | | SV2U (SetterFun V2U) 244 | | SV3U (SetterFun V3U) 245 | | SV4U (SetterFun V4U) 246 | | SInt (SetterFun Int32) 247 | | SV2I (SetterFun V2I) 248 | | SV3I (SetterFun V3I) 249 | | SV4I (SetterFun V4I) 250 | | SFloat (SetterFun Float) 251 | | SV2F (SetterFun V2F) 252 | | SV3F (SetterFun V3F) 253 | | SV4F (SetterFun V4F) 254 | | SM22F (SetterFun M22F) 255 | | SM23F (SetterFun M23F) 256 | | SM24F (SetterFun M24F) 257 | | SM32F (SetterFun M32F) 258 | | SM33F (SetterFun M33F) 259 | | SM34F (SetterFun M34F) 260 | | SM42F (SetterFun M42F) 261 | | SM43F (SetterFun M43F) 262 | | SM44F (SetterFun M44F) 263 | -- shadow textures 264 | | SSTexture1D 265 | | SSTexture2D 266 | | SSTextureCube 267 | | SSTexture1DArray 268 | | SSTexture2DArray 269 | | SSTexture2DRect 270 | -- float textures 271 | | SFTexture1D 272 | | SFTexture2D (SetterFun TextureData) 273 | | SFTexture3D 274 | | SFTextureCube 275 | | SFTexture1DArray 276 | | SFTexture2DArray 277 | | SFTexture2DMS 278 | | SFTexture2DMSArray 279 | | SFTextureBuffer 280 | | SFTexture2DRect 281 | -- int textures 282 | | SITexture1D 283 | | SITexture2D 284 | | SITexture3D 285 | | SITextureCube 286 | | SITexture1DArray 287 | | SITexture2DArray 288 | | SITexture2DMS 289 | | SITexture2DMSArray 290 | | SITextureBuffer 291 | | SITexture2DRect 292 | -- uint textures 293 | | SUTexture1D 294 | | SUTexture2D 295 | | SUTexture3D 296 | | SUTextureCube 297 | | SUTexture1DArray 298 | | SUTexture2DArray 299 | | SUTexture2DMS 300 | | SUTexture2DMSArray 301 | | SUTextureBuffer 302 | | SUTexture2DRect 303 | 304 | -- buffer handling 305 | {- 306 | user can fills a buffer (continuous memory region) 307 | each buffer have a data descriptor, what describes the 308 | buffer content. e.g. a buffer can contain more arrays of stream types 309 | -} 310 | 311 | -- user will provide stream data using this setup function 312 | type BufferSetter = (Ptr () -> IO ()) -> IO () 313 | 314 | -- specifies array component type (stream type in storage side) 315 | -- this type can be overridden in GPU side, e.g ArrWord8 can be seen as TFloat or TWord also 316 | data ArrayType 317 | = ArrWord8 318 | | ArrWord16 319 | | ArrWord32 320 | | ArrInt8 321 | | ArrInt16 322 | | ArrInt32 323 | | ArrFloat 324 | | ArrHalf -- Hint: half float is not supported in haskell 325 | deriving (Show,Eq,Ord) 326 | 327 | sizeOfArrayType :: ArrayType -> Int 328 | sizeOfArrayType ArrWord8 = 1 329 | sizeOfArrayType ArrWord16 = 2 330 | sizeOfArrayType ArrWord32 = 4 331 | sizeOfArrayType ArrInt8 = 1 332 | sizeOfArrayType ArrInt16 = 2 333 | sizeOfArrayType ArrInt32 = 4 334 | sizeOfArrayType ArrFloat = 4 335 | sizeOfArrayType ArrHalf = 2 336 | 337 | -- describes an array in a buffer 338 | data Array -- array type, element count (NOT byte size!), setter 339 | = Array ArrayType Int BufferSetter 340 | 341 | toStreamType :: InputType -> Maybe StreamType 342 | toStreamType Word = Just Attribute_Word 343 | toStreamType V2U = Just Attribute_V2U 344 | toStreamType V3U = Just Attribute_V3U 345 | toStreamType V4U = Just Attribute_V4U 346 | toStreamType Int = Just Attribute_Int 347 | toStreamType V2I = Just Attribute_V2I 348 | toStreamType V3I = Just Attribute_V3I 349 | toStreamType V4I = Just Attribute_V4I 350 | toStreamType Float = Just Attribute_Float 351 | toStreamType V2F = Just Attribute_V2F 352 | toStreamType V3F = Just Attribute_V3F 353 | toStreamType V4F = Just Attribute_V4F 354 | toStreamType M22F = Just Attribute_M22F 355 | toStreamType M23F = Just Attribute_M23F 356 | toStreamType M24F = Just Attribute_M24F 357 | toStreamType M32F = Just Attribute_M32F 358 | toStreamType M33F = Just Attribute_M33F 359 | toStreamType M34F = Just Attribute_M34F 360 | toStreamType M42F = Just Attribute_M42F 361 | toStreamType M43F = Just Attribute_M43F 362 | toStreamType M44F = Just Attribute_M44F 363 | toStreamType _ = Nothing 364 | 365 | fromStreamType :: StreamType -> InputType 366 | fromStreamType Attribute_Word = Word 367 | fromStreamType Attribute_V2U = V2U 368 | fromStreamType Attribute_V3U = V3U 369 | fromStreamType Attribute_V4U = V4U 370 | fromStreamType Attribute_Int = Int 371 | fromStreamType Attribute_V2I = V2I 372 | fromStreamType Attribute_V3I = V3I 373 | fromStreamType Attribute_V4I = V4I 374 | fromStreamType Attribute_Float = Float 375 | fromStreamType Attribute_V2F = V2F 376 | fromStreamType Attribute_V3F = V3F 377 | fromStreamType Attribute_V4F = V4F 378 | fromStreamType Attribute_M22F = M22F 379 | fromStreamType Attribute_M23F = M23F 380 | fromStreamType Attribute_M24F = M24F 381 | fromStreamType Attribute_M32F = M32F 382 | fromStreamType Attribute_M33F = M33F 383 | fromStreamType Attribute_M34F = M34F 384 | fromStreamType Attribute_M42F = M42F 385 | fromStreamType Attribute_M43F = M43F 386 | fromStreamType Attribute_M44F = M44F 387 | 388 | -- user can specify streams using Stream type 389 | -- a stream can be constant (ConstXXX) or can came from a buffer 390 | data Stream b 391 | = ConstWord Word32 392 | | ConstV2U V2U 393 | | ConstV3U V3U 394 | | ConstV4U V4U 395 | | ConstInt Int32 396 | | ConstV2I V2I 397 | | ConstV3I V3I 398 | | ConstV4I V4I 399 | | ConstFloat Float 400 | | ConstV2F V2F 401 | | ConstV3F V3F 402 | | ConstV4F V4F 403 | | ConstM22F M22F 404 | | ConstM23F M23F 405 | | ConstM24F M24F 406 | | ConstM32F M32F 407 | | ConstM33F M33F 408 | | ConstM34F M34F 409 | | ConstM42F M42F 410 | | ConstM43F M43F 411 | | ConstM44F M44F 412 | | Stream 413 | { streamType :: StreamType 414 | , streamBuffer :: b 415 | , streamArrIdx :: Int 416 | , streamStart :: Int 417 | , streamLength :: Int 418 | } 419 | deriving Show 420 | 421 | streamToStreamType :: Stream a -> StreamType 422 | streamToStreamType s = case s of 423 | ConstWord _ -> Attribute_Word 424 | ConstV2U _ -> Attribute_V2U 425 | ConstV3U _ -> Attribute_V3U 426 | ConstV4U _ -> Attribute_V4U 427 | ConstInt _ -> Attribute_Int 428 | ConstV2I _ -> Attribute_V2I 429 | ConstV3I _ -> Attribute_V3I 430 | ConstV4I _ -> Attribute_V4I 431 | ConstFloat _ -> Attribute_Float 432 | ConstV2F _ -> Attribute_V2F 433 | ConstV3F _ -> Attribute_V3F 434 | ConstV4F _ -> Attribute_V4F 435 | ConstM22F _ -> Attribute_M22F 436 | ConstM23F _ -> Attribute_M23F 437 | ConstM24F _ -> Attribute_M24F 438 | ConstM32F _ -> Attribute_M32F 439 | ConstM33F _ -> Attribute_M33F 440 | ConstM34F _ -> Attribute_M34F 441 | ConstM42F _ -> Attribute_M42F 442 | ConstM43F _ -> Attribute_M43F 443 | ConstM44F _ -> Attribute_M44F 444 | Stream t _ _ _ _ -> t 445 | 446 | -- stream of index values (for index buffer) 447 | data IndexStream b 448 | = IndexStream 449 | { indexBuffer :: b 450 | , indexArrIdx :: Int 451 | , indexStart :: Int 452 | , indexLength :: Int 453 | } 454 | 455 | newtype TextureData 456 | = TextureData 457 | { textureObject :: GLuint 458 | } 459 | deriving Storable 460 | 461 | data Primitive 462 | = TriangleStrip 463 | | TriangleList 464 | | TriangleFan 465 | | LineStrip 466 | | LineList 467 | | PointList 468 | | TriangleStripAdjacency 469 | | TriangleListAdjacency 470 | | LineStripAdjacency 471 | | LineListAdjacency 472 | deriving (Eq,Ord,Bounded,Enum,Show) 473 | 474 | type StreamSetter = Stream Buffer -> IO () 475 | 476 | -- storable instances 477 | instance Storable a => Storable (V2 a) where 478 | sizeOf _ = 2 * sizeOf (undefined :: a) 479 | alignment _ = sizeOf (undefined :: a) 480 | 481 | peek q = do 482 | let p = castPtr q :: Ptr a 483 | k = sizeOf (undefined :: a) 484 | x <- peek p 485 | y <- peekByteOff p k 486 | return $! (V2 x y) 487 | 488 | poke q (V2 x y) = do 489 | let p = castPtr q :: Ptr a 490 | k = sizeOf (undefined :: a) 491 | poke p x 492 | pokeByteOff p k y 493 | 494 | instance Storable a => Storable (V3 a) where 495 | sizeOf _ = 3 * sizeOf (undefined :: a) 496 | alignment _ = sizeOf (undefined :: a) 497 | 498 | peek q = do 499 | let p = castPtr q :: Ptr a 500 | k = sizeOf (undefined :: a) 501 | x <- peek p 502 | y <- peekByteOff p k 503 | z <- peekByteOff p (k*2) 504 | return $! (V3 x y z) 505 | 506 | poke q (V3 x y z) = do 507 | let p = castPtr q :: Ptr a 508 | k = sizeOf (undefined :: a) 509 | poke p x 510 | pokeByteOff p k y 511 | pokeByteOff p (k*2) z 512 | 513 | instance Storable a => Storable (V4 a) where 514 | sizeOf _ = 4 * sizeOf (undefined :: a) 515 | alignment _ = sizeOf (undefined :: a) 516 | 517 | peek q = do 518 | let p = castPtr q :: Ptr a 519 | k = sizeOf (undefined :: a) 520 | x <- peek p 521 | y <- peekByteOff p k 522 | z <- peekByteOff p (k*2) 523 | w <- peekByteOff p (k*3) 524 | return $! (V4 x y z w) 525 | 526 | poke q (V4 x y z w) = do 527 | let p = castPtr q :: Ptr a 528 | k = sizeOf (undefined :: a) 529 | poke p x 530 | pokeByteOff p k y 531 | pokeByteOff p (k*2) z 532 | pokeByteOff p (k*3) w 533 | -------------------------------------------------------------------------------- /src/LambdaCube/GL/Input.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns, FlexibleContexts, TypeSynonymInstances, FlexibleInstances #-} 2 | module LambdaCube.GL.Input where 3 | 4 | import Control.Applicative 5 | import Control.Exception 6 | import Control.Monad 7 | import Control.Monad.Writer 8 | import Data.Maybe 9 | import Data.IORef 10 | import Data.Map (Map) 11 | import Data.IntMap (IntMap) 12 | import Data.Vector (Vector,(//),(!)) 13 | import Data.Word 14 | import Data.String 15 | import Foreign 16 | import qualified Data.IntMap as IM 17 | import qualified Data.Set as S 18 | import qualified Data.Map as Map 19 | import qualified Data.Vector as V 20 | import qualified Data.Vector.Algorithms.Intro as I 21 | import Data.ByteString.Char8 (ByteString) 22 | import qualified Data.ByteString.Char8 as SB 23 | 24 | import Graphics.GL.Core33 25 | 26 | import LambdaCube.IR as IR 27 | import LambdaCube.Linear as IR 28 | import LambdaCube.PipelineSchema 29 | import LambdaCube.GL.Type as T 30 | import LambdaCube.GL.Util 31 | 32 | import qualified LambdaCube.IR as IR 33 | 34 | schemaFromPipeline :: IR.Pipeline -> PipelineSchema 35 | schemaFromPipeline a = PipelineSchema (Map.fromList sl) (foldl Map.union Map.empty ul) 36 | where 37 | (sl,ul) = unzip [( (sName,ObjectArraySchema sPrimitive (fmap cvt sStreams)) 38 | , sUniforms 39 | ) 40 | | IR.Slot sName sStreams sUniforms sPrimitive _ <- V.toList $ IR.slots a 41 | ] 42 | cvt a = case toStreamType a of 43 | Just v -> v 44 | Nothing -> error "internal error (schemaFromPipeline)" 45 | 46 | mkUniform :: [(String,InputType)] -> IO (Map GLUniformName InputSetter, Map String GLUniform) 47 | mkUniform l = do 48 | unisAndSetters <- forM l $ \(n,t) -> do 49 | (uni, setter) <- mkUniformSetter t 50 | return ((n,uni),(fromString n,setter)) 51 | let (unis,setters) = unzip unisAndSetters 52 | return (Map.fromList setters, Map.fromList unis) 53 | 54 | allocStorage :: PipelineSchema -> IO GLStorage 55 | allocStorage sch = do 56 | let sm = Map.fromList $ zip (Map.keys $ objectArrays sch) [0..] 57 | len = Map.size sm 58 | (setters,unis) <- mkUniform $ Map.toList $ uniforms sch 59 | seed <- newIORef 0 60 | slotV <- V.replicateM len $ newIORef (GLSlot IM.empty V.empty Ordered) 61 | size <- newIORef (0,0) 62 | ppls <- newIORef $ V.singleton Nothing 63 | return $ GLStorage 64 | { schema = sch 65 | , slotMap = sm 66 | , slotVector = slotV 67 | , objSeed = seed 68 | , uniformSetter = setters 69 | , uniformSetup = unis 70 | , screenSize = size 71 | , pipelines = ppls 72 | } 73 | 74 | disposeStorage :: GLStorage -> IO () 75 | disposeStorage _ = putStrLn "not implemented: disposeStorage" 76 | 77 | -- object 78 | addObject :: GLStorage -> String -> Primitive -> Maybe (IndexStream Buffer) -> Map String (Stream Buffer) -> [String] -> IO Object 79 | addObject input slotName prim indices attribs uniformNames = do 80 | let sch = schema input 81 | forM_ uniformNames $ \n -> case Map.lookup n (uniforms sch) of 82 | Nothing -> fail $ "Unknown uniform: " ++ show n 83 | _ -> return () 84 | case Map.lookup slotName (objectArrays sch) of 85 | Nothing -> fail $ "Unknown slot: " ++ show slotName 86 | Just (ObjectArraySchema sPrim sAttrs) -> do 87 | when (sPrim /= (primitiveToFetchPrimitive prim)) $ fail $ 88 | "Primitive mismatch for slot (" ++ show slotName ++ ") expected " ++ show sPrim ++ " but got " ++ show prim 89 | let sType = fmap streamToStreamType attribs 90 | when (sType /= sAttrs) $ fail $ unlines $ 91 | [ "Attribute stream mismatch for slot (" ++ show slotName ++ ") expected " 92 | , show sAttrs 93 | , " but got " 94 | , show sType 95 | ] 96 | 97 | let slotIdx = case slotName `Map.lookup` slotMap input of 98 | Nothing -> error $ "internal error (slot index): " ++ show slotName 99 | Just i -> i 100 | seed = objSeed input 101 | order <- newIORef 0 102 | enabled <- newIORef True 103 | index <- readIORef seed 104 | modifyIORef seed (1+) 105 | (setters,unis) <- mkUniform [(n,t) | n <- uniformNames, let t = fromMaybe (error $ "missing uniform: " ++ n) $ Map.lookup n (uniforms sch)] 106 | cmdsRef <- newIORef (V.singleton V.empty) 107 | let obj = Object 108 | { objSlot = slotIdx 109 | , objPrimitive = prim 110 | , objIndices = indices 111 | , objAttributes = attribs 112 | , objUniSetter = setters 113 | , objUniSetup = unis 114 | , objOrder = order 115 | , objEnabled = enabled 116 | , objId = index 117 | , objCommands = cmdsRef 118 | } 119 | 120 | modifyIORef' (slotVector input ! slotIdx) $ \(GLSlot objs _ _) -> GLSlot (IM.insert index obj objs) V.empty Generate 121 | 122 | -- generate GLObjectCommands for the new object 123 | {- 124 | foreach pipeline: 125 | foreach realted program: 126 | generate commands 127 | -} 128 | ppls <- readIORef $ pipelines input 129 | let topUnis = uniformSetup input 130 | cmds <- V.forM ppls $ \mp -> case mp of 131 | Nothing -> return V.empty 132 | Just p -> do 133 | Just ic <- readIORef $ glInput p 134 | case icSlotMapInputToPipeline ic ! slotIdx of 135 | Nothing -> do 136 | --putStrLn $ " ** slot is not used!" 137 | return V.empty -- this slot is not used in that pipeline 138 | Just pSlotIdx -> do 139 | --putStrLn "slot is used!" 140 | --where 141 | let emptyV = V.replicate (V.length $ glPrograms p) [] 142 | return $ emptyV // [(prgIdx,createObjectCommands (glTexUnitMapping p) topUnis obj (glPrograms p ! prgIdx))| prgIdx <- glSlotPrograms p ! pSlotIdx] 143 | writeIORef cmdsRef cmds 144 | return obj 145 | 146 | removeObject :: GLStorage -> Object -> IO () 147 | removeObject p obj = modifyIORef (slotVector p ! objSlot obj) $ \(GLSlot !objs _ _) -> GLSlot (IM.delete (objId obj) objs) V.empty Generate 148 | 149 | enableObject :: Object -> Bool -> IO () 150 | enableObject obj b = writeIORef (objEnabled obj) b 151 | 152 | setObjectOrder :: GLStorage -> Object -> Int -> IO () 153 | setObjectOrder p obj i = do 154 | writeIORef (objOrder obj) i 155 | modifyIORef (slotVector p ! objSlot obj) $ \(GLSlot objs sorted _) -> GLSlot objs sorted Reorder 156 | 157 | objectUniformSetter :: Object -> Map GLUniformName InputSetter 158 | objectUniformSetter = objUniSetter 159 | 160 | setScreenSize :: GLStorage -> Word -> Word -> IO () 161 | setScreenSize p w h = writeIORef (screenSize p) (w,h) 162 | 163 | sortSlotObjects :: GLStorage -> IO () 164 | sortSlotObjects p = V.forM_ (slotVector p) $ \slotRef -> do 165 | GLSlot objMap sortedV ord <- readIORef slotRef 166 | let cmpFun (a,_) (b,_) = a `compare` b 167 | doSort objs = do 168 | ordObjsM <- V.thaw objs 169 | I.sortBy cmpFun ordObjsM 170 | ordObjs <- V.freeze ordObjsM 171 | writeIORef slotRef (GLSlot objMap ordObjs Ordered) 172 | case ord of 173 | Ordered -> return () 174 | Generate -> do 175 | objs <- V.forM (V.fromList $ IM.elems objMap) $ \obj -> do 176 | ord <- readIORef $ objOrder obj 177 | return (ord,obj) 178 | doSort objs 179 | Reorder -> do 180 | objs <- V.forM sortedV $ \(_,obj) -> do 181 | ord <- readIORef $ objOrder obj 182 | return (ord,obj) 183 | doSort objs 184 | 185 | createObjectCommands :: Map String (IORef GLint) -> Map String GLUniform -> Object -> GLProgram -> [GLObjectCommand] 186 | createObjectCommands texUnitMap topUnis obj prg = objUniCmds ++ objStreamCmds ++ [objDrawCmd] 187 | where 188 | -- object draw command 189 | objDrawCmd = case objIndices obj of 190 | Nothing -> GLDrawArrays prim 0 (fromIntegral count) 191 | Just (IndexStream (Buffer arrs bo) arrIdx start idxCount) -> GLDrawElements prim (fromIntegral idxCount) idxType bo ptr 192 | where 193 | ArrayDesc arrType arrLen arrOffs arrSize = arrs ! arrIdx 194 | idxType = arrayTypeToGLType arrType 195 | ptr = intPtrToPtr $! fromIntegral (arrOffs + start * sizeOfArrayType arrType) 196 | where 197 | objAttrs = objAttributes obj 198 | prim = primitiveToGLType $ objPrimitive obj 199 | count = head [c | Stream _ _ _ _ c <- Map.elems objAttrs] 200 | 201 | -- object uniform commands 202 | -- texture slot setup commands 203 | objUniCmds = uniCmds ++ texCmds 204 | where 205 | uniCmds = [GLSetUniform i u | (n,i) <- uniMap, let u = Map.findWithDefault (topUni n) n objUnis] 206 | uniMap = Map.toList $ inputUniforms prg 207 | topUni n = Map.findWithDefault (error $ "internal error (createObjectCommands): " ++ show n) n topUnis 208 | objUnis = objUniSetup obj 209 | texUnis = S.toList $ inputTextureUniforms prg 210 | texCmds = [ GLBindTexture (inputTypeToTextureTarget $ uniInputType u) texUnit u 211 | | n <- texUnis 212 | , let u = Map.findWithDefault (topUni n) n objUnis 213 | , let texUnit = Map.findWithDefault (error $ "internal error (createObjectCommands - Texture Unit): " ++ show n) n texUnitMap 214 | ] 215 | uniInputType (GLUniform ty _) = ty 216 | 217 | -- object attribute stream commands 218 | objStreamCmds = [attrCmd i s | (i,name) <- Map.elems attrMap, let s = fromMaybe (error $ "missing attribute: " ++ name) $ Map.lookup name objAttrs] 219 | where 220 | attrMap = inputStreams prg 221 | objAttrs = objAttributes obj 222 | attrCmd i s = case s of 223 | Stream ty (Buffer arrs bo) arrIdx start len -> case ty of 224 | Attribute_Word -> setIntAttrib 1 225 | Attribute_V2U -> setIntAttrib 2 226 | Attribute_V3U -> setIntAttrib 3 227 | Attribute_V4U -> setIntAttrib 4 228 | Attribute_Int -> setIntAttrib 1 229 | Attribute_V2I -> setIntAttrib 2 230 | Attribute_V3I -> setIntAttrib 3 231 | Attribute_V4I -> setIntAttrib 4 232 | Attribute_Float -> setFloatAttrib 1 233 | Attribute_V2F -> setFloatAttrib 2 234 | Attribute_V3F -> setFloatAttrib 3 235 | Attribute_V4F -> setFloatAttrib 4 236 | Attribute_M22F -> setFloatAttrib 4 237 | Attribute_M23F -> setFloatAttrib 6 238 | Attribute_M24F -> setFloatAttrib 8 239 | Attribute_M32F -> setFloatAttrib 6 240 | Attribute_M33F -> setFloatAttrib 9 241 | Attribute_M34F -> setFloatAttrib 12 242 | Attribute_M42F -> setFloatAttrib 8 243 | Attribute_M43F -> setFloatAttrib 12 244 | Attribute_M44F -> setFloatAttrib 16 245 | where 246 | setFloatAttrib n = GLSetVertexAttribArray i bo n glType (ptr n) 247 | setIntAttrib n = GLSetVertexAttribIArray i bo n glType (ptr n) 248 | ArrayDesc arrType arrLen arrOffs arrSize = arrs ! arrIdx 249 | glType = arrayTypeToGLType arrType 250 | ptr compCnt = intPtrToPtr $! fromIntegral (arrOffs + start * fromIntegral compCnt * sizeOfArrayType arrType) 251 | 252 | -- constant generic attribute 253 | constAttr -> GLSetVertexAttrib i constAttr 254 | 255 | nullSetter :: GLUniformName -> String -> a -> IO () 256 | nullSetter n t _ = return () 257 | --nullSetter n t _ = Prelude.putStrLn $ "WARNING: unknown uniform: " ++ show n ++ " :: " ++ t 258 | 259 | uniformBool :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun Bool 260 | uniformV2B :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun V2B 261 | uniformV3B :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun V3B 262 | uniformV4B :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun V4B 263 | 264 | uniformWord :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun Word32 265 | uniformV2U :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun V2U 266 | uniformV3U :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun V3U 267 | uniformV4U :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun V4U 268 | 269 | uniformInt :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun Int32 270 | uniformV2I :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun V2I 271 | uniformV3I :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun V3I 272 | uniformV4I :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun V4I 273 | 274 | uniformFloat :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun Float 275 | uniformV2F :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun V2F 276 | uniformV3F :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun V3F 277 | uniformV4F :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun V4F 278 | 279 | uniformM22F :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun M22F 280 | uniformM23F :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun M23F 281 | uniformM24F :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun M24F 282 | uniformM32F :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun M32F 283 | uniformM33F :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun M33F 284 | uniformM34F :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun M34F 285 | uniformM42F :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun M42F 286 | uniformM43F :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun M43F 287 | uniformM44F :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun M44F 288 | 289 | uniformFTexture2D :: GLUniformName -> Map GLUniformName InputSetter -> SetterFun TextureData 290 | 291 | uniformBool n is = case Map.lookup n is of 292 | Just (SBool fun) -> fun 293 | _ -> nullSetter n "Bool" 294 | 295 | uniformV2B n is = case Map.lookup n is of 296 | Just (SV2B fun) -> fun 297 | _ -> nullSetter n "V2B" 298 | 299 | uniformV3B n is = case Map.lookup n is of 300 | Just (SV3B fun) -> fun 301 | _ -> nullSetter n "V3B" 302 | 303 | uniformV4B n is = case Map.lookup n is of 304 | Just (SV4B fun) -> fun 305 | _ -> nullSetter n "V4B" 306 | 307 | uniformWord n is = case Map.lookup n is of 308 | Just (SWord fun) -> fun 309 | _ -> nullSetter n "Word" 310 | 311 | uniformV2U n is = case Map.lookup n is of 312 | Just (SV2U fun) -> fun 313 | _ -> nullSetter n "V2U" 314 | 315 | uniformV3U n is = case Map.lookup n is of 316 | Just (SV3U fun) -> fun 317 | _ -> nullSetter n "V3U" 318 | 319 | uniformV4U n is = case Map.lookup n is of 320 | Just (SV4U fun) -> fun 321 | _ -> nullSetter n "V4U" 322 | 323 | uniformInt n is = case Map.lookup n is of 324 | Just (SInt fun) -> fun 325 | _ -> nullSetter n "Int" 326 | 327 | uniformV2I n is = case Map.lookup n is of 328 | Just (SV2I fun) -> fun 329 | _ -> nullSetter n "V2I" 330 | 331 | uniformV3I n is = case Map.lookup n is of 332 | Just (SV3I fun) -> fun 333 | _ -> nullSetter n "V3I" 334 | 335 | uniformV4I n is = case Map.lookup n is of 336 | Just (SV4I fun) -> fun 337 | _ -> nullSetter n "V4I" 338 | 339 | uniformFloat n is = case Map.lookup n is of 340 | Just (SFloat fun) -> fun 341 | _ -> nullSetter n "Float" 342 | 343 | uniformV2F n is = case Map.lookup n is of 344 | Just (SV2F fun) -> fun 345 | _ -> nullSetter n "V2F" 346 | 347 | uniformV3F n is = case Map.lookup n is of 348 | Just (SV3F fun) -> fun 349 | _ -> nullSetter n "V3F" 350 | 351 | uniformV4F n is = case Map.lookup n is of 352 | Just (SV4F fun) -> fun 353 | _ -> nullSetter n "V4F" 354 | 355 | uniformM22F n is = case Map.lookup n is of 356 | Just (SM22F fun) -> fun 357 | _ -> nullSetter n "M22F" 358 | 359 | uniformM23F n is = case Map.lookup n is of 360 | Just (SM23F fun) -> fun 361 | _ -> nullSetter n "M23F" 362 | 363 | uniformM24F n is = case Map.lookup n is of 364 | Just (SM24F fun) -> fun 365 | _ -> nullSetter n "M24F" 366 | 367 | uniformM32F n is = case Map.lookup n is of 368 | Just (SM32F fun) -> fun 369 | _ -> nullSetter n "M32F" 370 | 371 | uniformM33F n is = case Map.lookup n is of 372 | Just (SM33F fun) -> fun 373 | _ -> nullSetter n "M33F" 374 | 375 | uniformM34F n is = case Map.lookup n is of 376 | Just (SM34F fun) -> fun 377 | _ -> nullSetter n "M34F" 378 | 379 | uniformM42F n is = case Map.lookup n is of 380 | Just (SM42F fun) -> fun 381 | _ -> nullSetter n "M42F" 382 | 383 | uniformM43F n is = case Map.lookup n is of 384 | Just (SM43F fun) -> fun 385 | _ -> nullSetter n "M43F" 386 | 387 | uniformM44F n is = case Map.lookup n is of 388 | Just (SM44F fun) -> fun 389 | _ -> nullSetter n "M44F" 390 | 391 | uniformFTexture2D n is = case Map.lookup n is of 392 | Just (SFTexture2D fun) -> fun 393 | _ -> nullSetter n "FTexture2D" 394 | 395 | type UniM = Writer [Map GLUniformName InputSetter -> IO ()] 396 | 397 | class UniformSetter a where 398 | (@=) :: GLUniformName -> IO a -> UniM () 399 | 400 | setUniM setUni n act = tell [\s -> let f = setUni n s in f =<< act] 401 | 402 | instance UniformSetter Bool where (@=) = setUniM uniformBool 403 | instance UniformSetter V2B where (@=) = setUniM uniformV2B 404 | instance UniformSetter V3B where (@=) = setUniM uniformV3B 405 | instance UniformSetter V4B where (@=) = setUniM uniformV4B 406 | instance UniformSetter Word32 where (@=) = setUniM uniformWord 407 | instance UniformSetter V2U where (@=) = setUniM uniformV2U 408 | instance UniformSetter V3U where (@=) = setUniM uniformV3U 409 | instance UniformSetter V4U where (@=) = setUniM uniformV4U 410 | instance UniformSetter Int32 where (@=) = setUniM uniformInt 411 | instance UniformSetter V2I where (@=) = setUniM uniformV2I 412 | instance UniformSetter V3I where (@=) = setUniM uniformV3I 413 | instance UniformSetter V4I where (@=) = setUniM uniformV4I 414 | instance UniformSetter Float where (@=) = setUniM uniformFloat 415 | instance UniformSetter V2F where (@=) = setUniM uniformV2F 416 | instance UniformSetter V3F where (@=) = setUniM uniformV3F 417 | instance UniformSetter V4F where (@=) = setUniM uniformV4F 418 | instance UniformSetter M22F where (@=) = setUniM uniformM22F 419 | instance UniformSetter M23F where (@=) = setUniM uniformM23F 420 | instance UniformSetter M24F where (@=) = setUniM uniformM24F 421 | instance UniformSetter M32F where (@=) = setUniM uniformM32F 422 | instance UniformSetter M33F where (@=) = setUniM uniformM33F 423 | instance UniformSetter M34F where (@=) = setUniM uniformM34F 424 | instance UniformSetter M42F where (@=) = setUniM uniformM42F 425 | instance UniformSetter M43F where (@=) = setUniM uniformM43F 426 | instance UniformSetter M44F where (@=) = setUniM uniformM44F 427 | instance UniformSetter TextureData where (@=) = setUniM uniformFTexture2D 428 | 429 | updateUniforms storage m = sequence_ l where 430 | setters = uniformSetter storage 431 | l = map ($ setters) $ execWriter m 432 | 433 | updateObjectUniforms object m = sequence_ l where 434 | setters = objectUniformSetter object 435 | l = map ($ setters) $ execWriter m 436 | -------------------------------------------------------------------------------- /src/LambdaCube/GL/Util.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | module LambdaCube.GL.Util ( 3 | queryUniforms, 4 | queryStreams, 5 | mkUniformSetter, 6 | setUniform, 7 | setVertexAttrib, 8 | compileShader, 9 | printProgramLog, 10 | glGetShaderiv1, 11 | glGetProgramiv1, 12 | Buffer(..), 13 | ArrayDesc(..), 14 | StreamSetter, 15 | streamToInputType, 16 | arrayTypeToGLType, 17 | comparisonFunctionToGLType, 18 | logicOperationToGLType, 19 | blendEquationToGLType, 20 | blendingFactorToGLType, 21 | checkGL, 22 | textureDataTypeToGLType, 23 | textureDataTypeToGLArityType, 24 | glGetIntegerv1, 25 | setSampler, 26 | checkFBO, 27 | compileSampler, 28 | compileTexture, 29 | primitiveToFetchPrimitive, 30 | primitiveToGLType, 31 | inputTypeToTextureTarget 32 | ) where 33 | 34 | import Control.Applicative 35 | import Control.Exception 36 | import Control.Monad 37 | import Data.IORef 38 | import Data.List as L 39 | import Foreign 40 | import Foreign.C.String 41 | import qualified Data.Vector as V 42 | import Data.Vector.Unboxed.Mutable (IOVector) 43 | import qualified Data.Vector.Unboxed.Mutable as MV 44 | import Data.Map (Map) 45 | import qualified Data.Map as Map 46 | 47 | import Graphics.GL.Core33 48 | import LambdaCube.Linear 49 | import LambdaCube.IR 50 | import LambdaCube.PipelineSchema 51 | import LambdaCube.GL.Type 52 | 53 | setSampler :: GLint -> Int32 -> IO () 54 | setSampler i v = glUniform1i i $ fromIntegral v 55 | 56 | z2 = V2 0 0 :: V2F 57 | z3 = V3 0 0 0 :: V3F 58 | z4 = V4 0 0 0 0 :: V4F 59 | 60 | -- uniform functions 61 | queryUniforms :: GLuint -> IO (Map String GLint, Map String InputType) 62 | queryUniforms po = do 63 | ul <- getNameTypeSize po glGetActiveUniform glGetUniformLocation GL_ACTIVE_UNIFORMS GL_ACTIVE_UNIFORM_MAX_LENGTH 64 | let uNames = [n | (n,_,_,_) <- ul] 65 | uTypes = [fromGLType (e,s) | (_,_,e,s) <- ul] 66 | uLocation = [i | (_,i,_,_) <- ul] 67 | return $! (Map.fromList $! zip uNames uLocation, Map.fromList $! zip uNames uTypes) 68 | 69 | b2w :: Bool -> GLuint 70 | b2w True = 1 71 | b2w False = 0 72 | 73 | mkUniformSetter :: InputType -> IO (GLUniform, InputSetter) 74 | mkUniformSetter t@Bool = do {r <- newIORef 0; return $! (GLUniform t r, SBool $! writeIORef r . b2w)} 75 | mkUniformSetter t@V2B = do {r <- newIORef (V2 0 0); return $! (GLUniform t r, SV2B $! writeIORef r . fmap b2w)} 76 | mkUniformSetter t@V3B = do {r <- newIORef (V3 0 0 0); return $! (GLUniform t r, SV3B $! writeIORef r . fmap b2w)} 77 | mkUniformSetter t@V4B = do {r <- newIORef (V4 0 0 0 0); return $! (GLUniform t r, SV4B $! writeIORef r . fmap b2w)} 78 | mkUniformSetter t@Word = do {r <- newIORef 0; return $! (GLUniform t r, SWord $! writeIORef r)} 79 | mkUniformSetter t@V2U = do {r <- newIORef (V2 0 0); return $! (GLUniform t r, SV2U $! writeIORef r)} 80 | mkUniformSetter t@V3U = do {r <- newIORef (V3 0 0 0); return $! (GLUniform t r, SV3U $! writeIORef r)} 81 | mkUniformSetter t@V4U = do {r <- newIORef (V4 0 0 0 0); return $! (GLUniform t r, SV4U $! writeIORef r)} 82 | mkUniformSetter t@Int = do {r <- newIORef 0; return $! (GLUniform t r, SInt $! writeIORef r)} 83 | mkUniformSetter t@V2I = do {r <- newIORef (V2 0 0); return $! (GLUniform t r, SV2I $! writeIORef r)} 84 | mkUniformSetter t@V3I = do {r <- newIORef (V3 0 0 0); return $! (GLUniform t r, SV3I $! writeIORef r)} 85 | mkUniformSetter t@V4I = do {r <- newIORef (V4 0 0 0 0); return $! (GLUniform t r, SV4I $! writeIORef r)} 86 | mkUniformSetter t@Float = do {r <- newIORef 0; return $! (GLUniform t r, SFloat $! writeIORef r)} 87 | mkUniformSetter t@V2F = do {r <- newIORef (V2 0 0); return $! (GLUniform t r, SV2F $! writeIORef r)} 88 | mkUniformSetter t@V3F = do {r <- newIORef (V3 0 0 0); return $! (GLUniform t r, SV3F $! writeIORef r)} 89 | mkUniformSetter t@V4F = do {r <- newIORef (V4 0 0 0 0); return $! (GLUniform t r, SV4F $! writeIORef r)} 90 | mkUniformSetter t@M22F = do {r <- newIORef (V2 z2 z2); return $! (GLUniform t r, SM22F $! writeIORef r)} 91 | mkUniformSetter t@M23F = do {r <- newIORef (V3 z2 z2 z2); return $! (GLUniform t r, SM23F $! writeIORef r)} 92 | mkUniformSetter t@M24F = do {r <- newIORef (V4 z2 z2 z2 z2); return $! (GLUniform t r, SM24F $! writeIORef r)} 93 | mkUniformSetter t@M32F = do {r <- newIORef (V2 z3 z3); return $! (GLUniform t r, SM32F $! writeIORef r)} 94 | mkUniformSetter t@M33F = do {r <- newIORef (V3 z3 z3 z3); return $! (GLUniform t r, SM33F $! writeIORef r)} 95 | mkUniformSetter t@M34F = do {r <- newIORef (V4 z3 z3 z3 z3); return $! (GLUniform t r, SM34F $! writeIORef r)} 96 | mkUniformSetter t@M42F = do {r <- newIORef (V2 z4 z4); return $! (GLUniform t r, SM42F $! writeIORef r)} 97 | mkUniformSetter t@M43F = do {r <- newIORef (V3 z4 z4 z4); return $! (GLUniform t r, SM43F $! writeIORef r)} 98 | mkUniformSetter t@M44F = do {r <- newIORef (V4 z4 z4 z4 z4); return $! (GLUniform t r, SM44F $! writeIORef r)} 99 | mkUniformSetter t@FTexture2D = do {r <- newIORef (TextureData 0); return $! (GLUniform t r, SFTexture2D $! writeIORef r)} 100 | 101 | -- sets value based uniforms only (does not handle textures) 102 | setUniform :: Storable a => GLint -> InputType -> IORef a -> IO () 103 | setUniform i ty ref = do 104 | v <- readIORef ref 105 | let false = fromIntegral GL_FALSE 106 | with v $ \p -> case ty of 107 | Bool -> glUniform1uiv i 1 (castPtr p) 108 | V2B -> glUniform2uiv i 1 (castPtr p) 109 | V3B -> glUniform3uiv i 1 (castPtr p) 110 | V4B -> glUniform4uiv i 1 (castPtr p) 111 | Word -> glUniform1uiv i 1 (castPtr p) 112 | V2U -> glUniform2uiv i 1 (castPtr p) 113 | V3U -> glUniform3uiv i 1 (castPtr p) 114 | V4U -> glUniform4uiv i 1 (castPtr p) 115 | Int -> glUniform1iv i 1 (castPtr p) 116 | V2I -> glUniform2iv i 1 (castPtr p) 117 | V3I -> glUniform3iv i 1 (castPtr p) 118 | V4I -> glUniform4iv i 1 (castPtr p) 119 | Float -> glUniform1fv i 1 (castPtr p) 120 | V2F -> glUniform2fv i 1 (castPtr p) 121 | V3F -> glUniform3fv i 1 (castPtr p) 122 | V4F -> glUniform4fv i 1 (castPtr p) 123 | M22F -> glUniformMatrix2fv i 1 false (castPtr p) 124 | M23F -> glUniformMatrix2x3fv i 1 false (castPtr p) 125 | M24F -> glUniformMatrix2x4fv i 1 false (castPtr p) 126 | M32F -> glUniformMatrix3x2fv i 1 false (castPtr p) 127 | M33F -> glUniformMatrix3fv i 1 false (castPtr p) 128 | M34F -> glUniformMatrix3x4fv i 1 false (castPtr p) 129 | M42F -> glUniformMatrix4x2fv i 1 false (castPtr p) 130 | M43F -> glUniformMatrix4x3fv i 1 false (castPtr p) 131 | M44F -> glUniformMatrix4fv i 1 false (castPtr p) 132 | FTexture2D -> return () --putStrLn $ "TODO: setUniform FTexture2D" 133 | _ -> fail $ "internal error (setUniform)! - " ++ show ty 134 | 135 | -- attribute functions 136 | queryStreams :: GLuint -> IO (Map String GLuint, Map String InputType) 137 | queryStreams po = do 138 | al <- getNameTypeSize po glGetActiveAttrib glGetAttribLocation GL_ACTIVE_ATTRIBUTES GL_ACTIVE_ATTRIBUTE_MAX_LENGTH 139 | let aNames = [n | (n,_,_,_) <- al] 140 | aTypes = [fromGLType (e,s) | (_,_,e,s) <- al] 141 | aLocation = [fromIntegral i | (_,i,_,_) <- al] 142 | return $! (Map.fromList $! zip aNames aLocation, Map.fromList $! zip aNames aTypes) 143 | 144 | arrayTypeToGLType :: ArrayType -> GLenum 145 | arrayTypeToGLType a = case a of 146 | ArrWord8 -> GL_UNSIGNED_BYTE 147 | ArrWord16 -> GL_UNSIGNED_SHORT 148 | ArrWord32 -> GL_UNSIGNED_INT 149 | ArrInt8 -> GL_BYTE 150 | ArrInt16 -> GL_SHORT 151 | ArrInt32 -> GL_INT 152 | ArrFloat -> GL_FLOAT 153 | ArrHalf -> GL_HALF_FLOAT 154 | 155 | setVertexAttrib :: GLuint -> Stream Buffer -> IO () 156 | setVertexAttrib i val = case val of 157 | ConstWord v -> with v $! \p -> glVertexAttribI1uiv i $! castPtr p 158 | ConstV2U v -> with v $! \p -> glVertexAttribI2uiv i $! castPtr p 159 | ConstV3U v -> with v $! \p -> glVertexAttribI3uiv i $! castPtr p 160 | ConstV4U v -> with v $! \p -> glVertexAttribI4uiv i $! castPtr p 161 | ConstInt v -> with v $! \p -> glVertexAttribI1iv i $! castPtr p 162 | ConstV2I v -> with v $! \p -> glVertexAttribI2iv i $! castPtr p 163 | ConstV3I v -> with v $! \p -> glVertexAttribI3iv i $! castPtr p 164 | ConstV4I v -> with v $! \p -> glVertexAttribI4iv i $! castPtr p 165 | ConstFloat v -> setAFloat i v 166 | ConstV2F v -> setAV2F i v 167 | ConstV3F v -> setAV3F i v 168 | ConstV4F v -> setAV4F i v 169 | ConstM22F (V2 x y) -> setAV2F i x >> setAV2F (i+1) y 170 | ConstM23F (V3 x y z) -> setAV2F i x >> setAV2F (i+1) y >> setAV2F (i+2) z 171 | ConstM24F (V4 x y z w) -> setAV2F i x >> setAV2F (i+1) y >> setAV2F (i+2) z >> setAV2F (i+3) w 172 | ConstM32F (V2 x y) -> setAV3F i x >> setAV3F (i+1) y 173 | ConstM33F (V3 x y z) -> setAV3F i x >> setAV3F (i+1) y >> setAV3F (i+2) z 174 | ConstM34F (V4 x y z w) -> setAV3F i x >> setAV3F (i+1) y >> setAV3F (i+2) z >> setAV3F (i+3) w 175 | ConstM42F (V2 x y) -> setAV4F i x >> setAV4F (i+1) y 176 | ConstM43F (V3 x y z) -> setAV4F i x >> setAV4F (i+1) y >> setAV4F (i+2) z 177 | ConstM44F (V4 x y z w) -> setAV4F i x >> setAV4F (i+1) y >> setAV4F (i+2) z >> setAV4F (i+3) w 178 | _ -> fail "internal error (setVertexAttrib)!" 179 | 180 | setAFloat :: GLuint -> Float -> IO () 181 | setAV2F :: GLuint -> V2F -> IO () 182 | setAV3F :: GLuint -> V3F -> IO () 183 | setAV4F :: GLuint -> V4F -> IO () 184 | setAFloat i v = with v $! \p -> glVertexAttrib1fv i $! castPtr p 185 | setAV2F i v = with v $! \p -> glVertexAttrib2fv i $! castPtr p 186 | setAV3F i v = with v $! \p -> glVertexAttrib3fv i $! castPtr p 187 | setAV4F i v = with v $! \p -> glVertexAttrib4fv i $! castPtr p 188 | 189 | -- result list: [(name string,location,gl type,component count)] 190 | getNameTypeSize :: GLuint -> (GLuint -> GLuint -> GLsizei -> Ptr GLsizei -> Ptr GLint -> Ptr GLenum -> Ptr GLchar -> IO ()) 191 | -> (GLuint -> Ptr GLchar -> IO GLint) -> GLenum -> GLenum -> IO [(String,GLint,GLenum,GLint)] 192 | getNameTypeSize o f g enum enumLen = do 193 | nameLen <- glGetProgramiv1 enumLen o 194 | allocaArray (fromIntegral nameLen) $! \namep -> alloca $! \sizep -> alloca $! \typep -> do 195 | n <- glGetProgramiv1 enum o 196 | forM [0..n-1] $! \i -> f o (fromIntegral i) (fromIntegral nameLen) nullPtr sizep typep namep >> 197 | (,,,) <$> peekCString (castPtr namep) <*> g o namep <*> peek typep <*> peek sizep 198 | 199 | fromGLType :: (GLenum,GLint) -> InputType 200 | fromGLType (t,1) 201 | | t == GL_BOOL = Bool 202 | | t == GL_BOOL_VEC2 = V2B 203 | | t == GL_BOOL_VEC3 = V3B 204 | | t == GL_BOOL_VEC4 = V4B 205 | | t == GL_UNSIGNED_INT = Word 206 | | t == GL_UNSIGNED_INT_VEC2 = V2U 207 | | t == GL_UNSIGNED_INT_VEC3 = V3U 208 | | t == GL_UNSIGNED_INT_VEC4 = V4U 209 | | t == GL_INT = Int 210 | | t == GL_INT_VEC2 = V2I 211 | | t == GL_INT_VEC3 = V3I 212 | | t == GL_INT_VEC4 = V4I 213 | | t == GL_FLOAT = Float 214 | | t == GL_FLOAT_VEC2 = V2F 215 | | t == GL_FLOAT_VEC3 = V3F 216 | | t == GL_FLOAT_VEC4 = V4F 217 | | t == GL_FLOAT_MAT2 = M22F 218 | | t == GL_FLOAT_MAT2x3 = M23F 219 | | t == GL_FLOAT_MAT2x4 = M24F 220 | | t == GL_FLOAT_MAT3x2 = M32F 221 | | t == GL_FLOAT_MAT3 = M33F 222 | | t == GL_FLOAT_MAT3x4 = M34F 223 | | t == GL_FLOAT_MAT4x2 = M42F 224 | | t == GL_FLOAT_MAT4x3 = M43F 225 | | t == GL_FLOAT_MAT4 = M44F 226 | | t == GL_SAMPLER_1D_ARRAY_SHADOW = STexture1DArray 227 | | t == GL_SAMPLER_1D_SHADOW = STexture1D 228 | | t == GL_SAMPLER_2D_ARRAY_SHADOW = STexture2DArray 229 | | t == GL_SAMPLER_2D_RECT_SHADOW = STexture2DRect 230 | | t == GL_SAMPLER_2D_SHADOW = STexture2D 231 | | t == GL_SAMPLER_CUBE_SHADOW = STextureCube 232 | | t == GL_INT_SAMPLER_1D = ITexture1D 233 | | t == GL_INT_SAMPLER_1D_ARRAY = ITexture1DArray 234 | | t == GL_INT_SAMPLER_2D = ITexture2D 235 | | t == GL_INT_SAMPLER_2D_ARRAY = ITexture2DArray 236 | | t == GL_INT_SAMPLER_2D_MULTISAMPLE = ITexture2DMS 237 | | t == GL_INT_SAMPLER_2D_MULTISAMPLE_ARRAY = ITexture2DMSArray 238 | | t == GL_INT_SAMPLER_2D_RECT = ITexture2DRect 239 | | t == GL_INT_SAMPLER_3D = ITexture3D 240 | | t == GL_INT_SAMPLER_BUFFER = ITextureBuffer 241 | | t == GL_INT_SAMPLER_CUBE = ITextureCube 242 | | t == GL_SAMPLER_1D = FTexture1D 243 | | t == GL_SAMPLER_1D_ARRAY = FTexture1DArray 244 | | t == GL_SAMPLER_2D = FTexture2D 245 | | t == GL_SAMPLER_2D_ARRAY = FTexture2DArray 246 | | t == GL_SAMPLER_2D_MULTISAMPLE = FTexture2DMS 247 | | t == GL_SAMPLER_2D_MULTISAMPLE_ARRAY = FTexture2DMSArray 248 | | t == GL_SAMPLER_2D_RECT = FTexture2DRect 249 | | t == GL_SAMPLER_3D = FTexture3D 250 | | t == GL_SAMPLER_BUFFER = FTextureBuffer 251 | | t == GL_SAMPLER_CUBE = FTextureCube 252 | | t == GL_UNSIGNED_INT_SAMPLER_1D = UTexture1D 253 | | t == GL_UNSIGNED_INT_SAMPLER_1D_ARRAY = UTexture1DArray 254 | | t == GL_UNSIGNED_INT_SAMPLER_2D = UTexture2D 255 | | t == GL_UNSIGNED_INT_SAMPLER_2D_ARRAY = UTexture2DArray 256 | | t == GL_UNSIGNED_INT_SAMPLER_2D_MULTISAMPLE = UTexture2DMS 257 | | t == GL_UNSIGNED_INT_SAMPLER_2D_MULTISAMPLE_ARRAY = UTexture2DMSArray 258 | | t == GL_UNSIGNED_INT_SAMPLER_2D_RECT = UTexture2DRect 259 | | t == GL_UNSIGNED_INT_SAMPLER_3D = UTexture3D 260 | | t == GL_UNSIGNED_INT_SAMPLER_BUFFER = UTextureBuffer 261 | | t == GL_UNSIGNED_INT_SAMPLER_CUBE = UTextureCube 262 | | otherwise = error "Failed fromGLType" 263 | fromGLUniformType _ = error "Failed fromGLType" 264 | 265 | printShaderLog :: GLuint -> IO String 266 | printShaderLog o = do 267 | i <- glGetShaderiv1 GL_INFO_LOG_LENGTH o 268 | case (i > 0) of 269 | False -> return "" 270 | True -> do 271 | alloca $ \sizePtr -> allocaArray (fromIntegral i) $! \ps -> do 272 | glGetShaderInfoLog o (fromIntegral i) sizePtr ps 273 | size <- peek sizePtr 274 | log <- peekCStringLen (castPtr ps, fromIntegral size) 275 | putStrLn log 276 | return log 277 | 278 | glGetShaderiv1 :: GLenum -> GLuint -> IO GLint 279 | glGetShaderiv1 pname o = alloca $! \pi -> glGetShaderiv o pname pi >> peek pi 280 | 281 | glGetProgramiv1 :: GLenum -> GLuint -> IO GLint 282 | glGetProgramiv1 pname o = alloca $! \pi -> glGetProgramiv o pname pi >> peek pi 283 | 284 | printProgramLog :: GLuint -> IO String 285 | printProgramLog o = do 286 | i <- glGetProgramiv1 GL_INFO_LOG_LENGTH o 287 | case (i > 0) of 288 | False -> return "" 289 | True -> do 290 | alloca $ \sizePtr -> allocaArray (fromIntegral i) $! \ps -> do 291 | glGetProgramInfoLog o (fromIntegral i) sizePtr ps 292 | size <- peek sizePtr 293 | log <- peekCStringLen (castPtr ps, fromIntegral size) 294 | unless (null log) $ putStrLn log 295 | return log 296 | 297 | compileShader :: GLuint -> [String] -> IO () 298 | compileShader o srcl = withMany withCString srcl $! \l -> withArray l $! \p -> do 299 | glShaderSource o (fromIntegral $! length srcl) (castPtr p) nullPtr 300 | glCompileShader o 301 | log <- printShaderLog o 302 | status <- glGetShaderiv1 GL_COMPILE_STATUS o 303 | when (status /= fromIntegral GL_TRUE) $ fail $ unlines ["compileShader failed:",log] 304 | 305 | checkGL :: IO String 306 | checkGL = do 307 | let f e | e == GL_INVALID_ENUM = "INVALID_ENUM" 308 | | e == GL_INVALID_VALUE = "INVALID_VALUE" 309 | | e == GL_INVALID_OPERATION = "INVALID_OPERATION" 310 | | e == GL_INVALID_FRAMEBUFFER_OPERATION = "INVALID_FRAMEBUFFER_OPERATION" 311 | | e == GL_OUT_OF_MEMORY = "OUT_OF_MEMORY" 312 | | e == GL_NO_ERROR = "OK" 313 | | otherwise = "Unknown error" 314 | e <- glGetError 315 | return $ f e 316 | 317 | streamToInputType :: Stream Buffer -> InputType 318 | streamToInputType s = case s of 319 | ConstWord _ -> Word 320 | ConstV2U _ -> V2U 321 | ConstV3U _ -> V3U 322 | ConstV4U _ -> V4U 323 | ConstInt _ -> Int 324 | ConstV2I _ -> V2I 325 | ConstV3I _ -> V3I 326 | ConstV4I _ -> V4I 327 | ConstFloat _ -> Float 328 | ConstV2F _ -> V2F 329 | ConstV3F _ -> V3F 330 | ConstV4F _ -> V4F 331 | ConstM22F _ -> M22F 332 | ConstM23F _ -> M23F 333 | ConstM24F _ -> M24F 334 | ConstM32F _ -> M32F 335 | ConstM33F _ -> M33F 336 | ConstM34F _ -> M34F 337 | ConstM42F _ -> M42F 338 | ConstM43F _ -> M43F 339 | ConstM44F _ -> M44F 340 | Stream t (Buffer a _) i _ _ 341 | | 0 <= i && i < V.length a && 342 | if elem t integralTypes then elem at integralArrTypes else True 343 | -> fromStreamType t 344 | | otherwise -> error "streamToInputType failed" 345 | where 346 | at = arrType $! (a V.! i) 347 | integralTypes = [Attribute_Word, Attribute_V2U, Attribute_V3U, Attribute_V4U, Attribute_Int, Attribute_V2I, Attribute_V3I, Attribute_V4I] 348 | integralArrTypes = [ArrWord8, ArrWord16, ArrWord32, ArrInt8, ArrInt16, ArrInt32] 349 | 350 | comparisonFunctionToGLType :: ComparisonFunction -> GLenum 351 | comparisonFunctionToGLType a = case a of 352 | Always -> GL_ALWAYS 353 | Equal -> GL_EQUAL 354 | Gequal -> GL_GEQUAL 355 | Greater -> GL_GREATER 356 | Lequal -> GL_LEQUAL 357 | Less -> GL_LESS 358 | Never -> GL_NEVER 359 | Notequal -> GL_NOTEQUAL 360 | 361 | logicOperationToGLType :: LogicOperation -> GLenum 362 | logicOperationToGLType a = case a of 363 | And -> GL_AND 364 | AndInverted -> GL_AND_INVERTED 365 | AndReverse -> GL_AND_REVERSE 366 | Clear -> GL_CLEAR 367 | Copy -> GL_COPY 368 | CopyInverted -> GL_COPY_INVERTED 369 | Equiv -> GL_EQUIV 370 | Invert -> GL_INVERT 371 | Nand -> GL_NAND 372 | Noop -> GL_NOOP 373 | Nor -> GL_NOR 374 | Or -> GL_OR 375 | OrInverted -> GL_OR_INVERTED 376 | OrReverse -> GL_OR_REVERSE 377 | Set -> GL_SET 378 | Xor -> GL_XOR 379 | 380 | blendEquationToGLType :: BlendEquation -> GLenum 381 | blendEquationToGLType a = case a of 382 | FuncAdd -> GL_FUNC_ADD 383 | FuncReverseSubtract -> GL_FUNC_REVERSE_SUBTRACT 384 | FuncSubtract -> GL_FUNC_SUBTRACT 385 | Max -> GL_MAX 386 | Min -> GL_MIN 387 | 388 | blendingFactorToGLType :: BlendingFactor -> GLenum 389 | blendingFactorToGLType a = case a of 390 | ConstantAlpha -> GL_CONSTANT_ALPHA 391 | ConstantColor -> GL_CONSTANT_COLOR 392 | DstAlpha -> GL_DST_ALPHA 393 | DstColor -> GL_DST_COLOR 394 | One -> GL_ONE 395 | OneMinusConstantAlpha -> GL_ONE_MINUS_CONSTANT_ALPHA 396 | OneMinusConstantColor -> GL_ONE_MINUS_CONSTANT_COLOR 397 | OneMinusDstAlpha -> GL_ONE_MINUS_DST_ALPHA 398 | OneMinusDstColor -> GL_ONE_MINUS_DST_COLOR 399 | OneMinusSrcAlpha -> GL_ONE_MINUS_SRC_ALPHA 400 | OneMinusSrcColor -> GL_ONE_MINUS_SRC_COLOR 401 | SrcAlpha -> GL_SRC_ALPHA 402 | SrcAlphaSaturate -> GL_SRC_ALPHA_SATURATE 403 | SrcColor -> GL_SRC_COLOR 404 | Zero -> GL_ZERO 405 | 406 | -- XXX: we need to extend IR.TextureDescriptor to carry component bit depth 407 | -- if we want to avoid making arbitrary decisions here 408 | textureDataTypeToGLType :: ImageSemantic -> TextureDataType -> GLenum 409 | textureDataTypeToGLType Color a = case a of 410 | FloatT Red -> GL_R32F 411 | IntT Red -> GL_R32I 412 | WordT Red -> GL_R32UI 413 | FloatT RG -> GL_RG32F 414 | IntT RG -> GL_RG32I 415 | WordT RG -> GL_RG32UI 416 | FloatT RGBA -> GL_RGBA32F 417 | IntT RGBA -> GL_RGBA8I 418 | WordT RGBA -> GL_RGBA8UI 419 | a -> error $ "FIXME: This texture format is not yet supported" ++ show a 420 | textureDataTypeToGLType Depth a = case a of 421 | FloatT Red -> GL_DEPTH_COMPONENT32F 422 | WordT Red -> GL_DEPTH_COMPONENT32 423 | a -> error $ "FIXME: This texture format is not yet supported" ++ show a 424 | textureDataTypeToGLType Stencil a = case a of 425 | a -> error $ "FIXME: This texture format is not yet supported" ++ show a 426 | 427 | textureDataTypeToGLArityType :: ImageSemantic -> TextureDataType -> GLenum 428 | textureDataTypeToGLArityType Color a = case a of 429 | FloatT Red -> GL_RED 430 | IntT Red -> GL_RED_INTEGER 431 | WordT Red -> GL_RED_INTEGER 432 | FloatT RG -> GL_RG 433 | IntT RG -> GL_RG_INTEGER 434 | WordT RG -> GL_RG_INTEGER 435 | FloatT RGBA -> GL_RGBA 436 | IntT RGBA -> GL_RGBA_INTEGER 437 | WordT RGBA -> GL_RGBA_INTEGER 438 | a -> error $ "FIXME: This texture format is not yet supported" ++ show a 439 | textureDataTypeToGLArityType Depth a = case a of 440 | FloatT Red -> GL_DEPTH_COMPONENT 441 | WordT Red -> GL_DEPTH_COMPONENT 442 | a -> error $ "FIXME: This texture format is not yet supported" ++ show a 443 | textureDataTypeToGLArityType Stencil a = case a of 444 | a -> error $ "FIXME: This texture format is not yet supported" ++ show a 445 | {- 446 | Texture and renderbuffer color formats (R): 447 | R11F_G11F_B10F 448 | R16 449 | R16F 450 | R16I 451 | R16UI 452 | R32F 453 | R32I 454 | R32UI 455 | R8 456 | R8I 457 | R8UI 458 | RG16 459 | RG16F 460 | RG16I 461 | RG16UI 462 | RG32F 463 | RG32I 464 | RG32UI 465 | RG8 466 | RG8I 467 | RG8UI 468 | RGB10_A2 469 | RGB10_A2UI 470 | RGBA16 471 | RGBA16F 472 | RGBA16I 473 | RGBA16UI 474 | RGBA32F 475 | RGBA32I 476 | RGBA32UI 477 | RGBA8 478 | RGBA8I 479 | RGBA8UI 480 | SRGB8_ALPHA8 481 | -} 482 | 483 | glGetIntegerv1 :: GLenum -> IO GLint 484 | glGetIntegerv1 e = alloca $ \pi -> glGetIntegerv e pi >> peek pi 485 | 486 | checkFBO :: IO String 487 | checkFBO = do 488 | let f e | e == GL_FRAMEBUFFER_UNDEFINED = "FRAMEBUFFER_UNDEFINED" 489 | | e == GL_FRAMEBUFFER_INCOMPLETE_ATTACHMENT = "FRAMEBUFFER_INCOMPLETE_ATTACHMENT" 490 | | e == GL_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER = "FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER" 491 | | e == GL_FRAMEBUFFER_INCOMPLETE_READ_BUFFER = "FRAMEBUFFER_INCOMPLETE_READ_BUFFER" 492 | | e == GL_FRAMEBUFFER_UNSUPPORTED = "FRAMEBUFFER_UNSUPPORTED" 493 | | e == GL_FRAMEBUFFER_INCOMPLETE_MULTISAMPLE = "FRAMEBUFFER_INCOMPLETE_MULTISAMPLE" 494 | | e == GL_FRAMEBUFFER_INCOMPLETE_LAYER_TARGETS = "FRAMEBUFFER_INCOMPLETE_LAYER_TARGETS" 495 | | e == GL_FRAMEBUFFER_COMPLETE = "FRAMEBUFFER_COMPLETE" 496 | | otherwise = "Unknown error" 497 | e <- glCheckFramebufferStatus GL_DRAW_FRAMEBUFFER 498 | return $ f e 499 | 500 | filterToGLType :: Filter -> GLenum 501 | filterToGLType a = case a of 502 | Nearest -> GL_NEAREST 503 | Linear -> GL_LINEAR 504 | NearestMipmapNearest -> GL_NEAREST_MIPMAP_NEAREST 505 | NearestMipmapLinear -> GL_NEAREST_MIPMAP_LINEAR 506 | LinearMipmapNearest -> GL_LINEAR_MIPMAP_NEAREST 507 | LinearMipmapLinear -> GL_LINEAR_MIPMAP_LINEAR 508 | 509 | edgeModeToGLType :: EdgeMode -> GLenum 510 | edgeModeToGLType a = case a of 511 | Repeat -> GL_REPEAT 512 | MirroredRepeat -> GL_MIRRORED_REPEAT 513 | ClampToEdge -> GL_CLAMP_TO_EDGE 514 | ClampToBorder -> GL_CLAMP_TO_BORDER 515 | 516 | data ParameterSetup 517 | = ParameterSetup 518 | { setParameteri :: GLenum -> GLint -> IO () 519 | , setParameterfv :: GLenum -> Ptr GLfloat -> IO () 520 | , setParameterIiv :: GLenum -> Ptr GLint -> IO () 521 | , setParameterIuiv :: GLenum -> Ptr GLuint -> IO () 522 | , setParameterf :: GLenum -> GLfloat -> IO () 523 | } 524 | 525 | setTextureSamplerParameters :: GLenum -> SamplerDescriptor -> IO () 526 | setTextureSamplerParameters target = setParameters $ ParameterSetup 527 | { setParameteri = glTexParameteri target 528 | , setParameterfv = glTexParameterfv target 529 | , setParameterIiv = glTexParameterIiv target 530 | , setParameterIuiv = glTexParameterIuiv target 531 | , setParameterf = glTexParameterf target 532 | } 533 | 534 | setSamplerParameters :: GLuint -> SamplerDescriptor -> IO () 535 | setSamplerParameters samplerObj = setParameters $ ParameterSetup 536 | { setParameteri = glSamplerParameteri samplerObj 537 | , setParameterfv = glSamplerParameterfv samplerObj 538 | , setParameterIiv = glSamplerParameterIiv samplerObj 539 | , setParameterIuiv = glSamplerParameterIuiv samplerObj 540 | , setParameterf = glSamplerParameterf samplerObj 541 | } 542 | 543 | setParameters :: ParameterSetup -> SamplerDescriptor -> IO () 544 | setParameters ParameterSetup{..} s = do 545 | setParameteri GL_TEXTURE_WRAP_S $ fromIntegral $ edgeModeToGLType $ samplerWrapS s 546 | case samplerWrapT s of 547 | Nothing -> return () 548 | Just a -> setParameteri GL_TEXTURE_WRAP_T $ fromIntegral $ edgeModeToGLType a 549 | case samplerWrapR s of 550 | Nothing -> return () 551 | Just a -> setParameteri GL_TEXTURE_WRAP_R $ fromIntegral $ edgeModeToGLType a 552 | setParameteri GL_TEXTURE_MIN_FILTER $ fromIntegral $ filterToGLType $ samplerMinFilter s 553 | setParameteri GL_TEXTURE_MAG_FILTER $ fromIntegral $ filterToGLType $ samplerMagFilter s 554 | 555 | let setBColorV4F a = with a $ \p -> setParameterfv GL_TEXTURE_BORDER_COLOR $ castPtr p 556 | setBColorV4I a = with a $ \p -> setParameterIiv GL_TEXTURE_BORDER_COLOR $ castPtr p 557 | setBColorV4U a = with a $ \p -> setParameterIuiv GL_TEXTURE_BORDER_COLOR $ castPtr p 558 | case samplerBorderColor s of 559 | -- float, word, int, red, rg, rgb, rgba 560 | VFloat a -> setBColorV4F $ V4 a 0 0 0 561 | VV2F (V2 a b) -> setBColorV4F $ V4 a b 0 0 562 | VV3F (V3 a b c) -> setBColorV4F $ V4 a b c 0 563 | VV4F a -> setBColorV4F a 564 | 565 | VInt a -> setBColorV4I $ V4 a 0 0 0 566 | VV2I (V2 a b) -> setBColorV4I $ V4 a b 0 0 567 | VV3I (V3 a b c) -> setBColorV4I $ V4 a b c 0 568 | VV4I a -> setBColorV4I a 569 | 570 | VWord a -> setBColorV4U $ V4 a 0 0 0 571 | VV2U (V2 a b) -> setBColorV4U $ V4 a b 0 0 572 | VV3U (V3 a b c) -> setBColorV4U $ V4 a b c 0 573 | VV4U a -> setBColorV4U a 574 | _ -> fail "internal error (setTextureSamplerParameters)!" 575 | 576 | case samplerMinLod s of 577 | Nothing -> return () 578 | Just a -> setParameterf GL_TEXTURE_MIN_LOD $ realToFrac a 579 | case samplerMaxLod s of 580 | Nothing -> return () 581 | Just a -> setParameterf GL_TEXTURE_MAX_LOD $ realToFrac a 582 | setParameterf GL_TEXTURE_LOD_BIAS $ realToFrac $ samplerLodBias s 583 | case samplerCompareFunc s of 584 | Nothing -> setParameteri GL_TEXTURE_COMPARE_MODE $ fromIntegral GL_NONE 585 | Just a -> do 586 | setParameteri GL_TEXTURE_COMPARE_MODE $ fromIntegral GL_COMPARE_REF_TO_TEXTURE 587 | setParameteri GL_TEXTURE_COMPARE_FUNC $ fromIntegral $ comparisonFunctionToGLType a 588 | 589 | compileSampler :: SamplerDescriptor -> IO GLSampler 590 | compileSampler s = do 591 | so <- alloca $! \po -> glGenSamplers 1 po >> peek po 592 | setSamplerParameters so s 593 | return $ GLSampler 594 | { glSamplerObject = so 595 | } 596 | 597 | compileTexture :: TextureDescriptor -> IO GLTexture 598 | compileTexture txDescriptor = do 599 | to <- alloca $! \pto -> glGenTextures 1 pto >> peek pto 600 | let TextureDescriptor 601 | { textureType = txType 602 | , textureSize = txSize 603 | , textureSemantic = txSemantic 604 | , textureSampler = txSampler 605 | , textureBaseLevel = txBaseLevel 606 | , textureMaxLevel = txMaxLevel 607 | } = txDescriptor 608 | 609 | txSetup txTarget dTy = do 610 | let internalFormat = fromIntegral $ textureDataTypeToGLType txSemantic dTy 611 | dataFormat = fromIntegral $ textureDataTypeToGLArityType txSemantic dTy 612 | glBindTexture txTarget to 613 | glTexParameteri txTarget GL_TEXTURE_BASE_LEVEL $ fromIntegral txBaseLevel 614 | glTexParameteri txTarget GL_TEXTURE_MAX_LEVEL $ fromIntegral txMaxLevel 615 | setTextureSamplerParameters txTarget txSampler 616 | return (internalFormat,dataFormat) 617 | 618 | mipSize 0 x = [x] 619 | mipSize n x = x : mipSize (n-1) (x `div` 2) 620 | mipS = mipSize (txMaxLevel - txBaseLevel) 621 | levels = [txBaseLevel..txMaxLevel] 622 | (target, sizeV3) <- case txType of 623 | Texture1D dTy layerCnt -> do 624 | let VWord txW = txSize 625 | txTarget = if layerCnt > 1 then GL_TEXTURE_1D_ARRAY else GL_TEXTURE_1D 626 | (internalFormat,dataFormat) <- txSetup txTarget dTy 627 | forM_ (zip levels (mipS txW)) $ \(l,w) -> case layerCnt > 1 of 628 | True -> glTexImage2D txTarget (fromIntegral l) internalFormat (fromIntegral w) (fromIntegral layerCnt) 0 dataFormat GL_UNSIGNED_BYTE nullPtr 629 | False -> glTexImage1D txTarget (fromIntegral l) internalFormat (fromIntegral w) 0 dataFormat GL_UNSIGNED_BYTE nullPtr 630 | return (txTarget, V3 txW 0 0) 631 | Texture2D dTy layerCnt -> do 632 | let VV2U (V2 txW txH) = txSize 633 | txTarget = if layerCnt > 1 then GL_TEXTURE_2D_ARRAY else GL_TEXTURE_2D 634 | (internalFormat,dataFormat) <- txSetup txTarget dTy 635 | forM_ (zip3 levels (mipS txW) (mipS txH)) $ \(l,w,h) -> case layerCnt > 1 of 636 | True -> glTexImage3D txTarget (fromIntegral l) internalFormat (fromIntegral w) (fromIntegral h) (fromIntegral layerCnt) 0 dataFormat GL_UNSIGNED_BYTE nullPtr 637 | False -> glTexImage2D txTarget (fromIntegral l) internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat GL_UNSIGNED_BYTE nullPtr 638 | return (txTarget, V3 txW txH 0) 639 | Texture3D dTy -> do 640 | let VV3U (V3 txW txH txD) = txSize 641 | txTarget = GL_TEXTURE_3D 642 | (internalFormat,dataFormat) <- txSetup txTarget dTy 643 | forM_ (zip4 levels (mipS txW) (mipS txH) (mipS txD)) $ \(l,w,h,d) -> 644 | glTexImage3D txTarget (fromIntegral l) internalFormat (fromIntegral w) (fromIntegral h) (fromIntegral d) 0 dataFormat GL_UNSIGNED_BYTE nullPtr 645 | return (txTarget, V3 txW txH txD) 646 | TextureCube dTy -> do 647 | let VV2U (V2 txW txH) = txSize 648 | txTarget = GL_TEXTURE_CUBE_MAP 649 | targets = 650 | [ GL_TEXTURE_CUBE_MAP_POSITIVE_X 651 | , GL_TEXTURE_CUBE_MAP_NEGATIVE_X 652 | , GL_TEXTURE_CUBE_MAP_POSITIVE_Y 653 | , GL_TEXTURE_CUBE_MAP_NEGATIVE_Y 654 | , GL_TEXTURE_CUBE_MAP_POSITIVE_Z 655 | , GL_TEXTURE_CUBE_MAP_NEGATIVE_Z 656 | ] 657 | (internalFormat,dataFormat) <- txSetup txTarget dTy 658 | forM_ (zip3 levels (mipS txW) (mipS txH)) $ \(l,w,h) -> 659 | forM_ targets $ \t -> glTexImage2D t (fromIntegral l) internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat GL_UNSIGNED_BYTE nullPtr 660 | return (txTarget, V3 txW txH 0) 661 | TextureRect dTy -> do 662 | let VV2U (V2 txW txH) = txSize 663 | txTarget = GL_TEXTURE_RECTANGLE 664 | (internalFormat,dataFormat) <- txSetup txTarget dTy 665 | forM_ (zip3 levels (mipS txW) (mipS txH)) $ \(l,w,h) -> 666 | glTexImage2D txTarget (fromIntegral l) internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat GL_UNSIGNED_BYTE nullPtr 667 | return (txTarget, V3 txW txH 0) 668 | Texture2DMS dTy layerCnt sampleCount isFixedLocations -> do 669 | let VV2U (V2 w h) = txSize 670 | txTarget = if layerCnt > 1 then GL_TEXTURE_2D_MULTISAMPLE_ARRAY else GL_TEXTURE_2D_MULTISAMPLE 671 | isFixed = fromIntegral $ if isFixedLocations then GL_TRUE else GL_FALSE 672 | (internalFormat,dataFormat) <- txSetup txTarget dTy 673 | case layerCnt > 1 of 674 | True -> glTexImage3DMultisample txTarget (fromIntegral sampleCount) internalFormat (fromIntegral w) (fromIntegral h) (fromIntegral layerCnt) isFixed 675 | False -> glTexImage2DMultisample txTarget (fromIntegral sampleCount) internalFormat (fromIntegral w) (fromIntegral h) isFixed 676 | return (txTarget, V3 w h 1) 677 | TextureBuffer dTy -> do 678 | fail "internal error: buffer texture is not supported yet" 679 | -- TODO 680 | let VV2U (V2 w h) = txSize 681 | txTarget = GL_TEXTURE_2D 682 | (internalFormat,dataFormat) <- txSetup txTarget dTy 683 | glTexImage2D GL_TEXTURE_2D 0 internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat GL_UNSIGNED_BYTE nullPtr 684 | return (txTarget, V3 w h 0) 685 | return $ GLTexture 686 | { glTextureObject = to 687 | , glTextureTarget = target 688 | , glTextureSize = sizeV3 689 | } 690 | 691 | primitiveToFetchPrimitive :: Primitive -> FetchPrimitive 692 | primitiveToFetchPrimitive prim = case prim of 693 | TriangleStrip -> Triangles 694 | TriangleList -> Triangles 695 | TriangleFan -> Triangles 696 | LineStrip -> Lines 697 | LineList -> Lines 698 | PointList -> Points 699 | TriangleStripAdjacency -> TrianglesAdjacency 700 | TriangleListAdjacency -> TrianglesAdjacency 701 | LineStripAdjacency -> LinesAdjacency 702 | LineListAdjacency -> LinesAdjacency 703 | 704 | primitiveToGLType :: Primitive -> GLenum 705 | primitiveToGLType p = case p of 706 | TriangleStrip -> GL_TRIANGLE_STRIP 707 | TriangleList -> GL_TRIANGLES 708 | TriangleFan -> GL_TRIANGLE_FAN 709 | LineStrip -> GL_LINE_STRIP 710 | LineList -> GL_LINES 711 | PointList -> GL_POINTS 712 | TriangleStripAdjacency -> GL_TRIANGLE_STRIP_ADJACENCY 713 | TriangleListAdjacency -> GL_TRIANGLES_ADJACENCY 714 | LineStripAdjacency -> GL_LINE_STRIP_ADJACENCY 715 | LineListAdjacency -> GL_LINES_ADJACENCY 716 | 717 | inputTypeToTextureTarget :: InputType -> GLenum 718 | inputTypeToTextureTarget ty = case ty of 719 | STexture1D -> GL_TEXTURE_1D 720 | STexture2D -> GL_TEXTURE_2D 721 | STextureCube -> GL_TEXTURE_CUBE_MAP 722 | STexture1DArray -> GL_TEXTURE_1D_ARRAY 723 | STexture2DArray -> GL_TEXTURE_2D_ARRAY 724 | STexture2DRect -> GL_TEXTURE_RECTANGLE 725 | 726 | FTexture1D -> GL_TEXTURE_1D 727 | FTexture2D -> GL_TEXTURE_2D 728 | FTexture3D -> GL_TEXTURE_3D 729 | FTextureCube -> GL_TEXTURE_CUBE_MAP 730 | FTexture1DArray -> GL_TEXTURE_1D_ARRAY 731 | FTexture2DArray -> GL_TEXTURE_2D_ARRAY 732 | FTexture2DMS -> GL_TEXTURE_2D_MULTISAMPLE 733 | FTexture2DMSArray -> GL_TEXTURE_2D_MULTISAMPLE_ARRAY 734 | FTextureBuffer -> GL_TEXTURE_BUFFER 735 | FTexture2DRect -> GL_TEXTURE_RECTANGLE 736 | 737 | ITexture1D -> GL_TEXTURE_1D 738 | ITexture2D -> GL_TEXTURE_2D 739 | ITexture3D -> GL_TEXTURE_3D 740 | ITextureCube -> GL_TEXTURE_CUBE_MAP 741 | ITexture1DArray -> GL_TEXTURE_1D_ARRAY 742 | ITexture2DArray -> GL_TEXTURE_2D_ARRAY 743 | ITexture2DMS -> GL_TEXTURE_2D_MULTISAMPLE 744 | ITexture2DMSArray -> GL_TEXTURE_2D_MULTISAMPLE_ARRAY 745 | ITextureBuffer -> GL_TEXTURE_BUFFER 746 | ITexture2DRect -> GL_TEXTURE_RECTANGLE 747 | 748 | UTexture1D -> GL_TEXTURE_1D 749 | UTexture2D -> GL_TEXTURE_2D 750 | UTexture3D -> GL_TEXTURE_3D 751 | UTextureCube -> GL_TEXTURE_CUBE_MAP 752 | UTexture1DArray -> GL_TEXTURE_1D_ARRAY 753 | UTexture2DArray -> GL_TEXTURE_2D_ARRAY 754 | UTexture2DMS -> GL_TEXTURE_2D_MULTISAMPLE 755 | UTexture2DMSArray -> GL_TEXTURE_2D_MULTISAMPLE_ARRAY 756 | UTextureBuffer -> GL_TEXTURE_BUFFER 757 | UTexture2DRect -> GL_TEXTURE_RECTANGLE 758 | 759 | _ -> error "internal error (inputTypeToTextureTarget)!" 760 | -------------------------------------------------------------------------------- /src/LambdaCube/GL/Backend.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TupleSections, MonadComprehensions, RecordWildCards, LambdaCase, FlexibleContexts #-} 2 | module LambdaCube.GL.Backend where 3 | 4 | import Control.Applicative 5 | import Control.Monad 6 | import Control.Monad.State.Strict 7 | import Data.Maybe 8 | import Data.Bits 9 | import Data.IORef 10 | import Data.IntMap (IntMap) 11 | import Data.Maybe (isNothing,fromJust) 12 | import Data.Map (Map) 13 | import Data.Set (Set) 14 | import Data.Vector (Vector,(!),(//)) 15 | import qualified Data.Foldable as F 16 | import qualified Data.IntMap as IntMap 17 | import qualified Data.Map as Map 18 | import qualified Data.List as L 19 | import qualified Data.Set as Set 20 | import qualified Data.Vector as V 21 | import qualified Data.Vector.Storable as SV 22 | 23 | import Graphics.GL.Core33 24 | import Foreign 25 | import Foreign.C.String 26 | 27 | -- LC IR imports 28 | import LambdaCube.PipelineSchema 29 | import LambdaCube.Linear 30 | import LambdaCube.IR hiding (streamType) 31 | import qualified LambdaCube.IR as IR 32 | 33 | import LambdaCube.GL.Type 34 | import LambdaCube.GL.Util 35 | 36 | import LambdaCube.GL.Data 37 | import LambdaCube.GL.Input 38 | 39 | setupRasterContext :: RasterContext -> IO () 40 | setupRasterContext = cvt 41 | where 42 | cff :: FrontFace -> GLenum 43 | cff CCW = GL_CCW 44 | cff CW = GL_CW 45 | 46 | setProvokingVertex :: ProvokingVertex -> IO () 47 | setProvokingVertex pv = glProvokingVertex $ case pv of 48 | FirstVertex -> GL_FIRST_VERTEX_CONVENTION 49 | LastVertex -> GL_LAST_VERTEX_CONVENTION 50 | 51 | setPointSize :: PointSize -> IO () 52 | setPointSize ps = case ps of 53 | ProgramPointSize -> glEnable GL_PROGRAM_POINT_SIZE 54 | PointSize s -> do 55 | glDisable GL_PROGRAM_POINT_SIZE 56 | glPointSize $ realToFrac s 57 | 58 | cvt :: RasterContext -> IO () 59 | cvt (PointCtx ps fts sc) = do 60 | setPointSize ps 61 | glPointParameterf GL_POINT_FADE_THRESHOLD_SIZE (realToFrac fts) 62 | glPointParameterf GL_POINT_SPRITE_COORD_ORIGIN $ realToFrac $ case sc of 63 | LowerLeft -> GL_LOWER_LEFT 64 | UpperLeft -> GL_UPPER_LEFT 65 | 66 | cvt (LineCtx lw pv) = do 67 | glLineWidth (realToFrac lw) 68 | setProvokingVertex pv 69 | 70 | cvt (TriangleCtx cm pm po pv) = do 71 | -- cull mode 72 | case cm of 73 | CullNone -> glDisable GL_CULL_FACE 74 | CullFront f -> do 75 | glEnable GL_CULL_FACE 76 | glCullFace GL_FRONT 77 | glFrontFace $ cff f 78 | CullBack f -> do 79 | glEnable GL_CULL_FACE 80 | glCullFace GL_BACK 81 | glFrontFace $ cff f 82 | 83 | -- polygon mode 84 | case pm of 85 | PolygonPoint ps -> do 86 | setPointSize ps 87 | glPolygonMode GL_FRONT_AND_BACK GL_POINT 88 | PolygonLine lw -> do 89 | glLineWidth (realToFrac lw) 90 | glPolygonMode GL_FRONT_AND_BACK GL_LINE 91 | PolygonFill -> glPolygonMode GL_FRONT_AND_BACK GL_FILL 92 | 93 | -- polygon offset 94 | glDisable GL_POLYGON_OFFSET_POINT 95 | glDisable GL_POLYGON_OFFSET_LINE 96 | glDisable GL_POLYGON_OFFSET_FILL 97 | case po of 98 | NoOffset -> return () 99 | Offset f u -> do 100 | glPolygonOffset (realToFrac f) (realToFrac u) 101 | glEnable $ case pm of 102 | PolygonPoint _ -> GL_POLYGON_OFFSET_POINT 103 | PolygonLine _ -> GL_POLYGON_OFFSET_LINE 104 | PolygonFill -> GL_POLYGON_OFFSET_FILL 105 | 106 | -- provoking vertex 107 | setProvokingVertex pv 108 | 109 | setupAccumulationContext :: AccumulationContext -> IO () 110 | setupAccumulationContext (AccumulationContext n ops) = cvt ops 111 | where 112 | cvt :: [FragmentOperation] -> IO () 113 | cvt (StencilOp a b c : DepthOp f m : xs) = do 114 | -- TODO 115 | cvtC 0 xs 116 | cvt (StencilOp a b c : xs) = do 117 | -- TODO 118 | cvtC 0 xs 119 | cvt (DepthOp df dm : xs) = do 120 | -- TODO 121 | glDisable GL_STENCIL_TEST 122 | case df == Always && dm == False of 123 | True -> glDisable GL_DEPTH_TEST 124 | False -> do 125 | glEnable GL_DEPTH_TEST 126 | glDepthFunc $! comparisonFunctionToGLType df 127 | glDepthMask (cvtBool dm) 128 | cvtC 0 xs 129 | cvt xs = do 130 | glDisable GL_DEPTH_TEST 131 | glDisable GL_STENCIL_TEST 132 | cvtC 0 xs 133 | 134 | cvtC :: Int -> [FragmentOperation] -> IO () 135 | cvtC i (ColorOp b m : xs) = do 136 | -- TODO 137 | case b of 138 | NoBlending -> do 139 | -- FIXME: requires GL 3.1 140 | --glDisablei GL_BLEND $ fromIntegral GL_DRAW_BUFFER0 + fromIntegral i 141 | glDisable GL_BLEND -- workaround 142 | glDisable GL_COLOR_LOGIC_OP 143 | BlendLogicOp op -> do 144 | glDisable GL_BLEND 145 | glEnable GL_COLOR_LOGIC_OP 146 | glLogicOp $ logicOperationToGLType op 147 | Blend cEq aEq scF dcF saF daF (V4 r g b a) -> do 148 | glDisable GL_COLOR_LOGIC_OP 149 | -- FIXME: requires GL 3.1 150 | --glEnablei GL_BLEND $ fromIntegral GL_DRAW_BUFFER0 + fromIntegral i 151 | glEnable GL_BLEND -- workaround 152 | glBlendEquationSeparate (blendEquationToGLType cEq) (blendEquationToGLType aEq) 153 | glBlendFuncSeparate (blendingFactorToGLType scF) (blendingFactorToGLType dcF) 154 | (blendingFactorToGLType saF) (blendingFactorToGLType daF) 155 | glBlendColor (realToFrac r) (realToFrac g) (realToFrac b) (realToFrac a) 156 | let cvt True = 1 157 | cvt False = 0 158 | (mr,mg,mb,ma) = case m of 159 | VBool r -> (cvt r, 1, 1, 1) 160 | VV2B (V2 r g) -> (cvt r, cvt g, 1, 1) 161 | VV3B (V3 r g b) -> (cvt r, cvt g, cvt b, 1) 162 | VV4B (V4 r g b a) -> (cvt r, cvt g, cvt b, cvt a) 163 | _ -> (1,1,1,1) 164 | glColorMask mr mg mb ma 165 | cvtC (i + 1) xs 166 | cvtC _ [] = return () 167 | 168 | cvtBool :: Bool -> GLboolean 169 | cvtBool True = 1 170 | cvtBool False = 0 171 | 172 | clearRenderTarget :: GLRenderTarget -> [ClearImage] -> IO () 173 | clearRenderTarget GLRenderTarget{..} values = do 174 | let setClearValue (m,i) value = case value of 175 | ClearImage Depth (VFloat v) -> do 176 | glDepthMask 1 177 | glClearDepth $ realToFrac v 178 | return (m .|. GL_DEPTH_BUFFER_BIT, i) 179 | ClearImage Stencil (VWord v) -> do 180 | glClearStencil $ fromIntegral v 181 | return (m .|. GL_STENCIL_BUFFER_BIT, i) 182 | ClearImage Color c -> do 183 | glColorMask 1 1 1 1 184 | if framebufferObject == 0 185 | then 186 | clearDefaultFB >> 187 | pure (m .|. GL_COLOR_BUFFER_BIT, i+1) 188 | else 189 | clearFBColorAttachment >> 190 | pure (m, i+1) 191 | where 192 | clearDefaultFB = do 193 | let (r,g,b,a) = case c of 194 | VFloat r -> (realToFrac r, 0, 0, 1) 195 | VV2F (V2 r g) -> (realToFrac r, realToFrac g, 0, 1) 196 | VV3F (V3 r g b) -> (realToFrac r, realToFrac g, realToFrac b, 1) 197 | VV4F (V4 r g b a) -> (realToFrac r, realToFrac g, realToFrac b, realToFrac a) 198 | _ -> (0,0,0,1) 199 | glClearColor r g b a 200 | clearFBColorAttachment = do 201 | let buf = GL_COLOR 202 | case c of -- there must be some clever way to extract the generality here, I'm sure.. 203 | VFloat r -> with (V4 r 0 0 1) $ glClearBufferfv buf i . castPtr 204 | VV2F (V2 r g) -> with (V4 r g 0 1) $ glClearBufferfv buf i . castPtr 205 | VV3F (V3 r g b) -> with (V4 r g b 1) $ glClearBufferfv buf i . castPtr 206 | VV4F (V4 r g b a) -> with (V4 r g b a) $ glClearBufferfv buf i . castPtr 207 | 208 | VInt r -> with (V4 r 0 0 1) $ glClearBufferiv buf i . castPtr 209 | VV2I (V2 r g) -> with (V4 r g 0 1) $ glClearBufferiv buf i . castPtr 210 | VV3I (V3 r g b) -> with (V4 r g b 1) $ glClearBufferiv buf i . castPtr 211 | VV4I (V4 r g b a) -> with (V4 r g b a) $ glClearBufferiv buf i . castPtr 212 | 213 | VWord r -> with (V4 r 0 0 1) $ glClearBufferiv buf i . castPtr 214 | VV2U (V2 r g) -> with (V4 r g 0 1) $ glClearBufferiv buf i . castPtr 215 | VV3U (V3 r g b) -> with (V4 r g b 1) $ glClearBufferiv buf i . castPtr 216 | VV4U (V4 r g b a) -> with (V4 r g b a) $ glClearBufferiv buf i . castPtr 217 | _ -> error $ "internal error: unsupported color attachment format: " ++ show c 218 | 219 | _ -> error "internal error (clearRenderTarget)" 220 | (mask,_) <- foldM setClearValue (0,0) values 221 | glClear $ fromIntegral mask 222 | 223 | printGLStatus = checkGL >>= print 224 | printFBOStatus = checkFBO >>= print 225 | 226 | compileProgram :: Program -> IO GLProgram 227 | compileProgram p = do 228 | po <- glCreateProgram 229 | --putStrLn $ "compile program: " ++ show po 230 | let createAndAttach src t = do 231 | o <- glCreateShader t 232 | compileShader o [src] 233 | glAttachShader po o 234 | --putStr " + compile shader source: " >> printGLStatus 235 | return o 236 | 237 | objs <- sequence $ createAndAttach (vertexShader p) GL_VERTEX_SHADER : createAndAttach (fragmentShader p) GL_FRAGMENT_SHADER : case geometryShader p of 238 | Nothing -> [] 239 | Just s -> [createAndAttach s GL_GEOMETRY_SHADER] 240 | 241 | forM_ (zip (V.toList $ programOutput p) [0..]) $ \(Parameter n t,i) -> withCString n $ \pn -> do 242 | --putStrLn ("variable " ++ show n ++ " attached to color number #" ++ show i) 243 | glBindFragDataLocation po i $ castPtr pn 244 | --putStr " + setup shader output mapping: " >> printGLStatus 245 | 246 | glLinkProgram po 247 | log <- printProgramLog po 248 | 249 | -- check link status 250 | status <- glGetProgramiv1 GL_LINK_STATUS po 251 | when (status /= fromIntegral GL_TRUE) $ fail $ unlines ["link program failed:",log] 252 | 253 | -- check program input 254 | (uniforms,uniformsType) <- queryUniforms po 255 | (attributes,attributesType) <- queryStreams po 256 | --print uniforms 257 | --print attributes 258 | let lcUniforms = (programUniforms p) `Map.union` (programInTextures p) 259 | lcStreams = fmap ty (programStreams p) 260 | check a m = and $ map go $ Map.toList m 261 | where go (k,b) = case Map.lookup k a of 262 | Nothing -> False 263 | Just x -> x == b 264 | unless (check lcUniforms uniformsType) $ fail $ unlines 265 | [ "shader program uniform input mismatch!" 266 | , "expected: " ++ show lcUniforms 267 | , "actual: " ++ show uniformsType 268 | ] 269 | unless (check lcStreams attributesType) $ fail $ "shader program stream input mismatch! " ++ show (attributesType,lcStreams) 270 | -- the public (user) pipeline and program input is encoded by the objectArrays, therefore the programs does not distinct the render and slot textures input 271 | let inUniNames = programUniforms p 272 | inUniforms = L.filter (\(n,v) -> Map.member n inUniNames) $ Map.toList $ uniforms 273 | inTextureNames = programInTextures p 274 | inTextures = L.filter (\(n,v) -> Map.member n inTextureNames) $ Map.toList $ uniforms 275 | texUnis = [n | (n,_) <- inTextures, Map.member n (programUniforms p)] 276 | let prgInTextures = Map.keys inTextureNames 277 | uniInTextures = map fst inTextures 278 | {- 279 | unless (S.fromList prgInTextures == S.fromList uniInTextures) $ fail $ unlines 280 | [ "shader program uniform texture input mismatch!" 281 | , "expected: " ++ show prgInTextures 282 | , "actual: " ++ show uniInTextures 283 | , "vertex shader:" 284 | , vertexShader p 285 | , "geometry shader:" 286 | , fromMaybe "" (geometryShader p) 287 | , "fragment shader:" 288 | , fragmentShader p 289 | ] 290 | -} 291 | --putStrLn $ "uniTrie: " ++ show (Map.keys uniTrie) 292 | --putStrLn $ "inUniNames: " ++ show inUniNames 293 | --putStrLn $ "inUniforms: " ++ show inUniforms 294 | --putStrLn $ "inTextureNames: " ++ show inTextureNames 295 | --putStrLn $ "inTextures: " ++ show inTextures 296 | --putStrLn $ "texUnis: " ++ show texUnis 297 | let valA = Map.toList $ attributes 298 | valB = Map.toList $ programStreams p 299 | --putStrLn "------------" 300 | --print $ Map.toList $ attributes 301 | --print $ Map.toList $ programStreams p 302 | let lcStreamName = fmap name (programStreams p) 303 | return $ GLProgram 304 | { shaderObjects = objs 305 | , programObject = po 306 | , inputUniforms = Map.fromList inUniforms 307 | , inputTextures = Map.fromList inTextures 308 | , inputTextureUniforms = Set.fromList $ texUnis 309 | , inputStreams = Map.fromList [(n,(idx, attrName)) | (n,idx) <- Map.toList $ attributes, let attrName = fromMaybe (error $ "missing attribute: " ++ n) $ Map.lookup n lcStreamName] 310 | } 311 | 312 | renderTargetOutputs :: Vector GLTexture -> RenderTarget -> GLRenderTarget -> [GLOutput] 313 | renderTargetOutputs glTexs (RenderTarget targetItems) (GLRenderTarget fbo bufs _) = 314 | let isFB (Framebuffer _) = True 315 | isFB _ = False 316 | images = [img | TargetItem _ (Just img) <- V.toList targetItems] 317 | in case all isFB images of 318 | True -> fromMaybe [] $ (GLOutputDrawBuffer fbo <$>) <$> bufs 319 | False -> (\(TextureImage texIdx _ _)-> GLOutputRenderTexture fbo $ glTexs ! texIdx) <$> images 320 | 321 | compileRenderTarget :: Vector TextureDescriptor -> Vector GLTexture -> RenderTarget -> IO GLRenderTarget 322 | compileRenderTarget texs glTexs (RenderTarget targets) = do 323 | let isFB (Framebuffer _) = True 324 | isFB _ = False 325 | images = [img | TargetItem _ (Just img) <- V.toList targets] 326 | case all isFB images of 327 | True -> do 328 | let bufs = [cvt img | TargetItem Color img <- V.toList targets] 329 | cvt a = case a of 330 | Nothing -> GL_NONE 331 | Just (Framebuffer Color) -> GL_BACK_LEFT 332 | _ -> error "internal error (compileRenderTarget)!" 333 | return $ GLRenderTarget 334 | { framebufferObject = 0 335 | , framebufferDrawbuffers = Just bufs 336 | , framebufferSize = Nothing 337 | } 338 | False -> do 339 | when (any isFB images) $ fail "internal error (compileRenderTarget)!" 340 | fbo <- alloca $! \pbo -> glGenFramebuffers 1 pbo >> peek pbo 341 | glBindFramebuffer GL_DRAW_FRAMEBUFFER fbo 342 | {- 343 | void glFramebufferTexture1D(GLenum target, GLenum attachment, GLenum textarget, GLuint texture, GLint level); 344 | GL_TEXTURE_1D 345 | void glFramebufferTexture2D(GLenum target, GLenum attachment, GLenum textarget, GLuint texture, GLint level); 346 | GL_TEXTURE_2D 347 | GL_TEXTURE_RECTANGLE 348 | GL_TEXTURE_CUBE_MAP_POSITIVE_X 349 | GL_TEXTURE_CUBE_MAP_POSITIVE_Y 350 | GL_TEXTURE_CUBE_MAP_POSITIVE_Z 351 | GL_TEXTURE_CUBE_MAP_NEGATIVE_X 352 | GL_TEXTURE_CUBE_MAP_NEGATIVE_Y 353 | GL_TEXTURE_CUBE_MAP_NEGATIVE_Z 354 | GL_TEXTURE_2D_MULTISAMPLE 355 | void glFramebufferTextureLayer(GLenum target, GLenum attachment, GLuint texture, GLint level, GLint layer); 356 | void glFramebufferRenderbuffer(GLenum target, GLenum attachment, GLenum renderbuffertarget, GLuint renderbuffer); 357 | void glFramebufferTexture(GLenum target, GLenum attachment, GLuint texture, GLint level); 358 | -} 359 | let attach attachment (TextureImage texIdx level (Just layer)) = 360 | glFramebufferTextureLayer GL_DRAW_FRAMEBUFFER attachment (glTextureTarget $ glTexs ! texIdx) (fromIntegral level) (fromIntegral layer) 361 | attach attachment (TextureImage texIdx level Nothing) = do 362 | let glTex = glTexs ! texIdx 363 | tex = texs ! texIdx 364 | txLevel = fromIntegral level 365 | txTarget = glTextureTarget glTex 366 | txObj = glTextureObject glTex 367 | attachArray = glFramebufferTexture GL_DRAW_FRAMEBUFFER attachment txObj txLevel 368 | attach2D = glFramebufferTexture2D GL_DRAW_FRAMEBUFFER attachment txTarget txObj txLevel 369 | case textureType tex of 370 | Texture1D _ n 371 | | n > 1 -> attachArray 372 | | otherwise -> glFramebufferTexture1D GL_DRAW_FRAMEBUFFER attachment txTarget txObj txLevel 373 | Texture2D _ n 374 | | n > 1 -> attachArray 375 | | otherwise -> attach2D 376 | Texture3D _ -> attachArray 377 | TextureCube _ -> attachArray 378 | TextureRect _ -> attach2D 379 | Texture2DMS _ n _ _ 380 | | n > 1 -> attachArray 381 | | otherwise -> attach2D 382 | TextureBuffer _ -> fail "internalError (compileRenderTarget/TextureBuffer)!" 383 | 384 | go a (TargetItem Stencil (Just img)) = do 385 | fail "Stencil support is not implemented yet!" 386 | return a 387 | go a (TargetItem Depth (Just img)) = do 388 | attach GL_DEPTH_ATTACHMENT img 389 | return a 390 | go (bufs,colorIdx) (TargetItem Color (Just img)) = do 391 | let attachment = GL_COLOR_ATTACHMENT0 + fromIntegral colorIdx 392 | attach attachment img 393 | return (attachment : bufs, colorIdx + 1) 394 | go (bufs,colorIdx) (TargetItem Color Nothing) = return (GL_NONE : bufs, colorIdx + 1) 395 | go a _ = return a 396 | (bufs,_) <- foldM go ([],0) targets 397 | withArray (reverse bufs) $ glDrawBuffers (fromIntegral $ length bufs) 398 | let framebufferImageSizes = [glTextureSize (glTexs ! texIdx) | TargetItem _ (Just (TextureImage texIdx _ _)) <- V.toList targets] 399 | return $ GLRenderTarget 400 | { framebufferObject = fbo 401 | , framebufferDrawbuffers = Nothing 402 | , framebufferSize = if null framebufferImageSizes then Nothing else Just $ minimum framebufferImageSizes 403 | } 404 | 405 | compileStreamData :: StreamData -> IO GLStream 406 | compileStreamData s = do 407 | let withV w a f = w a (\p -> f $ castPtr p) 408 | let compileAttr (VFloatArray v) = Array ArrFloat (V.length v) (withV (SV.unsafeWith . V.convert) v) 409 | compileAttr (VIntArray v) = Array ArrInt32 (V.length v) (withV (SV.unsafeWith . V.convert) v) 410 | compileAttr (VWordArray v) = Array ArrWord32 (V.length v) (withV (SV.unsafeWith . V.convert) v) 411 | --TODO: compileAttr (VBoolArray v) = Array ArrWord32 (length v) (withV withArray v) 412 | (indexMap,arrays) = unzip [((n,i),compileAttr d) | (i,(n,d)) <- zip [0..] $ Map.toList $ streamData s] 413 | getLength n = l `div` c 414 | where 415 | l = case Map.lookup n $ IR.streamData s of 416 | Just (VFloatArray v) -> V.length v 417 | Just (VIntArray v) -> V.length v 418 | Just (VWordArray v) -> V.length v 419 | _ -> error "compileStreamData - getLength" 420 | c = case Map.lookup n $ IR.streamType s of 421 | Just Bool -> 1 422 | Just V2B -> 2 423 | Just V3B -> 3 424 | Just V4B -> 4 425 | Just Word -> 1 426 | Just V2U -> 2 427 | Just V3U -> 3 428 | Just V4U -> 4 429 | Just Int -> 1 430 | Just V2I -> 2 431 | Just V3I -> 3 432 | Just V4I -> 4 433 | Just Float -> 1 434 | Just V2F -> 2 435 | Just V3F -> 3 436 | Just V4F -> 4 437 | Just M22F -> 4 438 | Just M23F -> 6 439 | Just M24F -> 8 440 | Just M32F -> 6 441 | Just M33F -> 9 442 | Just M34F -> 12 443 | Just M42F -> 8 444 | Just M43F -> 12 445 | Just M44F -> 16 446 | _ -> error "compileStreamData - getLength element count" 447 | buffer <- compileBuffer arrays 448 | cmdRef <- newIORef [] 449 | let toStream (n,i) = (n,Stream 450 | { streamType = fromMaybe (error $ "missing attribute: " ++ n) $ toStreamType =<< Map.lookup n (IR.streamType s) 451 | , streamBuffer = buffer 452 | , streamArrIdx = i 453 | , streamStart = 0 454 | , streamLength = getLength n 455 | }) 456 | return $ GLStream 457 | { glStreamCommands = cmdRef 458 | , glStreamPrimitive = case streamPrimitive s of 459 | Points -> PointList 460 | Lines -> LineList 461 | Triangles -> TriangleList 462 | LinesAdjacency -> LineListAdjacency 463 | TrianglesAdjacency -> TriangleListAdjacency 464 | , glStreamAttributes = Map.fromList $ map toStream indexMap 465 | , glStreamProgram = V.head $ streamPrograms s 466 | } 467 | 468 | createStreamCommands :: Map String (IORef GLint) -> Map String GLUniform -> Map String (Stream Buffer) -> Primitive -> GLProgram -> [GLObjectCommand] 469 | createStreamCommands texUnitMap topUnis attrs primitive prg = streamUniCmds ++ streamCmds ++ [drawCmd] 470 | where 471 | -- object draw command 472 | drawCmd = GLDrawArrays prim 0 (fromIntegral count) 473 | where 474 | prim = primitiveToGLType primitive 475 | count = head [c | Stream _ _ _ _ c <- Map.elems attrs] 476 | 477 | -- object uniform commands 478 | -- texture slot setup commands 479 | streamUniCmds = uniCmds ++ texCmds 480 | where 481 | uniCmds = [GLSetUniform i u | (n,i) <- uniMap, let u = topUni n] 482 | uniMap = Map.toList $ inputUniforms prg 483 | topUni n = Map.findWithDefault (error "internal error (createStreamCommands)!") n topUnis 484 | texUnis = Set.toList $ inputTextureUniforms prg 485 | texCmds = [ GLBindTexture (inputTypeToTextureTarget $ uniInputType u) texUnit u 486 | | n <- texUnis 487 | , let u = topUni n 488 | , let texUnit = Map.findWithDefault (error "internal error (createStreamCommands - Texture Unit)") n texUnitMap 489 | ] 490 | uniInputType (GLUniform ty _) = ty 491 | 492 | -- object attribute stream commands 493 | streamCmds = [attrCmd i s | (i,name) <- Map.elems attrMap, let s = fromMaybe (error $ "missing attribute: " ++ name) $ Map.lookup name attrs] 494 | where 495 | attrMap = inputStreams prg 496 | attrCmd i s = case s of 497 | Stream ty (Buffer arrs bo) arrIdx start len -> case ty of 498 | Attribute_Word -> setIntAttrib 1 499 | Attribute_V2U -> setIntAttrib 2 500 | Attribute_V3U -> setIntAttrib 3 501 | Attribute_V4U -> setIntAttrib 4 502 | Attribute_Int -> setIntAttrib 1 503 | Attribute_V2I -> setIntAttrib 2 504 | Attribute_V3I -> setIntAttrib 3 505 | Attribute_V4I -> setIntAttrib 4 506 | Attribute_Float -> setFloatAttrib 1 507 | Attribute_V2F -> setFloatAttrib 2 508 | Attribute_V3F -> setFloatAttrib 3 509 | Attribute_V4F -> setFloatAttrib 4 510 | Attribute_M22F -> setFloatAttrib 4 511 | Attribute_M23F -> setFloatAttrib 6 512 | Attribute_M24F -> setFloatAttrib 8 513 | Attribute_M32F -> setFloatAttrib 6 514 | Attribute_M33F -> setFloatAttrib 9 515 | Attribute_M34F -> setFloatAttrib 12 516 | Attribute_M42F -> setFloatAttrib 8 517 | Attribute_M43F -> setFloatAttrib 12 518 | Attribute_M44F -> setFloatAttrib 16 519 | where 520 | setFloatAttrib n = GLSetVertexAttribArray i bo n glType (ptr n) 521 | setIntAttrib n = GLSetVertexAttribIArray i bo n glType (ptr n) 522 | ArrayDesc arrType arrLen arrOffs arrSize = arrs ! arrIdx 523 | glType = arrayTypeToGLType arrType 524 | ptr compCnt = intPtrToPtr $! fromIntegral (arrOffs + start * fromIntegral compCnt * sizeOfArrayType arrType) 525 | 526 | -- constant generic attribute 527 | constAttr -> GLSetVertexAttrib i constAttr 528 | 529 | outputIsRenderTexture :: GLOutput -> Bool 530 | outputIsRenderTexture GLOutputRenderTexture{..} = True 531 | outputIsRenderTexture _ = False 532 | 533 | allocRenderer :: Pipeline -> IO GLRenderer 534 | allocRenderer p = do 535 | smps <- V.mapM compileSampler $ samplers p 536 | texs <- V.mapM compileTexture $ textures p 537 | let cmds = V.toList $ commands p 538 | finalRenderTargetIdx = head [i | SetRenderTarget i <- reverse $ cmds] 539 | trgs <- traverse (compileRenderTarget (textures p) texs) $ targets p 540 | let finalRenderTarget = targets p ! finalRenderTargetIdx 541 | finalGLRenderTarget = trgs ! finalRenderTargetIdx 542 | outs = renderTargetOutputs texs finalRenderTarget finalGLRenderTarget 543 | prgs <- V.mapM compileProgram $ programs p 544 | -- texture unit mapping ioref trie 545 | -- texUnitMapRefs :: Map UniformName (IORef TextureUnit) 546 | texUnitMapRefs <- Map.fromList <$> mapM (\k -> (k,) <$> newIORef 0) (Set.toList $ Set.fromList $ concat $ V.toList $ V.map (Map.keys . programInTextures) $ programs p) 547 | let st = execState (mapM_ (compileCommand texUnitMapRefs smps texs trgs prgs) cmds) initCGState 548 | input <- newIORef Nothing 549 | -- default Vertex Array Object 550 | vao <- alloca $! \pvao -> glGenVertexArrays 1 pvao >> peek pvao 551 | strs <- V.mapM compileStreamData $ streams p 552 | drawContextRef <- newIORef $ error "missing DrawContext" 553 | forceSetup <- newIORef True 554 | vertexBufferRef <- newIORef 0 555 | indexBufferRef <- newIORef 0 556 | drawCallCounterRef <- newIORef 0 557 | return $ GLRenderer 558 | { glPrograms = prgs 559 | , glTextures = texs 560 | , glSamplers = smps 561 | , glTargets = trgs 562 | , glCommands = reverse $ drawCommands st 563 | , glSlotPrograms = V.map (V.toList . slotPrograms) $ IR.slots p 564 | , glInput = input 565 | , glOutputs = outs 566 | , glSlotNames = V.map slotName $ IR.slots p 567 | , glVAO = vao 568 | , glTexUnitMapping = texUnitMapRefs 569 | , glStreams = strs 570 | , glDrawContextRef = drawContextRef 571 | , glForceSetup = forceSetup 572 | , glVertexBufferRef = vertexBufferRef 573 | , glIndexBufferRef = indexBufferRef 574 | , glDrawCallCounterRef = drawCallCounterRef 575 | } 576 | 577 | disposeRenderer :: GLRenderer -> IO () 578 | disposeRenderer p = do 579 | setStorage' p Nothing 580 | V.forM_ (glPrograms p) $ \prg -> do 581 | glDeleteProgram $ programObject prg 582 | mapM_ glDeleteShader $ shaderObjects prg 583 | let targets = glTargets p 584 | withArray (map framebufferObject $ V.toList targets) $ (glDeleteFramebuffers $ fromIntegral $ V.length targets) 585 | let textures = glTextures p 586 | withArray (map glTextureObject $ V.toList textures) $ (glDeleteTextures $ fromIntegral $ V.length textures) 587 | let samplers = glSamplers p 588 | withArray (map glSamplerObject $ V.toList samplers) $ (glDeleteSamplers . fromIntegral . V.length $ glSamplers p) 589 | with (glVAO p) $ (glDeleteVertexArrays 1) 590 | 591 | {- 592 | data ObjectArraySchema 593 | = ObjectArraySchema 594 | { primitive :: FetchPrimitive 595 | , attributes :: Trie StreamType 596 | } 597 | deriving Show 598 | 599 | data PipelineSchema 600 | = PipelineSchema 601 | { objectArrays :: Trie ObjectArraySchema 602 | , uniforms :: Trie InputType 603 | } 604 | deriving Show 605 | -} 606 | isSubTrie :: (a -> a -> Bool) -> Map String a -> Map String a -> Bool 607 | isSubTrie eqFun universe subset = and [isMember a (Map.lookup n universe) | (n,a) <- Map.toList subset] 608 | where 609 | isMember a Nothing = False 610 | isMember a (Just b) = eqFun a b 611 | 612 | -- TODO: if there is a mismatch thow detailed error message in the excoeption, containing the missing attributes and uniforms 613 | {- 614 | let sch = schema input 615 | forM_ uniformNames $ \n -> case Map.lookup n (uniforms sch) of 616 | Nothing -> throw $ userError $ "Unknown uniform: " ++ show n 617 | _ -> return () 618 | case Map.lookup slotName (objectArrays sch) of 619 | Nothing -> throw $ userError $ "Unknown slot: " ++ show slotName 620 | Just (ObjectArraySchema sPrim sAttrs) -> do 621 | when (sPrim /= (primitiveToFetchPrimitive prim)) $ throw $ userError $ 622 | "Primitive mismatch for slot (" ++ show slotName ++ ") expected " ++ show sPrim ++ " but got " ++ show prim 623 | let sType = fmap streamToStreamType attribs 624 | when (sType /= sAttrs) $ throw $ userError $ unlines $ 625 | [ "Attribute stream mismatch for slot (" ++ show slotName ++ ") expected " 626 | , show sAttrs 627 | , " but got " 628 | , show sType 629 | ] 630 | -} 631 | 632 | setStorage :: GLRenderer -> GLStorage -> IO (Maybe String) 633 | setStorage p input' = setStorage' p (Just input') 634 | 635 | setStorage' :: GLRenderer -> Maybe GLStorage -> IO (Maybe String) 636 | setStorage' p@GLRenderer{..} input' = do 637 | -- TODO: check matching input schema 638 | {- 639 | case input' of 640 | Nothing -> return () 641 | Just input -> schemaFromPipeline p 642 | -} 643 | {- 644 | deletion: 645 | - remove pipeline's object commands from used objectArrays 646 | - remove pipeline from attached pipelines vector 647 | -} 648 | readIORef glInput >>= \case 649 | Nothing -> return () 650 | Just InputConnection{..} -> do 651 | let slotRefs = slotVector icInput 652 | modifyIORef (pipelines icInput) $ \v -> v // [(icId,Nothing)] 653 | V.forM_ icSlotMapPipelineToInput $ \slotIdx -> do 654 | slot <- readIORef (slotRefs ! slotIdx) 655 | forM_ (objectMap slot) $ \obj -> do 656 | modifyIORef (objCommands obj) $ \v -> v // [(icId,V.empty)] 657 | {- 658 | addition: 659 | - get an id from pipeline input 660 | - add to attached pipelines 661 | - generate slot mappings 662 | - update used objectArrays, and generate object commands for objects in the related objectArrays 663 | -} 664 | case input' of 665 | Nothing -> writeIORef glInput Nothing >> return Nothing 666 | Just input -> do 667 | let pipelinesRef = pipelines input 668 | oldPipelineV <- readIORef pipelinesRef 669 | (idx,shouldExtend) <- case V.findIndex isNothing oldPipelineV of 670 | Nothing -> do 671 | -- we don't have empty space, hence we double the vector size 672 | let len = V.length oldPipelineV 673 | modifyIORef pipelinesRef $ \v -> (V.concat [v,V.replicate len Nothing]) // [(len,Just p)] 674 | return (len,Just len) 675 | Just i -> do 676 | modifyIORef pipelinesRef $ \v -> v // [(i,Just p)] 677 | return (i,Nothing) 678 | -- create input connection 679 | let sm = slotMap input 680 | pToI = [i | n <- glSlotNames, let i = fromMaybe (error $ "setStorage - missing object array: " ++ n) $ Map.lookup n sm] 681 | iToP = V.update (V.replicate (Map.size sm) Nothing) (V.imap (\i v -> (v, Just i)) pToI) 682 | writeIORef glInput $ Just $ InputConnection idx input pToI iToP 683 | 684 | -- generate object commands for related objectArrays 685 | {- 686 | for each slot in pipeline: 687 | map slot name to input slot name 688 | for each object: 689 | generate command program vector => for each dependent program: 690 | generate object commands 691 | -} 692 | let slotV = slotVector input 693 | progV = glPrograms 694 | --texUnitMap = glTexUnitMapping p 695 | topUnis = uniformSetup input 696 | emptyV = V.replicate (V.length progV) [] 697 | extend v = case shouldExtend of 698 | Nothing -> v 699 | Just l -> V.concat [v,V.replicate l V.empty] 700 | V.forM_ (V.zip pToI glSlotPrograms) $ \(slotIdx,prgs) -> do 701 | slot <- readIORef $ slotV ! slotIdx 702 | forM_ (objectMap slot) $ \obj -> do 703 | let cmdV = emptyV // [(prgIdx,createObjectCommands glTexUnitMapping topUnis obj (progV ! prgIdx)) | prgIdx <- prgs] 704 | modifyIORef (objCommands obj) $ \v -> extend v // [(idx,cmdV)] 705 | -- generate stream commands 706 | V.forM_ glStreams $ \s -> do 707 | writeIORef (glStreamCommands s) $ createStreamCommands glTexUnitMapping topUnis (glStreamAttributes s) (glStreamPrimitive s) (progV ! glStreamProgram s) 708 | return Nothing 709 | {- 710 | track state: 711 | - render target 712 | - binded textures 713 | -} 714 | 715 | {- 716 | render steps: 717 | - update uniforms 718 | - per uniform setup 719 | - buffer setup (one buffer per object, which has per at least one object uniform) 720 | - new command: set uniform buffer (binds uniform buffer to program's buffer slot) 721 | - render slot steps: 722 | - set uniform buffer or set uniforms separately 723 | - set vertex and index array 724 | - call draw command 725 | -} 726 | {- 727 | storage alternatives: 728 | - interleaved / separated 729 | - VAO or VBOs 730 | -} 731 | {- 732 | strategy: 733 | step 1: generate commands for an object 734 | step 2: sort object merge and do optimization by filtering redundant commands 735 | -} 736 | {- 737 | design: 738 | runtime eleminiation of redundant buffer bind commands and redundant texture bind commands 739 | -} 740 | {- 741 | track: 742 | buffer binding on various targets: GL_ARRAY_BUFFER, GL_ELEMENT_ARRAY_BUFFER 743 | glEnable/DisableVertexAttribArray 744 | -} 745 | renderSlot :: IORef Int -> IORef GLuint -> IORef GLuint -> [GLObjectCommand] -> IO () 746 | renderSlot glDrawCallCounterRef glVertexBufferRef glIndexBufferRef cmds = forM_ cmds $ \cmd -> do 747 | let setup ref v m = do 748 | old <- readIORef ref 749 | unless (old == v) $ do 750 | writeIORef ref v 751 | m 752 | 753 | case cmd of 754 | GLSetVertexAttribArray idx buf size typ ptr -> do 755 | setup glVertexBufferRef buf $ glBindBuffer GL_ARRAY_BUFFER buf 756 | glEnableVertexAttribArray idx 757 | glVertexAttribPointer idx size typ (fromIntegral GL_FALSE) 0 ptr 758 | GLSetVertexAttribIArray idx buf size typ ptr -> do 759 | setup glVertexBufferRef buf $ glBindBuffer GL_ARRAY_BUFFER buf 760 | glEnableVertexAttribArray idx 761 | glVertexAttribIPointer idx size typ 0 ptr 762 | GLDrawArrays mode first count -> glDrawArrays mode first count >> modifyIORef glDrawCallCounterRef succ 763 | GLDrawElements mode count typ buf indicesPtr -> do 764 | setup glIndexBufferRef buf $ glBindBuffer GL_ELEMENT_ARRAY_BUFFER buf 765 | glDrawElements mode count typ indicesPtr 766 | modifyIORef glDrawCallCounterRef succ 767 | GLSetUniform idx (GLUniform ty ref) -> setUniform idx ty ref 768 | GLBindTexture txTarget tuRef (GLUniform _ ref) -> do 769 | txObjVal <- readIORef ref 770 | -- HINT: ugly and hacky 771 | with txObjVal $ \txObjPtr -> do 772 | txObj <- peek $ castPtr txObjPtr :: IO GLuint 773 | texUnit <- readIORef tuRef 774 | glActiveTexture $ GL_TEXTURE0 + fromIntegral texUnit 775 | glBindTexture txTarget txObj 776 | --putStrLn $ "to texture unit " ++ show texUnit ++ " texture object " ++ show txObj 777 | GLSetVertexAttrib idx val -> do 778 | glDisableVertexAttribArray idx 779 | setVertexAttrib idx val 780 | --isOk <- checkGL 781 | --putStrLn $ isOk ++ " - " ++ show cmd 782 | 783 | setupRenderTarget glInput GLRenderTarget{..} = do 784 | -- set target viewport 785 | let setMainScreenSize = do 786 | ic' <- readIORef glInput 787 | case ic' of 788 | Nothing -> return () 789 | Just ic -> do 790 | let input = icInput ic 791 | (w,h) <- readIORef $ screenSize input 792 | glViewport 0 0 (fromIntegral w) (fromIntegral h) 793 | 794 | case framebufferSize of 795 | Nothing -> setMainScreenSize 796 | Just (V3 w h _) -> glViewport 0 0 (fromIntegral w) (fromIntegral h) 797 | 798 | -- bind render target 799 | glBindFramebuffer GL_DRAW_FRAMEBUFFER framebufferObject 800 | case framebufferDrawbuffers of 801 | Nothing -> pure () 802 | Just bl -> withArray bl $ glDrawBuffers (fromIntegral $ length bl) 803 | 804 | setupDrawContext glForceSetup glDrawContextRef glInput new = do 805 | old <- readIORef glDrawContextRef 806 | writeIORef glDrawContextRef new 807 | force <- readIORef glForceSetup 808 | writeIORef glForceSetup False 809 | 810 | let setup :: Eq a => (GLDrawContext -> a) -> (a -> IO ()) -> IO () 811 | setup f m = case force of 812 | True -> m $ f new 813 | False -> do 814 | let a = f new 815 | unless (a == f old) $ m a 816 | 817 | setup glRenderTarget $ setupRenderTarget glInput 818 | setup glRasterContext $ setupRasterContext 819 | setup glAccumulationContext setupAccumulationContext 820 | setup glProgram glUseProgram 821 | 822 | -- setup texture mapping 823 | setup glTextureMapping $ mapM_ $ \(textureUnit,GLTexture{..}) -> do 824 | glActiveTexture (GL_TEXTURE0 + fromIntegral textureUnit) 825 | glBindTexture glTextureTarget glTextureObject 826 | 827 | -- setup sampler mapping 828 | setup glSamplerMapping $ mapM_ $ \(textureUnit,GLSampler{..}) -> do 829 | glBindSampler (GL_TEXTURE0 + fromIntegral textureUnit) glSamplerObject 830 | 831 | -- setup sampler uniform mapping 832 | forM_ (glSamplerUniformMapping new) $ \(textureUnit,GLSamplerUniform{..}) -> do 833 | glUniform1i glUniformBinding (fromIntegral textureUnit) 834 | writeIORef glUniformBindingRef (fromIntegral textureUnit) 835 | 836 | renderFrame :: GLRenderer -> IO () 837 | renderFrame GLRenderer{..} = do 838 | writeIORef glForceSetup True 839 | writeIORef glVertexBufferRef 0 840 | writeIORef glIndexBufferRef 0 841 | writeIORef glDrawCallCounterRef 0 842 | glBindVertexArray glVAO 843 | forM_ glCommands $ \cmd -> do 844 | case cmd of 845 | GLClearRenderTarget rt vals -> do 846 | setupRenderTarget glInput rt 847 | clearRenderTarget rt vals 848 | modifyIORef glDrawContextRef $ \ctx -> ctx {glRenderTarget = rt} 849 | 850 | GLRenderStream ctx streamIdx progIdx -> do 851 | setupDrawContext glForceSetup glDrawContextRef glInput ctx 852 | drawcmd <- readIORef (glStreamCommands $ glStreams ! streamIdx) 853 | renderSlot glDrawCallCounterRef glVertexBufferRef glIndexBufferRef drawcmd 854 | 855 | GLRenderSlot ctx slotIdx progIdx -> do 856 | input <- readIORef glInput 857 | case input of 858 | Nothing -> putStrLn "Warning: No pipeline input!" >> return () 859 | Just ic -> do 860 | let draw setupDone obj = readIORef (objEnabled obj) >>= \case 861 | False -> return setupDone 862 | True -> do 863 | unless setupDone $ setupDrawContext glForceSetup glDrawContextRef glInput ctx 864 | drawcmd <- readIORef $ objCommands obj 865 | --putStrLn "Render object" 866 | renderSlot glDrawCallCounterRef glVertexBufferRef glIndexBufferRef ((drawcmd ! icId ic) ! progIdx) 867 | return True 868 | --putStrLn $ "Rendering " ++ show (V.length objs) ++ " objects" 869 | readIORef (slotVector (icInput ic) ! (icSlotMapPipelineToInput ic ! slotIdx)) >>= \case 870 | GLSlot _ objs Ordered -> foldM_ (\a -> draw a . snd) False objs 871 | GLSlot objMap _ _ -> foldM_ draw False objMap 872 | 873 | --isOk <- checkGL 874 | --putStrLn $ isOk ++ " - " ++ show cmd 875 | --readIORef glDrawCallCounterRef >>= \n -> putStrLn (show n ++ " draw calls") 876 | 877 | data CGState 878 | = CGState 879 | { drawCommands :: [GLCommand] 880 | -- draw context data 881 | , rasterContext :: RasterContext 882 | , accumulationContext :: AccumulationContext 883 | , renderTarget :: GLRenderTarget 884 | , currentProgram :: ProgramName 885 | , samplerUniformMapping :: IntMap GLSamplerUniform 886 | , textureMapping :: IntMap GLTexture 887 | , samplerMapping :: IntMap GLSampler 888 | } 889 | 890 | initCGState = CGState 891 | { drawCommands = mempty 892 | -- draw context data 893 | , rasterContext = error "compileCommand: missing RasterContext" 894 | , accumulationContext = error "compileCommand: missing AccumulationContext" 895 | , renderTarget = error "compileCommand: missing RenderTarget" 896 | , currentProgram = error "compileCommand: missing Program" 897 | , samplerUniformMapping = mempty 898 | , textureMapping = mempty 899 | , samplerMapping = mempty 900 | } 901 | 902 | type CG a = State CGState a 903 | 904 | emit :: GLCommand -> CG () 905 | emit cmd = modify $ \s -> s {drawCommands = cmd : drawCommands s} 906 | 907 | drawContext programs = do 908 | GLProgram{..} <- (programs !) <$> gets currentProgram 909 | let f = take (Map.size inputTextures) . IntMap.toList 910 | GLDrawContext <$> gets rasterContext 911 | <*> gets accumulationContext 912 | <*> gets renderTarget 913 | <*> pure programObject 914 | <*> gets (f . textureMapping) 915 | <*> gets (f . samplerMapping) 916 | <*> gets (f . samplerUniformMapping) 917 | 918 | compileCommand :: Map String (IORef GLint) -> Vector GLSampler -> Vector GLTexture -> Vector GLRenderTarget -> Vector GLProgram -> Command -> CG () 919 | compileCommand texUnitMap samplers textures targets programs cmd = case cmd of 920 | SetRasterContext rCtx -> modify $ \s -> s {rasterContext = rCtx} 921 | SetAccumulationContext aCtx -> modify $ \s -> s {accumulationContext = aCtx} 922 | SetRenderTarget rt -> modify $ \s -> s {renderTarget = targets ! rt} 923 | SetProgram p -> modify $ \s -> s {currentProgram = p} 924 | SetSamplerUniform n tu -> do 925 | p <- currentProgram <$> get 926 | case Map.lookup n (inputTextures $ programs ! p) of 927 | Nothing -> return () -- TODO: some drivers does heavy cross stage (vertex/fragment) dead code elimination; fail $ "internal error (SetSamplerUniform)! - " ++ show cmd 928 | Just i -> case Map.lookup n texUnitMap of 929 | Nothing -> fail $ "internal error (SetSamplerUniform - IORef)! - " ++ show cmd 930 | Just r -> modify $ \s -> s {samplerUniformMapping = IntMap.insert tu (GLSamplerUniform i r) $ samplerUniformMapping s} 931 | SetTexture tu t -> modify $ \s -> s {textureMapping = IntMap.insert tu (textures ! t) $ textureMapping s} 932 | SetSampler tu i -> modify $ \s -> s {samplerMapping = IntMap.insert tu (maybe (GLSampler 0) (samplers !) i) $ samplerMapping s} 933 | 934 | -- draw commands 935 | RenderSlot slot -> do 936 | p <- gets currentProgram 937 | ctx <- drawContext programs 938 | emit $ GLRenderSlot ctx slot p 939 | RenderStream stream -> do 940 | p <- gets currentProgram 941 | ctx <- drawContext programs 942 | emit $ GLRenderStream ctx stream p 943 | ClearRenderTarget vals -> do 944 | rt <- gets renderTarget 945 | emit $ GLClearRenderTarget rt $ V.toList vals 946 | {- 947 | GenerateMipMap tu -> do 948 | tb <- textureBinding <$> get 949 | case IM.lookup tu tb of 950 | Nothing -> fail "internal error (GenerateMipMap)!" 951 | Just tex -> return $ GLGenerateMipMap (GL_TEXTURE0 + fromIntegral tu) (glTextureTarget tex) 952 | -} 953 | --------------------------------------------------------------------------------