lambdacube-gl (empty) → 0.2.0
raw patch · 11 files changed
+4321/−0 lines, 11 filesdep +OpenGLRawdep +basedep +binarysetup-changed
Dependencies added: OpenGLRaw, base, binary, bitmap, bytestring, bytestring-trie, containers, lambdacube-core, lambdacube-edsl, language-glsl, mtl, prettyclass, vector
Files
- LICENSE +28/−0
- Setup.hs +2/−0
- lambdacube-gl.cabal +82/−0
- src/lib/LambdaCube/GL.hs +294/−0
- src/lib/LambdaCube/GL/Backend.hs +427/−0
- src/lib/LambdaCube/GL/Compile.hs +590/−0
- src/lib/LambdaCube/GL/Data.hs +336/−0
- src/lib/LambdaCube/GL/GLSLCodeGen.hs +867/−0
- src/lib/LambdaCube/GL/Mesh.hs +229/−0
- src/lib/LambdaCube/GL/Type.hs +476/−0
- src/lib/LambdaCube/GL/Util.hs +990/−0
+ LICENSE view
@@ -0,0 +1,28 @@+Copyright (c) 2009-2013, Csaba Hruska+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice,+ this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of its contributors may be+ used to endorse or promote products derived from this software without+ specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE+LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR+CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF+SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS+INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN+CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)+ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ lambdacube-gl.cabal view
@@ -0,0 +1,82 @@+Name: lambdacube-gl+Version: 0.2.0+Cabal-Version: >= 1.10+Build-Type: Simple+License: BSD3+License-File: LICENSE+Author: Csaba Hruska, Gergely Patai+Maintainer: csaba (dot) hruska (at) gmail (dot) com+Stability: experimental+Homepage: http://www.haskell.org/haskellwiki/LambdaCubeEngine+Bug-Reports: https://github.com/csabahruska/lc-dsl/issues+Category: Graphics+Tested-With: GHC == 7.8.3+Synopsis: OpenGL backend for LambdaCube graphics language (main package)+Description:+ LambdaCube 3D is a domain specific language and library that makes+ it possible to program GPUs in a purely functional style.+ Programming with LambdaCube constitutes of composing a data-flow+ description, which is compiled into a specialised library. The+ language provides a uniform way to define shaders and compositor+ chains by treating both streams and framebuffers as first-class+ values.+ .+ As a user of the library you only need to import the "LambdaCube.GL" and+ "LambdaCube.GL.Mesh" modules. You should check out the pointers at <http://lambdacube3d.wordpress.com/getting-started/>+ to understand the principle behind the library, and also have a good look+ at the @lambdacube-samples@ package.++Library+ default-language: Haskell2010+ hs-source-dirs: src/lib+ Build-Depends: + base >=4.6 && <5,+ binary >=0.7 && <0.8,+ bytestring >=0.10 && <0.11,+ containers >=0.5 && <0.6,+ mtl >=2.2 && <2.3,+ vector >=0.10 && <0.11,+ prettyclass >=1.0 && <1.1,++ bytestring-trie >=0.2 && <0.3,+ OpenGLRaw >=1.5 && <1.6,+ bitmap >= 0.0.2 && <0.0.3,+ language-glsl >=0.1 && <0.2,++ lambdacube-core == 0.2.0,+ lambdacube-edsl == 0.2.0++ Exposed-modules:+ LambdaCube.GL+ LambdaCube.GL.Mesh++ other-modules:+ LambdaCube.GL.Backend+ LambdaCube.GL.Compile+ LambdaCube.GL.Data+ LambdaCube.GL.GLSLCodeGen+ LambdaCube.GL.Type+ LambdaCube.GL.Util++ GHC-options:+-- -Werror+ -Wall+ -fno-warn-missing-signatures+ -fno-warn-name-shadowing+ -fno-warn-orphans+ -fno-warn-unused-binds+ -fno-warn-unused-do-bind+ -fspec-constr-count=10+ -funbox-strict-fields+ -O2+-- for profiling+-- -auto-all+-- -caf-all++ default-extensions:+ DataKinds+ DeriveDataTypeable+ OverloadedStrings+ ParallelListComp+ ScopedTypeVariables+ TupleSections
+ src/lib/LambdaCube/GL.hs view
@@ -0,0 +1,294 @@+module LambdaCube.GL (+ -- language+ module LambdaCube.Language.Type,+ module LambdaCube.Language.ReifyType,+ module LambdaCube.Language.HOAS,+ module LambdaCube.Language,+ Int32,+ Word32,+ uniformBool,+ uniformV2B,+ uniformV3B,+ uniformV4B,++ uniformWord,+ uniformV2U,+ uniformV3U,+ uniformV4U,++ uniformInt,+ uniformV2I,+ uniformV3I,+ uniformV4I,++ uniformFloat,+ uniformV2F,+ uniformV3F,+ uniformV4F,++ uniformM22F,+ uniformM23F,+ uniformM24F,+ uniformM32F,+ uniformM33F,+ uniformM34F,+ uniformM42F,+ uniformM43F,+ uniformM44F,++ uniformFTexture2D,++ -- backend+ Buffer,+ compileBuffer,+ updateBuffer,+ bufferSize,+ arraySize,+ arrayType,++ Renderer,+ compileRenderer,+ slotUniform,+ slotStream,+ uniformSetter,+ render,+ dispose,+ setScreenSize,+ samplerOutput,++ Object,+ addObject,+ removeObject,+ objectUniformSetter,+ enableObject,++ -- texture (temporary)+ compileTexture2DRGBAF,+ updateTexture2DRGBAF,++ -- EDSL reuses types from Core+ V2(..), V3(..), V4(..),+ M22F, M23F, M24F, M32F, M33F, M34F, M42F, M43F, M44F,+ V2F, V3F, V4F, V2I, V3I, V4I, V2U, V3U, V4U, V2B, V3B, V4B,+ --InputType(..),+ PointSpriteCoordOrigin(..),+ PointSize(..),+ PolygonOffset(..),+ FrontFace(..),+ PolygonMode(..),+ ProvokingVertex(..),+ CullMode(..),+ DepthFunction,+ ComparisonFunction(..),+ StencilOperation(..),+ BlendEquation(..),+ BlendingFactor(..),+ LogicOperation(..),+ StencilOps(..),+ StencilTests(..),+ StencilTest(..),+ Filter(..),+ EdgeMode(..),++ -- types for pipeline input+ InputSetter,+ BufferSetter,+ ArrayType(..),+ Array(..),+ Primitive(..),+ StreamType(..),+ Stream(..),+ IndexStream(..),+ TextureData(..),+ SetterFun+) where++import Data.Int+import Data.Word++import LambdaCube.Core.Type++import LambdaCube.Language.ReifyType hiding (Shadow)+import LambdaCube.Language.Type+import LambdaCube.Language.HOAS+import LambdaCube.Language+import qualified LambdaCube.Language.Type as H+import qualified LambdaCube.Language.HOAS as H++import qualified LambdaCube.Core.DeBruijn as U+import LambdaCube.Convert.ToDeBruijn++--import LambdaCube.GL.Backend hiding (compileRenderer)+--import LambdaCube.GL.Compile+import LambdaCube.GL.Data+import LambdaCube.GL.Type+--import LambdaCube.GL.Util (Buffer)+import qualified LambdaCube.GL.Backend as GL++import Control.Monad.State+--import Data.ByteString.Char8 (ByteString)+import Data.ByteString.Char8 as SB+import Data.Trie as T++import LambdaCube.Core.Util.BiMap+import Data.List as L+import qualified Data.IntMap as IM++import System.IO as IO++compileRenderer :: H.GPOutput H.SingleOutput -> IO Renderer+compileRenderer l = do++ let root = U.toExp dag l'+ (l', dag) = runState (U.unN $ convertGPOutput l) U.emptyDAG+ U.DAG (BiMap _ em) tm _ _ _ = dag+ unis = U.mkExpUni dag+ gunis = U.mkGPUni dag+ dag' = dag {U.expUniverseV = unis, U.gpUniverseV = gunis}+ --print unis+ --print gunis+ print l'+ mapM print $ L.zipWith (\(i,e) (_,t) -> (i,(t,e))) (IM.toList em) (IM.toList tm)++ --(root, dag) <- convert l+ IO.hPutStrLn stderr "GL.compileRenderer"+ GL.compileRenderer dag' root++nullSetter :: ByteString -> String -> a -> IO ()+nullSetter n t _ = return () -- Prelude.putStrLn $ "WARNING: unknown uniform: " ++ SB.unpack n ++ " :: " ++ t++uniformBool :: ByteString -> Trie InputSetter -> SetterFun Bool+uniformV2B :: ByteString -> Trie InputSetter -> SetterFun V2B+uniformV3B :: ByteString -> Trie InputSetter -> SetterFun V3B+uniformV4B :: ByteString -> Trie InputSetter -> SetterFun V4B++uniformWord :: ByteString -> Trie InputSetter -> SetterFun Word32+uniformV2U :: ByteString -> Trie InputSetter -> SetterFun V2U+uniformV3U :: ByteString -> Trie InputSetter -> SetterFun V3U+uniformV4U :: ByteString -> Trie InputSetter -> SetterFun V4U++uniformInt :: ByteString -> Trie InputSetter -> SetterFun Int32+uniformV2I :: ByteString -> Trie InputSetter -> SetterFun V2I+uniformV3I :: ByteString -> Trie InputSetter -> SetterFun V3I+uniformV4I :: ByteString -> Trie InputSetter -> SetterFun V4I++uniformFloat :: ByteString -> Trie InputSetter -> SetterFun Float+uniformV2F :: ByteString -> Trie InputSetter -> SetterFun V2F+uniformV3F :: ByteString -> Trie InputSetter -> SetterFun V3F+uniformV4F :: ByteString -> Trie InputSetter -> SetterFun V4F++uniformM22F :: ByteString -> Trie InputSetter -> SetterFun M22F+uniformM23F :: ByteString -> Trie InputSetter -> SetterFun M23F+uniformM24F :: ByteString -> Trie InputSetter -> SetterFun M24F+uniformM32F :: ByteString -> Trie InputSetter -> SetterFun M32F+uniformM33F :: ByteString -> Trie InputSetter -> SetterFun M33F+uniformM34F :: ByteString -> Trie InputSetter -> SetterFun M34F+uniformM42F :: ByteString -> Trie InputSetter -> SetterFun M42F+uniformM43F :: ByteString -> Trie InputSetter -> SetterFun M43F+uniformM44F :: ByteString -> Trie InputSetter -> SetterFun M44F++uniformFTexture2D :: ByteString -> Trie InputSetter -> SetterFun TextureData++uniformBool n is = case T.lookup n is of+ Just (SBool (Setter fun)) -> fun+ _ -> nullSetter n "Bool"++uniformV2B n is = case T.lookup n is of+ Just (SV2B (Setter fun)) -> fun+ _ -> nullSetter n "V2B"++uniformV3B n is = case T.lookup n is of+ Just (SV3B (Setter fun)) -> fun+ _ -> nullSetter n "V3B"++uniformV4B n is = case T.lookup n is of+ Just (SV4B (Setter fun)) -> fun+ _ -> nullSetter n "V4B"++uniformWord n is = case T.lookup n is of+ Just (SWord (Setter fun)) -> fun+ _ -> nullSetter n "Word"++uniformV2U n is = case T.lookup n is of+ Just (SV2U (Setter fun)) -> fun+ _ -> nullSetter n "V2U"++uniformV3U n is = case T.lookup n is of+ Just (SV3U (Setter fun)) -> fun+ _ -> nullSetter n "V3U"++uniformV4U n is = case T.lookup n is of+ Just (SV4U (Setter fun)) -> fun+ _ -> nullSetter n "V4U"++uniformInt n is = case T.lookup n is of+ Just (SInt (Setter fun)) -> fun+ _ -> nullSetter n "Int"++uniformV2I n is = case T.lookup n is of+ Just (SV2I (Setter fun)) -> fun+ _ -> nullSetter n "V2I"++uniformV3I n is = case T.lookup n is of+ Just (SV3I (Setter fun)) -> fun+ _ -> nullSetter n "V3I"++uniformV4I n is = case T.lookup n is of+ Just (SV4I (Setter fun)) -> fun+ _ -> nullSetter n "V4I"++uniformFloat n is = case T.lookup n is of+ Just (SFloat (Setter fun)) -> fun+ _ -> nullSetter n "Float"++uniformV2F n is = case T.lookup n is of+ Just (SV2F (Setter fun)) -> fun+ _ -> nullSetter n "V2F"++uniformV3F n is = case T.lookup n is of+ Just (SV3F (Setter fun)) -> fun+ _ -> nullSetter n "V3F"++uniformV4F n is = case T.lookup n is of+ Just (SV4F (Setter fun)) -> fun+ _ -> nullSetter n "V4F"++uniformM22F n is = case T.lookup n is of+ Just (SM22F (Setter fun)) -> fun+ _ -> nullSetter n "M22F"++uniformM23F n is = case T.lookup n is of+ Just (SM23F (Setter fun)) -> fun+ _ -> nullSetter n "M23F"++uniformM24F n is = case T.lookup n is of+ Just (SM24F (Setter fun)) -> fun+ _ -> nullSetter n "M24F"++uniformM32F n is = case T.lookup n is of+ Just (SM32F (Setter fun)) -> fun+ _ -> nullSetter n "M32F"++uniformM33F n is = case T.lookup n is of+ Just (SM33F (Setter fun)) -> fun+ _ -> nullSetter n "M33F"++uniformM34F n is = case T.lookup n is of+ Just (SM34F (Setter fun)) -> fun+ _ -> nullSetter n "M34F"++uniformM42F n is = case T.lookup n is of+ Just (SM42F (Setter fun)) -> fun+ _ -> nullSetter n "M42F"++uniformM43F n is = case T.lookup n is of+ Just (SM43F (Setter fun)) -> fun+ _ -> nullSetter n "M43F"++uniformM44F n is = case T.lookup n is of+ Just (SM44F (Setter fun)) -> fun+ _ -> nullSetter n "M44F"++uniformFTexture2D n is = case T.lookup n is of+ Just (SFTexture2D (Setter fun)) -> fun+ _ -> nullSetter n "FTexture2D"
+ src/lib/LambdaCube/GL/Backend.hs view
@@ -0,0 +1,427 @@+module LambdaCube.GL.Backend where++import Debug.Trace++import Control.Applicative+import Control.Monad+import Data.ByteString.Char8 (ByteString)+import Data.IORef+import Data.List as L+import Data.Maybe+import Data.Set (Set)+import Data.Map (Map)+import Data.Trie as T+import Foreign+import qualified Data.ByteString.Char8 as SB+import qualified Data.IntMap as IntMap+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.Traversable as T+import qualified Data.Vector as V+import qualified Data.Vector.Unboxed.Mutable as MV++import Graphics.Rendering.OpenGL.Raw.Core32+ ( GLuint+ -- FRAMEBUFFER related *+ -- create+ , glBindFramebuffer+ , glDeleteFramebuffers+ , glGenFramebuffers+ -- content manipulation+ , glActiveTexture+ , glBindRenderbuffer+ , glBindTexture+ , glDeleteTextures+ , glDrawBuffer+ , glDrawBuffers+ , glFramebufferRenderbuffer+ , glFramebufferTexture+ , glFramebufferTexture2D+ , glGenRenderbuffers+ , glRenderbufferStorage+ , glViewport+ , gl_BACK_LEFT+ , gl_COLOR_ATTACHMENT0+ , gl_DEPTH_ATTACHMENT+ , gl_DEPTH_COMPONENT32+ , gl_DRAW_FRAMEBUFFER+ , gl_MAX_COMBINED_TEXTURE_IMAGE_UNITS+ , gl_NONE+ , gl_RENDERBUFFER+ , gl_TEXTURE0+ , gl_TEXTURE_2D+ , gl_UNSIGNED_BYTE+ , glTexImage2D+ , gl_TEXTURE_2D_ARRAY+ , glTexImage3D+ , gl_TEXTURE_MAX_LEVEL+ , glTexParameteri+ , gl_TEXTURE_BASE_LEVEL+ , gl_NEAREST+ , gl_TEXTURE_MIN_FILTER+ , gl_TEXTURE_MAG_FILTER+ , gl_CLAMP_TO_EDGE+ , gl_TEXTURE_WRAP_S+ , gl_TEXTURE_WRAP_T+ , gl_DEPTH_COMPONENT32+ , gl_DEPTH_COMPONENT+ , glGenTextures+ )++import LambdaCube.Core.Type+import LambdaCube.Core.DeBruijn+import LambdaCube.Core.Traversals+import LambdaCube.Core.Util.BiMap++import LambdaCube.GL.Type+import LambdaCube.GL.Util+import LambdaCube.GL.GLSLCodeGen+import LambdaCube.GL.Compile++import qualified Data.IntMap as IM+-- Renderer++nubS :: Ord a => [a] -> [a]+nubS = Set.toList . Set.fromList++findFetch :: DAG -> Exp -> Maybe Exp+findFetch dag f = listToMaybe [a | a@Fetch {} <- drawOperations dag f]++---------------------------+-- odered according pass dependency (topology order)+{-+findFrameBuffer+gpUniverse+-}+orderedFrameBuffersFromGP :: DAG -> Exp -> [Exp]+orderedFrameBuffersFromGP dag r = es --[e | e@(Accumulate{}) <- IM.elems m]+ where+ rfb = findFrameBuffer dag r+ txl = concat [map (findFrameBuffer dag . toExp dag) l | Texture _ _ _ l <- IM.elems m]+ es = map (toExp dag) . nubS . map (toExpId dag) $ rfb : txl+ BiMap _ m = dagExp dag+{-+orderedFrameBuffersFromGP dag orig = order deps+ where + deps :: Map Exp (Set Exp)+ deps = add Map.empty $ findFrameBuffer dag orig++ add :: Map Exp (Set Exp) -> Exp -> Map Exp (Set Exp)+ add m fb = Map.unionsWith Set.union $ m' : map (add m') fbl+ where+ m' = Map.alter fun fb m+ fbl = concat [map (findFrameBuffer dag . toExp dag) l | Sampler _ _ tx <- concatMap (expUniverse' dag) (gpUniverse' dag fb), Texture _ _ _ l <- [toExp dag tx]]+ fbs = Set.fromList fbl+ fun Nothing = Just fbs+ fun (Just a) = Just (a `Set.union` fbs)++ order :: Map Exp (Set Exp) -> [Exp]+ order d+ | Map.null d = []+ | otherwise = leaves ++ order (Map.map (Set.\\ (Set.fromList leaves)) hasDeps)+ where+ leaves = Map.keys noDeps+ (noDeps,hasDeps) = Map.partition Set.null d+-}+---------------------------++printGLStatus = checkGL >>= print_+printFBOStatus = checkFBO >>= print_++mkSlotDescriptor :: Set Exp -> IO SlotDescriptor+mkSlotDescriptor gps = SlotDescriptor gps <$> newIORef Set.empty++mkRenderTextures :: DAG -> [Exp] -> Maybe (ByteString,Exp) -> IO (Map Exp String, Map Exp String, Map Exp GLuint, IO (), Exp -> [Exp])+mkRenderTextures dag allGPs samplerOutData = do+ let samplers = nubS $ [s | s@Sampler {} <- expUniverse' dag allGPs] ++ [smp | (_,smp) <- maybeToList samplerOutData]+ samplersWithTexture = nubS [s | s@(Sampler _ _ tx) <- samplers, Texture {} <- [toExp dag tx]]+ -- collect all render textures refers to a FrameBuffer+ isReferred :: Exp -> Exp -> Bool+ isReferred f (Sampler _ _ tx) = findFrameBuffer dag (toExp dag f') == f+ where+ Texture _ _ _ [f'] = toExp dag tx+ isReferred _ _ = False+ dependentSamplers f = filter (isReferred f) samplersWithTexture+ -- texture attributes: GL texture target (1D,2D,etc), arity, float/word/int, size, mipmap+ -- sampler attributes: filter, edge mode+ -- TODO: also build sampler name map: Map (Exp :: Sampler) (ByteString, GLTexObj)++ -- question: how should we handle the Stencil and Depth textures at multipass rendering+ (renderTexNameList,renderTexGLObjList,disposeTex) <- fmap unzip3 $ forM (zip [0..] samplersWithTexture) $ \(sIdx,smp) -> do+ to <- createGLTextureObject dag smp+ putStr (" -- Render Texture " ++ show sIdx ++ "(texture object " ++ show to ++ "): ") >> printGLStatus >> putStrLn ""+ return ((smp,"renderTex_" ++ show sIdx),(smp,to),with to $ \pto -> glDeleteTextures 1 pto)+ let renderTexName = Map.fromList renderTexNameList+ renderTexGLObj = Map.fromList renderTexGLObjList+ texSlotName = Map.fromList $ nubS [(s,SB.unpack n) | s@(Sampler _ _ txExp) <- samplers, TextureSlot n _ <- [toExp dag txExp]]+ return (texSlotName, renderTexName, renderTexGLObj, sequence_ disposeTex, dependentSamplers)++mkRenderDescriptor :: T.Trie InputGetter -> DAG -> RenderState -> Map Exp String -> Map Exp String -> Map Exp GLuint -> Exp -> IO RenderDescriptor+mkRenderDescriptor uniformGetterTrie dag rendState texSlotName renderTexName renderTexGLObj f = case f of+ FrameBuffer imgs -> RenderDescriptor T.empty T.empty (compileClearFrameBuffer f) (return ()) <$> newIORef (ObjectSet (return ()) Map.empty) <*> pure (length [() | ColorImage {} <- imgs])+ Accumulate {} -> do+ {- + setup texture input, before each slot's render operation we should setup texture unit mapping+ - we have to create the TextureUnit layout+ - create TextureUnit setter action+ - the shader should be setup at the creation+ - we have to setup texture binding before each render action call+ -}+ let usedRenderSamplers = nubS [s | s@(Sampler _ _ te) <- expUniverse' dag f, Texture {} <- [toExp dag te]]+ usedSlotSamplers = nubS [s | s@(Sampler _ _ te) <- expUniverse' dag f, TextureSlot {} <- [toExp dag te]]+ usedRenderTexName = [(s,n) | s <- usedRenderSamplers, let Just n = Map.lookup s renderTexName]+ usedTexSlotName = [(s,n) | s <- usedSlotSamplers, let Just n = Map.lookup s texSlotName]+ renderTexObjs = [txObj | s <- usedRenderSamplers, let Just txObj = Map.lookup s renderTexGLObj]+ texUnitState = textureUnitState rendState+ textureSetup = forM_ (zip renderTexObjs [0.. MV.length texUnitState-1]) $ \(texObj,texUnitIdx) -> do+ let texObj' = fromIntegral texObj+ curTexObj <- MV.read texUnitState texUnitIdx+ when (curTexObj /= texObj') $ do+ MV.write texUnitState texUnitIdx texObj'+ glActiveTexture $ gl_TEXTURE0 + fromIntegral texUnitIdx+ glBindTexture gl_TEXTURE_2D texObj+ putStrLn_ $ "CMD: glActiveTexture " ++ show texUnitIdx+ putStrLn_ $ "CMD: glBindTexture gl_TEXTURE_2D " ++ show texObj+ --putStr (" -- Texture bind (TexUnit " ++ show (texUnitIdx,texObj) ++ " TexObj): ") >> printGLStatus >> putStrLn ""++ drawRef <- newIORef $ ObjectSet (return ()) Map.empty+ (rA,dA,uT,sT,outColorCnt) <- compileRenderFrameBuffer rendState uniformGetterTrie dag usedRenderTexName usedTexSlotName drawRef f+ return $ RenderDescriptor+ { uniformLocation = uT+ , streamLocation = sT+ , renderAction = textureSetup >> rA+ , disposeAction = dA+ , drawObjectsIORef = drawRef+ , fragmentOutCount = outColorCnt+ }+ _ -> error $ "GP node type error: should be FrameBuffer but got: " ++ (head $ (words $ show f) ++ [])++-- FIXME: currently we expect ScreenOut to be the last operation+mkPassSetup :: IORef (Word,Word) -> RenderState -> DAG -> Map Exp GLuint -> (Exp -> [Exp]) -> (Bool,Int,Int) -> Exp -> IO (IO (), IO ())+mkPassSetup screenSizeIORef rendState dag renderTexGLObj dependentSamplers (isLast,outIdx,outCnt) fb = case isLast of+ True -> do+ putStrLn $ " -- last pass output count: " ++ show outCnt ++ " outIdx: " ++ show outIdx+ let setup = do+ (screenW,screenH) <- readIORef screenSizeIORef+ writeIORef (renderTargetSize rendState) $ V2 (fromIntegral screenW) (fromIntegral screenH)+ glViewport 0 0 (fromIntegral screenW) (fromIntegral screenH)+ putStrLn_ $ "CMD: glBindFramebuffer gl_DRAW_FRAMEBUFFER 0"+ glBindFramebuffer gl_DRAW_FRAMEBUFFER 0+ let fboMapping = [if i == outIdx then gl_BACK_LEFT else gl_NONE | i <- [1..outCnt]]+ withArray fboMapping $ glDrawBuffers (fromIntegral $ length fboMapping)+ --putStr " -- default FB bind: " >> printGLStatus >> putStrLn ""+ return (setup,return ())+ False -> do+ -- setup each pass's FBO output, attach RenderTarget textures to source FBO+ putStrLn " -- FBO init: "++ glFBO <- alloca $! \pbo -> glGenFramebuffers 1 pbo >> peek pbo+ putStr " - alloc: " >> printGLStatus >> putStrLn ""+ glBindFramebuffer gl_DRAW_FRAMEBUFFER glFBO+ putStr " - bind: " >> printGLStatus >> putStrLn ""+ let depSamplers = dependentSamplers fb+ hasDepthOp = case fb of+ Accumulate aCtx _ _ _ _ -> not $ L.null [() | DepthOp {} <- ops]+ where AccumulationContext _ ops = toExp dag aCtx+ FrameBuffer imgs -> not $ L.null [() | DepthImage {} <- imgs]+ ----------+ -- FIXME: samplers must contain the fragment value's output index!+ ----------+ (layerCnts,texSizes,fboMapping) <- fmap unzip3 $ forM (zip [0..] depSamplers) $ \(i,smp) -> do+ let Sampler _ _ txExp = smp+ Texture txType ts NoMip [prjFBExp] = toExp dag txExp+ PrjFrameBuffer _ prjIdx _ = toExp dag prjFBExp+ Just txObj = Map.lookup smp renderTexGLObj+ colorNumber = outCnt - prjIdx - 1+ attachSingleLayer = glFramebufferTexture2D gl_DRAW_FRAMEBUFFER (gl_COLOR_ATTACHMENT0 + fromIntegral i) gl_TEXTURE_2D txObj 0+ attachMultiLayer = glFramebufferTexture gl_DRAW_FRAMEBUFFER (gl_COLOR_ATTACHMENT0 + fromIntegral i) txObj 0+ lc <- case txType of+ Texture2D _ ln+ | ln <= 1 -> attachSingleLayer >> return ln+ | otherwise -> attachMultiLayer >> return ln+ TextureCube _ -> attachMultiLayer >> return 6+ putStr (" - attach to color slot #" ++ show i ++ " texture object #" ++ show txObj ++ " with color number #" ++ show colorNumber ++ ": ") >> printGLStatus >> putStrLn ""+ return (lc, ts, (colorNumber,gl_COLOR_ATTACHMENT0 + fromIntegral i)) -- FIXME: calculate FBO attachment index properly, index reffered from right+ let fboMappingMap = IntMap.fromList fboMapping+ fboMappingList = [IntMap.findWithDefault gl_NONE i fboMappingMap | i <- [0..outCnt-1]]+ withArray fboMappingList $ glDrawBuffers $ fromIntegral outCnt+ putStrLn $ " - FBO mapping: " ++ show [if i == gl_NONE then "gl_NONE" else ("gl_COLOR_ATTACHMENT" ++ (show $ i - gl_COLOR_ATTACHMENT0)) | i <- fboMappingList]+ putStr " - mappig setup: " >> printGLStatus >> putStrLn ""++ -- check all texture size maches+ unless (all (== head (texSizes ++ error "texSizes")) texSizes) $ error ("Framebuffer attachment size mismatch! \n" ++ " - sizes: " ++ show texSizes)+ -- create and attach depth buffer+ let VV2U (V2 depthW depthH) = head $ texSizes ++ error "texSizes2"+ when hasDepthOp $ do+ {-+ depthTex <- alloca $! \pto -> glGenRenderbuffers 1 pto >> peek pto+ putStr " - alloc depth texture: " >> printGLStatus >> putStrLn ""+ glBindRenderbuffer gl_RENDERBUFFER depthTex+ putStr " - bind depth texture: " >> printGLStatus >> putStrLn ""+ glRenderbufferStorage gl_RENDERBUFFER gl_DEPTH_COMPONENT32 (fromIntegral depthW) (fromIntegral depthH)+ putStr " - define depth texture: " >> printGLStatus >> putStrLn ""+ glFramebufferRenderbuffer gl_DRAW_FRAMEBUFFER gl_DEPTH_ATTACHMENT gl_RENDERBUFFER depthTex+ putStr " - attach depth texture: " >> printGLStatus >> putStrLn ""+ -}+ depthTex <- alloca $! \pto -> glGenTextures 1 pto >> peek pto+ putStr " - alloc depth texture: " >> printGLStatus >> putStrLn ""+ let layerCnt = head $ layerCnts ++ error "layerCnts"+ txTarget = if layerCnt > 1 then gl_TEXTURE_2D_ARRAY else gl_TEXTURE_2D+ internalFormat = fromIntegral gl_DEPTH_COMPONENT --32+ dataFormat = fromIntegral gl_DEPTH_COMPONENT+ glBindTexture txTarget depthTex+ putStr " - bind depth texture: " >> printGLStatus >> putStrLn ""+ -- temp+ glTexParameteri txTarget gl_TEXTURE_WRAP_S $ fromIntegral gl_CLAMP_TO_EDGE+ glTexParameteri txTarget gl_TEXTURE_WRAP_T $ fromIntegral gl_CLAMP_TO_EDGE+ glTexParameteri txTarget gl_TEXTURE_MAG_FILTER $ fromIntegral gl_NEAREST+ glTexParameteri txTarget gl_TEXTURE_MIN_FILTER $ fromIntegral gl_NEAREST+ glTexParameteri txTarget gl_TEXTURE_BASE_LEVEL 0+ glTexParameteri txTarget gl_TEXTURE_MAX_LEVEL 0+ -- temp end+ case layerCnt > 1 of+ True -> glTexImage3D gl_TEXTURE_2D_ARRAY 0 internalFormat (fromIntegral depthW) (fromIntegral depthH) (fromIntegral layerCnt) 0 dataFormat gl_UNSIGNED_BYTE nullPtr+ False -> glTexImage2D gl_TEXTURE_2D 0 internalFormat (fromIntegral depthW) (fromIntegral depthH) 0 dataFormat gl_UNSIGNED_BYTE nullPtr+ putStr " - define depth texture: " >> printGLStatus >> putStrLn ""+ case layerCnt > 1 of+ True -> glFramebufferTexture gl_DRAW_FRAMEBUFFER gl_DEPTH_ATTACHMENT depthTex 0+ False -> glFramebufferTexture2D gl_DRAW_FRAMEBUFFER gl_DEPTH_ATTACHMENT gl_TEXTURE_2D depthTex 0+ putStr " - attach depth texture: " >> printGLStatus >> putStrLn ""+++ putStr " - check FBO completeness: " >> printFBOStatus >> putStrLn ""++ let renderAct = do+ --printGLStatus >> putStrLn ""+ putStrLn_ $ "CMD: glBindFramebuffer gl_DRAW_FRAMEBUFFER " ++ show glFBO+ glBindFramebuffer gl_DRAW_FRAMEBUFFER glFBO+ printGLStatus+ writeIORef (renderTargetSize rendState) $ V2 (fromIntegral depthW) (fromIntegral depthH)+ glViewport 0 0 (fromIntegral depthW) (fromIntegral depthH)+ --putStr " -- FBO bind: " >> printGLStatus >> putStrLn ""+ --putStr " -- FBO status: " >> printFBOStatus >> putStrLn ""+ disposeAct = do+ with glFBO $ \pbo -> glDeleteFramebuffers 1 pbo+ --with depthTex $ \pto -> glDeleteTextures 1 pto+ return (renderAct,disposeAct)++mkRenderState :: IO RenderState+mkRenderState = do+ maxTextureUnits <- glGetIntegerv1 gl_MAX_COMBINED_TEXTURE_IMAGE_UNITS+ texUnitState <- MV.new $ fromIntegral maxTextureUnits+ MV.set texUnitState (-1)+ rtSize <- newIORef $ V2 0 0+ return $ RenderState+ { textureUnitState = texUnitState+ , renderTargetSize = rtSize+ }+{-+ Note: Input mapping problem+ more programs use the same slot -> minimize vertex attribute mapping collisions (best case: use the same mapping)+ more programs use the same uniform -> minimize uniform mapping collisions (best case: use the same mapping)+-}+-- FIXME: implement properly+compileRenderer :: DAG -> Exp -> IO Renderer+compileRenderer dag outExp = do+ let (samplerOutData,gp,idx) = case outExp of+ ScreenOut img -> (Nothing,toExp dag gpId,idx)+ where+ PrjFrameBuffer n idx gpId = toExp dag img+ SamplerOut outName smpIdx -> (Just (outName,smp),toExp dag gpId,idx)+ where+ smp@(Sampler _ _ tex) = toExp dag smpIdx+ Texture _ _ _ [img] = toExp dag tex+ PrjFrameBuffer n idx gpId = toExp dag img++ unis :: Exp -> [(ByteString,InputType)]+ unis fb = nubS [(name,t) | u@(Uni name) <- expUniverse' dag fb, let [t] = codeGenType $ expType dag u] +++ nubS [(name,t) | s@(Sampler _ _ ts) <- expUniverse' dag fb+ , TextureSlot name _ <- [toExp dag ts]+ , let [t] = codeGenType $ expType dag s]++ ordFBs = orderedFrameBuffersFromGP dag gp+ allGPs = Set.toList $ Set.unions $ map (Set.fromList . gpUniverse' dag) $ nubS ordFBs++ -- collect slot info: name, primitive type, stream input, uniform input+ (slotStreamList, slotUniformList, slotGPList) = unzip3+ [ (T.singleton name (primType,T.fromList inputs)+ ,T.singleton name (T.fromList $ unis fb)+ ,T.singleton name (Set.singleton fb))+ | fb <- concatMap (renderChain dag) ordFBs+ , Fetch name primType inputs <- maybeToList $ findFetch dag fb+ ]+ slotStreamTrie = foldl' (T.mergeBy (\(a1,a2) (b1,b2) -> Just (a1, T.unionL a2 b2))) T.empty slotStreamList+ slotUniformTrie = foldl' (T.mergeBy (\a b -> Just (T.unionL a b))) T.empty slotUniformList+ (uniformNames,uniformTypes) = unzip $ nubS $ concatMap (T.toList . snd) $ T.toList slotUniformTrie++ putStrLn_ "calculate exp universe..."+ print_ $ map (toExpId dag) ordFBs+ print_ ordFBs+ putStrLn_ $ "Exp universe size: " ++ show (length (nubS $ expUniverse' dag gp))+ putStrLn_ $ "ord GP size: " ++ show (length ordFBs)+ putStrLn_ $ "GP universe size: " ++ show (length allGPs)++ -- create RenderState+ rendState <- mkRenderState++ (uSetup,uSetter,uGetter) <- unzip3 <$> mapM (mkUniformSetter rendState) uniformTypes+ let uniformSetterTrie = T.fromList $! zip uniformNames uSetter+ uniformGetterTrie = T.fromList $! zip uniformNames uGetter+ mkUniformSetupTrie = T.fromList $! zip uniformNames uSetup++ slotGP :: Trie (Set Exp)+ slotGP = foldl' (T.mergeBy (\a b -> Just $ Set.union a b)) T.empty slotGPList++ -- create SlotDescriptors (input setup)+ slotDescriptors <- T.fromList <$> mapM (\(n,a) -> (n,) <$> mkSlotDescriptor a) (T.toList slotGP)++ -- allocate render textures (output resource initialization)+ (texSlotName,renderTexName,renderTexGLObj,renderTexDispose,dependentSamplers) <- mkRenderTextures dag allGPs samplerOutData++ -- create RenderDescriptors+ renderDescriptors <- Map.fromList <$> mapM (\a -> (a,) <$> mkRenderDescriptor uniformGetterTrie dag rendState texSlotName renderTexName renderTexGLObj a) (nubS $ concatMap (renderChain dag) ordFBs)++ -- create IORef for ScreenOut Size+ screenSizeIORef <- newIORef (0,0)++ putStrLn ("number of passes: " ++ show (length ordFBs))+ -- join compiled graphics network components+ (passRender,passDispose) <- fmap unzip $ forM (zip ordFBs [1..]) $ \(fb,passNo) -> do+ let (drawList, disposeList) = unzip [(renderAction rd, disposeAction rd) | f <- renderChain dag fb, let Just rd = Map.lookup f renderDescriptors]+ let Just rd = Map.lookup fb renderDescriptors+ putStrLn ("pass #" ++ show passNo)+ putStrLn (" - draw count: " ++ show (length drawList))+ (passSetup,passDispose) <- mkPassSetup screenSizeIORef rendState dag renderTexGLObj dependentSamplers (samplerOutData == Nothing && fb == gp,fragmentOutCount rd - idx, fragmentOutCount rd) fb+ return (passSetup >> sequence_ drawList, passDispose >> sequence_ disposeList)++ -- debug+ putStrLn $ "number of passes: " ++ show (length ordFBs) ++ " is output the last? " ++ show (findFrameBuffer dag gp == last ordFBs)++ -- TODO: validate+ -- all slot name should be unique+ -- all uniform with same name have the same type+ -- all stream input with same name have the same type+ objIDSeed <- newIORef 1+ return $! Renderer+ -- public+ { slotUniform = slotUniformTrie+ , slotStream = slotStreamTrie+ , uniformSetter = uniformSetterTrie+ , render = do+ --print_ " * Frame Started"+ putStrLn_ "CMD: render frame started"+ MV.set (textureUnitState rendState) (-1)++ sequence_ passRender+ --print_ " * Frame Ended"+ , dispose = renderTexDispose >> sequence_ passDispose+ , setScreenSize = \w h -> writeIORef screenSizeIORef (w,h)+ , samplerOutput = T.fromList [(n,TextureData $ renderTexGLObj Map.! s) | (n,s) <- maybeToList samplerOutData]++ -- internal+ , mkUniformSetup = mkUniformSetupTrie+ , slotDescriptor = slotDescriptors+ , renderDescriptor = renderDescriptors+ , renderState = rendState+ , objectIDSeed = objIDSeed+ }
+ src/lib/LambdaCube/GL/Compile.hs view
@@ -0,0 +1,590 @@+module LambdaCube.GL.Compile where++import Control.Applicative hiding (Const)+import Control.Monad+import Data.ByteString.Char8 (ByteString)+import Data.IORef+import Data.List as L+import Data.Maybe+import Data.Set (Set)+import Data.Map (Map)+import Data.Trie as T+import Foreign+import qualified Data.ByteString.Char8 as SB+import qualified Data.Set as Set+import qualified Data.Map as Map+import qualified Data.Traversable as T+import qualified Data.Vector as V++import Graphics.Rendering.OpenGL.Raw.Core32+ ( GLboolean+ , GLenum+ , GLint+ , GLuint+ , glDisable+ , glEnable+ , gl_TRUE++ -- SHADER PROGRAM related *+ , glAttachShader+ , glBindFragDataLocation+ , glCreateProgram+ , glCreateShader+ , glDeleteProgram+ , glDeleteShader+ , glLinkProgram+ , glUseProgram+ , gl_FRAGMENT_SHADER+ , gl_GEOMETRY_SHADER+ , gl_LINK_STATUS+ , gl_VERTEX_SHADER++ -- ACCUMULATION CONTEXT related *+ , glViewport+ -- blending+ , glBlendColor+ , glBlendEquationSeparate+ , glBlendFuncSeparate+ , gl_BLEND+ -- logic operation+ , glLogicOp+ , gl_COLOR_LOGIC_OP+ -- framebuffer related+ , glClear+ , glClearColor+ , glClearDepth+ , glColorMask+ , gl_COLOR_BUFFER_BIT+ , gl_DEPTH_BUFFER_BIT+ -- depth and stencil filter functions+ , glDepthFunc+ , glDepthMask+ , gl_DEPTH_TEST+ , gl_STENCIL_TEST++ -- RASTER CONTEXT related *+ , glProvokingVertex+ , gl_FIRST_VERTEX_CONVENTION+ , gl_LAST_VERTEX_CONVENTION+ -- point+ , glPointParameterf+ , glPointSize+ , gl_LOWER_LEFT+ , gl_POINT_FADE_THRESHOLD_SIZE+ , gl_POINT_SPRITE_COORD_ORIGIN+ , gl_PROGRAM_POINT_SIZE+ , gl_UPPER_LEFT+ -- line+ , glLineWidth+ -- triangle+ , glCullFace+ , glFrontFace+ , glPolygonMode+ , glPolygonOffset+ , gl_BACK+ , gl_CCW+ , gl_CULL_FACE+ , gl_CW+ , gl_FILL+ , gl_FRONT+ , gl_FRONT_AND_BACK+ , gl_LINE+ , gl_POINT+ , gl_POLYGON_OFFSET_FILL+ , gl_POLYGON_OFFSET_LINE+ , gl_POLYGON_OFFSET_POINT+ -- debug+ )++import LambdaCube.Core.Type+import LambdaCube.Core.DeBruijn+import LambdaCube.Core.Traversals++import LambdaCube.GL.Type+import LambdaCube.GL.Util+import LambdaCube.GL.GLSLCodeGen++data ShaderSource+ = VertexShaderSrc !ByteString+ | GeometryShaderSrc !ByteString+ | FragmentShaderSrc !ByteString++setupRasterContext :: RasterContext -> IO ()+setupRasterContext = cvt+ where+ cff :: FrontFace -> GLenum+ cff CCW = gl_CCW+ cff CW = gl_CW++ setProvokingVertex :: ProvokingVertex -> IO ()+ setProvokingVertex pv = glProvokingVertex $ case pv of+ FirstVertex -> gl_FIRST_VERTEX_CONVENTION+ LastVertex -> gl_LAST_VERTEX_CONVENTION++ setPointSize :: PointSize -> IO ()+ setPointSize ps = case ps of+ ProgramPointSize -> glEnable gl_PROGRAM_POINT_SIZE+ PointSize s -> do+ glDisable gl_PROGRAM_POINT_SIZE+ glPointSize $ realToFrac s++ cvt :: RasterContext -> IO ()+ cvt (PointCtx ps fts sc) = do+ setPointSize ps+ glPointParameterf gl_POINT_FADE_THRESHOLD_SIZE (realToFrac fts)+ glPointParameterf gl_POINT_SPRITE_COORD_ORIGIN $ realToFrac $ case sc of+ LowerLeft -> gl_LOWER_LEFT+ UpperLeft -> gl_UPPER_LEFT++ cvt (LineCtx lw pv) = do+ glLineWidth (realToFrac lw)+ setProvokingVertex pv++ cvt (TriangleCtx cm pm po pv) = do+ let printGLStatus = checkGL >>= print_++ putStrLn_ "TriangleCtx 1" >> printGLStatus+ -- cull mode+ case cm of+ CullNone -> glDisable gl_CULL_FACE+ CullFront f -> do+ glEnable gl_CULL_FACE+ glCullFace gl_FRONT+ glFrontFace $ cff f+ CullBack f -> do+ glEnable gl_CULL_FACE+ glCullFace gl_BACK+ glFrontFace $ cff f+ putStrLn_ "TriangleCtx 2" >> printGLStatus++ -- polygon mode+ case pm of+ PolygonPoint ps -> do+ setPointSize ps+ putStrLn_ "TriangleCtx 2 - 1" >> printGLStatus+ glPolygonMode gl_FRONT_AND_BACK gl_POINT+ putStrLn_ "TriangleCtx 2 - 2" >> printGLStatus+ PolygonLine lw -> do+ putStrLn_ ("TriangleCtx 2 - 3 : " ++ show lw) >> printGLStatus+ glLineWidth (realToFrac lw)+ putStrLn_ "TriangleCtx 2 - 4" >> printGLStatus+ glPolygonMode gl_FRONT_AND_BACK gl_LINE+ putStrLn_ "TriangleCtx 2 - 5" >> printGLStatus+ PolygonFill -> glPolygonMode gl_FRONT_AND_BACK gl_FILL+ putStrLn_ "TriangleCtx 3" >> printGLStatus++ -- polygon offset+ {-+ glDisable gl_POLYGON_OFFSET_POINT+ glDisable gl_POLYGON_OFFSET_LINE+ glDisable gl_POLYGON_OFFSET_FILL+ -}+ putStrLn_ "TriangleCtx 4" >> printGLStatus+ case po of+ NoOffset -> glDisable $ case pm of+ PolygonPoint _ -> gl_POLYGON_OFFSET_POINT+ PolygonLine _ -> gl_POLYGON_OFFSET_LINE+ PolygonFill -> gl_POLYGON_OFFSET_FILL+ Offset f u -> do+ glPolygonOffset (realToFrac f) (realToFrac u)+ glEnable $ case pm of+ PolygonPoint _ -> gl_POLYGON_OFFSET_POINT+ PolygonLine _ -> gl_POLYGON_OFFSET_LINE+ PolygonFill -> gl_POLYGON_OFFSET_FILL+ putStrLn_ "TriangleCtx 5" >> printGLStatus++ -- provoking vertex+ setProvokingVertex pv+ putStrLn_ "TriangleCtx 6" >> printGLStatus++setupAccumulationContext :: RenderState -> T.Trie InputGetter -> DAG -> ExpId -> IO ()+setupAccumulationContext rendState uniformGetterTrie dag aCtx = cvt ops+ where+ AccumulationContext vpSize ops = toExp dag aCtx+ cvt :: [FragmentOperation] -> IO ()+ cvt (StencilOp a b c : DepthOp f m : xs) = do+ -- TODO+ cvtC 0 xs+ cvt (StencilOp a b c : xs) = do+ -- TODO+ cvtC 0 xs+ cvt (DepthOp df dm : xs) = do+ -- TODO+ glDisable gl_STENCIL_TEST+ case df == Always && dm == False of+ True -> glDisable gl_DEPTH_TEST+ False -> do+ glEnable gl_DEPTH_TEST+ glDepthFunc $! comparisonFunctionToGLType df+ glDepthMask (cvtBool dm)+ cvtC 0 xs+ cvt xs = do+ glDepthMask (cvtBool True) -- ??? wtf probably gl bug++ glDisable gl_DEPTH_TEST+ glDisable gl_STENCIL_TEST+ cvtC 0 xs++ cvtC :: Int -> [FragmentOperation] -> IO ()+ cvtC i (ColorOp b m : xs) = do+ -- TODO+ case b of+ NoBlending -> do+ -- FIXME: requires GL 3.1+ --glDisablei gl_BLEND $ fromIntegral gl_DRAW_BUFFER0 + fromIntegral i+ glDisable gl_BLEND -- workaround+ glDisable gl_COLOR_LOGIC_OP+ BlendLogicOp op -> do+ glDisable gl_BLEND+ glEnable gl_COLOR_LOGIC_OP+ glLogicOp $ logicOperationToGLType op+ Blend (cEq,aEq) ((scF,dcF),(saF,daF)) (V4 r g b a) -> do+ glDisable gl_COLOR_LOGIC_OP+ -- FIXME: requires GL 3.1+ --glEnablei gl_BLEND $ fromIntegral gl_DRAW_BUFFER0 + fromIntegral i+ glEnable gl_BLEND -- workaround+ glBlendEquationSeparate (blendEquationToGLType cEq) (blendEquationToGLType aEq)+ glBlendFuncSeparate (blendingFactorToGLType scF) (blendingFactorToGLType dcF)+ (blendingFactorToGLType saF) (blendingFactorToGLType daF)+ glBlendColor (realToFrac r) (realToFrac g) (realToFrac b) (realToFrac a)+ let cvt True = 1+ cvt False = 0+ (mr,mg,mb,ma) = case m of+ VBool r -> (cvt r, 1, 1, 1)+ VV2B (V2 r g) -> (cvt r, cvt g, 1, 1)+ VV3B (V3 r g b) -> (cvt r, cvt g, cvt b, 1)+ VV4B (V4 r g b a) -> (cvt r, cvt g, cvt b, cvt a)+ _ -> (1,1,1,1)+ glColorMask mr mg mb ma+ cvtC (i + 1) xs+ cvtC _ [] = case vpSize of+ Nothing -> do+ V2 w h <- readIORef $ renderTargetSize rendState+ glViewport 0 0 (fromIntegral w) (fromIntegral h)+ Just vpSizeExp -> do+ V4 x y w h <- case toExp dag vpSizeExp of+ Uni n -> case T.lookup n uniformGetterTrie of+ Just (SV4U (Getter v)) -> v+ _ -> error $ "interal error: viewport size type mismatch for Uni input " ++ show n+ Const (VV4U c) -> return c+ a -> error $ "interal error: viewport size type mismatch - " ++ show a+ glViewport (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h)++ cvtBool :: Bool -> GLboolean+ cvtBool True = 1+ cvtBool False = 0++{-+ compile steps:+ - collect all render buffers and render textures and allocate the GL resources+ - create setup actions all FBO-s (including clear targets action)+ - compile Image setup function for each+ - compile FragmentOperation function for each+ - compile shader programs++ render stages:+ - draw pass:+ - bind FBO+ - clear FBO targets+ - bind program+ - execute draw actions+ - execute next draw pass+ - blit ScreenOut to Back buffer if necessary++ hints:+ - we will have one GLProgram and one FBO per Accumulate+-}+-- TODO:+-- according context create FBO attachments+-- we always use Textures (without mipmap, as a single image) as FBO attachments+-- RenderBuffer can be use if it not fed to a sampler and it has olny one layer+-- question:+-- what is needed to create a Texture:+-- size - will be stored in FrameBuffer :: GP (FrameBuffer sh t)+-- internal format - for each component (float,int or word)+{-+ glGenTextures(1, &color_tex);+ glBindTexture(GL_TEXTURE_2D, color_tex);+ glTexImage2D(GL_TEXTURE_2D, 0, GL_RGBA8, 256, 256, 0, GL_BGRA, GL_UNSIGNED_BYTE, NULL);++ void glFramebufferTexture(GLenum target, GLenum attachment, GLuint texture, GLint level);+ void glDrawBuffers( GLsizei n, const GLenum *bufs );+-}+{-+ scissor:+ enable/disable: SCISSOR_TEST+ void Scissor( int left, int bottom, sizei width, sizei height );++ multisample:+ enable/disable: SAMPLE_ALPHA_TO_COVERAGE, SAMPLE_ALPHA_TO_ONE, SAMPLE_COVERAGE, SAMPLE_MASK+ void SampleCoverage( clampf value, boolean invert );+ void SampleMaski( uint maskNumber, bitfield mask );++ stencil:+ enable/disable: STENCIL_TEST+ void StencilFunc( enum func, int ref, uint mask );+ void StencilFuncSeparate( enum face, enum func, int ref, uint mask );+ void StencilOp( enum sfail, enum dpfail, enum dppass );+ void StencilOpSeparate( enum face, enum sfail, enum dpfail, enum dppass );++ depth:+ enable/disable: DEPTH_TEST+ void DepthFunc( enum func );++ blending:+ enable/disable:+ target: BLEND+ index: DRAW_BUFFERi+ void Enablei( enum target, uint index );+ void Disablei( enum target, uint index );+ FRAMEBUFFER_SRGB+ Blend Equation:+ void BlendEquation( enum mode );+ void BlendEquationSeparate( enum modeRGB, enum modeAlpha );+ void BlendFuncSeparate( enum srcRGB, enum dstRGB, enum srcAlpha, enum dstAlpha );+ void BlendFunc( enum src, enum dst );+ void BlendColor( clampf red, clampf green, clampf blue, clampf alpha );++ dither:+ enable/disable: DITHER++ logic operation:+ enable/disable: COLOR_LOGIC_OP+ void LogicOp( enum op );++ Selecting a Buffer for Writing:+ void DrawBuffer( enum buf );+ void DrawBuffers( sizei n, const enum *bufs );++ Fine Control of Buffer Updates:+ void ColorMask( boolean r, boolean g, boolean b, boolean a );+ void ColorMaski( uint buf, boolean r, boolean g, boolean b, boolean a );+ void DepthMask( boolean mask );+ void StencilMask( uint mask );+ void StencilMaskSeparate( enum face, uint mask );++ Clearing the Buffers:+ void Clear( bitfield buf );+ void ClearColor( clampf r, clampf g, clampf b, clampf a );+ void ClearDepth( clampd d );+ void ClearStencil( int s );+ void ClearBuffer{if ui}v( enum buffer, int drawbuffer, const T*value);+ void ClearBufferfi( enum buffer, int drawbuffer, float depth, int stencil );++ Reading and Copying Pixels:+ void ReadPixels( int x, int y, sizei width, sizei height, enum format, enum type, void *data );+ void ReadBuffer( enum src );+ void ClampColor( enum target, enum clamp );+ + void BlitFramebuffer( int srcX0, int srcY0, int srcX1, int srcY1, int dstX0, int dstY0, int dstX1, int dstY1, bitfield mask, enum filter );+-}+{-+ NOTE:+ We have to validate context, because we can support only the same Blend and LogicOperation for all render targets,+ however blending or LogicOp can be disabled separatly to each render target.+-}++compileClearFrameBuffer :: Exp -> IO ()+compileClearFrameBuffer (FrameBuffer fb) = putStrLn_ ("CMD: clearFrameBuffer " ++ show fb) >> cvt fb+ where+ -- we have to handle depth and stencil specially, available configurations:+ -- depth+ -- stencil+ -- depth-stencil+ cvt :: [Image] -> IO ()+ cvt (StencilImage sh1 s : DepthImage sh2 d : xs) = do+ -- TODO+ cvtC 0 xs+ cvt (StencilImage sh s : xs) = do+ -- TODO+ cvtC 0 xs+ cvt (DepthImage sh d : xs) = do+ let --renderGL3 = with d $ \pd -> glClearBufferfv gl_DEPTH 0 $ castPtr pd+ glClearDepth $ realToFrac d+ glClear $ fromIntegral gl_DEPTH_BUFFER_BIT+ --print " * glClear gl_DEPTH_BUFFER_BIT"+ cvtC 0 xs+ cvt xs = cvtC 0 xs++ cvtC :: Int -> [Image] -> IO ()+ cvtC i (ColorImage sh c : xs) = do+ -- for GL3:+ --with c' $ \pc -> glClearBufferfv gl_COLOR (fromIntegral $ gl_DRAW_BUFFER0 + fromIntegral i) $ castPtr pc+ let (r,g,b,a) = case c of+ VFloat r -> (realToFrac r, 0, 0, 1)+ VV2F (V2 r g) -> (realToFrac r, realToFrac g, 0, 1)+ VV3F (V3 r g b) -> (realToFrac r, realToFrac g, realToFrac b, 1)+ VV4F (V4 r g b a) -> (realToFrac r, realToFrac g, realToFrac b, realToFrac a)+ _ -> (0,0,0,1)+ glClearColor r g b a+ glClear $ fromIntegral gl_COLOR_BUFFER_BIT+ cvtC i (UnclearedImage sh : xs) = return ()+ cvtC i [] = return ()++-- TODO+{-+ hint:+ sampler names are generated, only texture slots are named by user+ one texture can be attached to more samplers+ user feed textures not samplers to gfx network++ texturing support:+ collect all sampler and texture definitions+ create sampler <-> texture name map+ sort previous passes+ create sampler setup action+ add texture slots to uniform input trie++ resources to create+ samplers+ sampler setup action+ textures+ hint: only if it is an output of a previous pass+-}+{-+ void GenSamplers( sizei count, uint *samplers );+ void BindSampler( uint unit, uint sampler );+ void DeleteSamplers( sizei count, const uint *samplers );+ void SamplerParameter{if}v( uint sampler, enum pname, T param );+ void SamplerParameterI{u ui}v( uint sampler, enum pname, T *params );+ pname:+ TEXTURE_WRAP_S+ TEXTURE_WRAP_T+ TEXTURE_WRAP_R+ TEXTURE_MIN_FILTER+ TEXTURE_MAG_FILTER+ TEXTURE_BORDER_COLOR+ TEXTURE_MIN_LOD+ TEXTURE_MAX_LOD+ TEXTURE_LOD_BIAS+ TEXTURE_COMPARE_MODE+ TEXTURE_COMPARE_FUNC+ void DeleteSamplers( sizei count, const uint *samplers );++ void ActiveTexture( enum texture );+ TEXTUREi = TEXTURE0 + i+ void BindTexture( enum target, uint texture );+ target:+ TEXTURE_1D+ TEXTURE_2D+ TEXTURE_3D+ TEXTURE_1D_ARRAY+ TEXTURE_2D_ARRAY+ TEXTURE_RECTANGLE+ TEXTURE_BUFFER+ TEXTURE_CUBE_MAP+ TEXTURE_2D_MULTISAMPLE+ TEXTURE_2D_MULTISAMPLE_ARRAY+-}+++-- FIXME: simple solution, does not support sharing+-- result: (RenderAction, DisposeAction, UniformLocation, StreamLocation)+compileRenderFrameBuffer :: RenderState -> Trie InputGetter -> DAG -> [(Exp,String)] -> [(Exp,String)] -> IORef ObjectSet -> Exp -> IO (IO (), IO (), Trie GLint, Trie GLuint, Int)+compileRenderFrameBuffer rendState uniformGetterTrie dag samplerNames slotSamplerNames objsIORef (Accumulate aCtx ffilter fsh rastExp fb) = do+ --rndr <- compileFrameBuffer fb rndr'+ po <- glCreateProgram+ let Rasterize rCtx primsExp = toExp dag rastExp+ (vsh,gsh,fetchExp) = case toExp dag primsExp of+ Transform vsh fetchExp -> (vsh,Nothing,fetchExp)+ Reassemble gsh transExp -> case toExp dag transExp of+ Transform vsh fetchExp -> (vsh,Just gsh,fetchExp)+ _ -> error "internal error: compileRenderFrameBuffer"+ _ -> error "internal error: compileRenderFrameBuffer"+ Fetch slotName slotPrim slotInput = toExp dag fetchExp+ (shl,fragOuts,outColorCnt) = case gsh of+ Nothing -> ([VertexShaderSrc srcV, FragmentShaderSrc srcF], (map fst outF), outColorCnt)+ where+ (srcF,outF,outColorCnt) = codeGenFragmentShader dag samplerNameMap outV (toExp dag ffilter) $ toExp dag fsh+ Just gs -> ([VertexShaderSrc srcV, GeometryShaderSrc srcG, FragmentShaderSrc srcF], (map fst outF), outColorCnt)+ where+ (srcG,outG) = codeGenGeometryShader dag samplerNameMap slotPrim outV $ toExp dag gs+ (srcF,outF,outColorCnt) = codeGenFragmentShader dag samplerNameMap outG (toExp dag ffilter) $ toExp dag fsh+ (srcV,outV) = codeGenVertexShader dag samplerNameMap slotInput $ toExp dag vsh+ allSamplerNames = samplerNames ++ slotSamplerNames + samplerNameMap = Map.fromList allSamplerNames+ printGLStatus = checkGL >>= print_+ createAndAttach [] _ = return $! Nothing+ createAndAttach sl t = do+ mapM_ SB.putStrLn sl+ o <- glCreateShader t+ compileShader o sl+ glAttachShader po o+ putStr " + compile shader source: " >> printGLStatus+ return $! Just o+ putStrLn $ "compileRenderFrameBuffer: compiling program for slot: " ++ show slotName+ putStrLn " + compile vertex shader"+ vsh <- createAndAttach [s | VertexShaderSrc s <- shl] gl_VERTEX_SHADER+ putStrLn " + compile geometry shader"+ gsh <- createAndAttach [s | GeometryShaderSrc s <- shl] gl_GEOMETRY_SHADER+ putStrLn " + compile fragment shader"+ fsh <- createAndAttach [s | FragmentShaderSrc s <- shl] gl_FRAGMENT_SHADER++ -- connect Fragment output to FBO+ forM_ (zip fragOuts [0..]) $ \(n,i) -> SB.useAsCString n $ \pn -> do+ putStrLn ("variable " ++ show n ++ " attached to color number #" ++ show i)+ glBindFragDataLocation po i $ castPtr pn+ putStr " + setup shader output mapping: " >> printGLStatus+ glLinkProgram po+ printProgramLog po++ -- check link status+ status <- glGetProgramiv1 gl_LINK_STATUS po+ when (status /= fromIntegral gl_TRUE) $ fail "link program failed!"++ -- query active uniforms, attributes and samplers+ (uLoc,uType) <- queryUniforms po+ (sLoc,sType) <- queryStreams po++ putStrLn $ "shader program stream input: " ++ show sLoc+ putStrLn $ "shader program uniform input: " ++ show uLoc+ putStrLn $ "expected sampler input: " ++ show allSamplerNames++ -- set sampler mapping+ glUseProgram po+ forM_ (zip [0..] (map (SB.pack . snd) allSamplerNames)) $ \(tuIdx,n) -> case T.lookup n uLoc of+ Nothing -> putStrLn $ "WARNING - unxepected inactive sampler: " ++ show n+ Just i -> (setSampler i tuIdx) >> putStr (" + setup texture unit mapping (smp " ++ show i ++ " <-> TexUnit " ++ show tuIdx ++": ") >> printGLStatus++ -- HINT: we get the uniform location now, so we have to provide this info to the renderer+ let uLoc' = foldl' (\t (_,n) -> setSamplerLoc t (SB.pack n)) uLoc allSamplerNames+ renderSmpNamesS = Set.fromList $ map (SB.pack . snd) samplerNames+ renderSmpCount = Set.size renderSmpNamesS+ slotSmpName = map (SB.pack . snd) slotSamplerNames++ setSamplerLoc :: Trie GLint -> ByteString -> Trie GLint+ setSamplerLoc t n+ | Set.member n renderSmpNamesS = T.delete n t+ | otherwise = T.adjust (\_ -> fromIntegral $ renderSmpCount + idx) n t+ where+ Just idx = elemIndex n slotSmpName++ disposeFun = glDeleteProgram po >> mapM_ glDeleteShader (catMaybes [vsh,gsh,fsh])+ renderFun = do+ ObjectSet drawObjs objsMap <- readIORef objsIORef+ --unless (False {-Map.null objsMap-}) $ do+ unless (Map.null objsMap) $ do+ --putStrLn $ "Slot: " ++ show slotName ++ " object count: " ++ show (Map.size objsMap)+ putStrLn_ "pre draw" >> printGLStatus+ putStrLn_ $ "CMD: setRasterContext " ++ show rCtx+ setupRasterContext rCtx+ putStrLn_ ("setupRasterContext " ++ show rCtx) >> printGLStatus+ setupAccumulationContext rendState uniformGetterTrie dag aCtx+ putStrLn_ "setupAccumulationContext" >> printGLStatus+ putStrLn_ $ "CMD: setAccumulationContext " ++ show aCtx+ putStrLn_ $ "CMD: glUseProgram " ++ show po+ glUseProgram po+ putStrLn_ "glUseProgram" >> printGLStatus+ putStrLn_ $ "CMD: renderSlot " ++ show slotName+ drawObjs+ putStrLn_ "drawObjs" >> printGLStatus+ print_ slotName+ print_ uLoc'+ return $! (renderFun, disposeFun, uLoc', sLoc, outColorCnt)++putStrLn_ :: String -> IO ()+--putStrLn_ = putStrLn+putStrLn_ _ = return ()++print_ :: Show a => a -> IO ()+print_ _ = return ()
+ src/lib/LambdaCube/GL/Data.hs view
@@ -0,0 +1,336 @@+module LambdaCube.GL.Data where++import Control.Applicative+import Control.Monad+import Data.ByteString.Char8 (ByteString)+import Data.IORef+import Data.List as L+import Data.Maybe+import Data.Trie as T+import Foreign +import System.IO.Unsafe+--import qualified Data.IntMap as IM+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.Vector as V++--import Control.DeepSeq++import Graphics.Rendering.OpenGL.Raw.Core32+ ( GLuint+ + -- FUNCTION APPLICATION related *+ -- render call+ , glDrawArrays+ , glDrawElements+ , gl_LINES+ , gl_LINES_ADJACENCY+ , gl_LINE_STRIP+ , gl_LINE_STRIP_ADJACENCY+ , gl_POINTS+ , gl_TRIANGLES+ , gl_TRIANGLES_ADJACENCY+ , gl_TRIANGLE_FAN+ , gl_TRIANGLE_STRIP+ , gl_TRIANGLE_STRIP_ADJACENCY++ -- BUFFER related *+ -- buffer data+ , glBindBuffer+ , glBindVertexArray+ , glBufferData+ , glBufferSubData+ , glGenBuffers+ , glGenVertexArrays+ , gl_ARRAY_BUFFER+ , gl_ELEMENT_ARRAY_BUFFER+ , gl_STATIC_DRAW++ -- TEXTURE related *+ -- texture data+ , glBindTexture+ , glGenTextures+ , glGenerateMipmap+ , glPixelStorei+ , glTexImage2D+ , glTexSubImage2D+ , glTexParameteri+ , gl_CLAMP_TO_EDGE+ , gl_LINEAR+ , gl_LINEAR_MIPMAP_LINEAR+ , gl_REPEAT+ , gl_RGB+ , gl_RGBA+ , gl_RGBA8+ , gl_TEXTURE_2D+ , gl_TEXTURE_BASE_LEVEL+ , gl_TEXTURE_MAG_FILTER+ , gl_TEXTURE_MAX_LEVEL+ , gl_TEXTURE_MIN_FILTER+ , gl_TEXTURE_WRAP_S+ , gl_TEXTURE_WRAP_T+ , gl_UNPACK_ALIGNMENT+ , gl_UNSIGNED_BYTE+ )++import Data.Word+import Data.Bitmap.Pure++import LambdaCube.GL.Type+import LambdaCube.GL.Util+import LambdaCube.Core.Type+import LambdaCube.Core.DeBruijn++-- Buffer+compileBuffer :: [Array] -> IO Buffer+compileBuffer arrs = do+ let calcDesc (offset,setters,descs) (Array arrType cnt setter) =+ let size = cnt * sizeOfArrayType arrType+ in (size + offset, (offset,size,setter):setters, ArrayDesc arrType cnt offset size:descs)+ (bufSize,arrSetters,arrDescs) = foldl' calcDesc (0,[],[]) arrs+ bo <- alloca $! \pbo -> glGenBuffers 1 pbo >> peek pbo+ glBindBuffer gl_ARRAY_BUFFER bo+ glBufferData gl_ARRAY_BUFFER (fromIntegral bufSize) nullPtr gl_STATIC_DRAW+ forM_ arrSetters $! \(offset,size,setter) -> setter $! glBufferSubData gl_ARRAY_BUFFER (fromIntegral offset) (fromIntegral size)+ glBindBuffer gl_ARRAY_BUFFER 0+ return $! Buffer (V.fromList $! reverse arrDescs) bo++updateBuffer :: Buffer -> [(Int,Array)] -> IO ()+updateBuffer (Buffer arrDescs bo) arrs = do+ glBindBuffer gl_ARRAY_BUFFER bo+ forM arrs $ \(i,Array arrType cnt setter) -> do+ let ArrayDesc ty len offset size = arrDescs V.! i+ when (ty == arrType && cnt == len) $+ setter $! glBufferSubData gl_ARRAY_BUFFER (fromIntegral offset) (fromIntegral size)+ glBindBuffer gl_ARRAY_BUFFER 0++bufferSize :: Buffer -> Int+bufferSize = V.length . bufArrays++arraySize :: Buffer -> Int -> Int+arraySize buf arrIdx = arrLength $! bufArrays buf V.! arrIdx++arrayType :: Buffer -> Int -> ArrayType+arrayType buf arrIdx = arrType $! bufArrays buf V.! arrIdx++-- question: should we render the full stream?+-- answer: YES+-- Object+nullObject :: Object+nullObject = unsafePerformIO $ Object "" T.empty 0 <$> newIORef False++addObject :: Renderer -> ByteString -> Primitive -> Maybe (IndexStream Buffer) -> Trie (Stream Buffer) -> [ByteString] -> IO Object+addObject renderer slotName prim objIndices objAttributes objUniforms =+ if (not $ T.member slotName $! slotUniform renderer) then do+ putStrLn $ "WARNING: unknown slot name: " ++ show slotName+ return nullObject+ else do+ -- validate+ let Just (slotType,sType) = T.lookup slotName $ slotStream renderer+ objSType = fmap streamToInputType objAttributes+ primType = case prim of+ TriangleStrip -> Triangles+ TriangleList -> Triangles+ TriangleFan -> Triangles+ LineStrip -> Lines+ LineList -> Lines+ PointList -> Points+ TriangleStripAdjacency -> TrianglesAdjacency+ TriangleListAdjacency -> TrianglesAdjacency+ LineStripAdjacency -> LinesAdjacency+ LineListAdjacency -> LinesAdjacency+ primGL = case prim of+ TriangleStrip -> gl_TRIANGLE_STRIP+ TriangleList -> gl_TRIANGLES+ TriangleFan -> gl_TRIANGLE_FAN+ LineStrip -> gl_LINE_STRIP+ LineList -> gl_LINES+ PointList -> gl_POINTS+ TriangleStripAdjacency -> gl_TRIANGLE_STRIP_ADJACENCY+ TriangleListAdjacency -> gl_TRIANGLES_ADJACENCY+ LineStripAdjacency -> gl_LINE_STRIP_ADJACENCY+ LineListAdjacency -> gl_LINES_ADJACENCY+ streamCounts = [c | Stream _ _ _ _ c <- T.elems objAttributes]+ count = head $ streamCounts ++ error "streamCounts"++ when (slotType /= primType) $ fail $ "addObject: primitive type mismatch: " ++ show (slotType,primType)+ when (objSType /= sType) $ fail $ unlines+ [ "addObject: attribute mismatch"+ , "expected:"+ , " " ++ show sType+ , "actual:"+ , " " ++ show objSType+ ]+ when (L.null streamCounts) $ fail "addObject: missing stream attribute, a least one stream attribute is required!"+ when (L.or [c /= count | c <- streamCounts]) $ fail "addObject: streams should have the same length!"++ -- validate index type if presented and create draw action+ (iSetup,draw) <- case objIndices of+ Nothing -> return (putStrLn_ ("OBJ: glBindBuffer gl_ELEMENT_ARRAY_BUFFER 0") >> glBindBuffer gl_ELEMENT_ARRAY_BUFFER 0, + putStrLn_ ("OBJ: glDrawArrays " ++ show prim ++ " 0 " ++ show count) >> glDrawArrays primGL 0 (fromIntegral count))+ Just (IndexStream (Buffer arrs bo) arrIdx start idxCount) -> do+ -- setup index buffer+ let ArrayDesc arrType arrLen arrOffs arrSize = arrs V.! arrIdx+ glType = arrayTypeToGLType arrType+ ptr = intPtrToPtr $! fromIntegral (arrOffs + start * sizeOfArrayType arrType)+ -- validate index type+ when (notElem arrType [ArrWord8, ArrWord16, ArrWord32]) $ fail "addObject: index type should be unsigned integer type"+ return (putStrLn_ ("OBJ: glBindBuffer gl_ELEMENT_ARRAY_BUFFER " ++ show bo) >> glBindBuffer gl_ELEMENT_ARRAY_BUFFER bo,+ putStrLn_ ("OBJ: glDrawElements " ++ show prim ++ " " ++ show idxCount ++ " " ++ show arrType ++ " " ++ show ptr) >> glDrawElements primGL (fromIntegral idxCount) glType ptr)++ -- implementation+ let renderDescriptorMap = renderDescriptor renderer+ uniformType = T.fromList $ concat [T.toList t | (_,t) <- T.toList $ slotUniform renderer]+ mkUSetup = mkUniformSetup renderer+ globalUNames = Set.toList $! (Set.fromList $! T.keys uniformType) Set.\\ (Set.fromList objUniforms)+ rendState = renderState renderer+ + stateIORef <- newIORef True+ (mkObjUSetup,objUSetters,_) <- unzip3 <$> (sequence [mkUniformSetter rendState t | n <- objUniforms, t <- maybeToList $ T.lookup n uniformType])+ let objUSetterTrie = T.fromList $! zip objUniforms objUSetters+ + mkDrawAction :: Exp -> IO (GLuint,IO ())+ mkDrawAction gp = do+ let Just rd = Map.lookup gp renderDescriptorMap+ sLocs = streamLocation rd+ uLocs = uniformLocation rd+ -- stream setup action+ sSetup = sequence_ [ mkSSetter t loc s + | (n,s) <- T.toList objAttributes+ , t <- maybeToList $ T.lookup n sType+ , loc <- maybeToList $ T.lookup n sLocs+ ]+ -- global uniform setup+ {-+ globalUSetup = sequence_ [ mkUS loc + | n <- globalUNames+ , let Just mkUS = T.lookup n mkUSetup+ , loc <- maybeToList $ T.lookup n uLocs+ ]+ -}+ globalUSetup = V.sequence_ $ V.fromList+ [ mkUS loc+ | n <- globalUNames+ , let Just mkUS = T.lookup n mkUSetup+ , loc <- maybeToList $ T.lookup n uLocs+ ]+ -- object uniform setup+ objUSetup = sequence_ [ mkOUS loc+ | (n,mkOUS) <- zip objUniforms mkObjUSetup+ , loc <- maybeToList $ T.lookup n uLocs+ ]+ --print sLocs+ -- create Vertex Array Object+ vao <- alloca $! \pvao -> glGenVertexArrays 1 pvao >> peek pvao+ glBindVertexArray vao+ sSetup -- setup vertex attributes+ iSetup -- setup index buffer+ let renderFun = readIORef stateIORef >>= \enabled -> when enabled $ do+ --print "draw object"+ --putStrLn $ " setup global uniforms: " ++ show [n | n <- globalUNames, T.member n uLocs]+ globalUSetup -- setup uniforms+ putStrLn_ $ "OBJ: globalUSetup"+ --putStrLn_ $ " setup object uniforms: " ++ show [n | n <- objUniforms, T.member n uLocs]+ objUSetup+ putStrLn_ $ "OBJ: objUSetup"+ putStrLn_ $ "OBJ: glBindVertexArray " ++ show vao+ glBindVertexArray vao -- setup stream input (aka object attributes)+ draw -- execute draw function+ return (vao,renderFun)++ Just (SlotDescriptor gps objSetRef) = T.lookup slotName (slotDescriptor renderer)+ gpList = Set.toList gps+ {-+ - create the object draw action for every Accumulate node+ - update ObjectSet's draw action lists+ -}+ --print sType+ (vaoList,drawList) <- unzip <$> mapM mkDrawAction gpList+ objID <- readIORef (objectIDSeed renderer)+ modifyIORef (objectIDSeed renderer) (+1)+ let obj = Object+ { objectSlotName = slotName+ , objectUniformSetter = objUSetterTrie+ , objectID = objID+ , objectEnabledIORef = stateIORef+ }++ -- add object to slot's object set+ modifyIORef objSetRef $ \s -> Set.insert obj s++ -- add draw object action to list+ forM_ (zip gpList drawList) $ \(gp,draw) -> do+ --print ("add", vaoList)+ let Just rd = Map.lookup gp renderDescriptorMap+ modifyIORef (drawObjectsIORef rd) $ \(ObjectSet _ drawMap) ->+ let drawMap' = Map.insert obj draw drawMap+ in ObjectSet (sequence_ $ Map.elems drawMap') drawMap'++ return obj++removeObject :: Renderer -> Object -> IO ()+removeObject rend obj = do+ let Just (SlotDescriptor gps objSetRef) = T.lookup (objectSlotName obj) (slotDescriptor rend)+ renderDescriptorMap = renderDescriptor rend++ -- remove object from slot's object set+ modifyIORef objSetRef $ \s -> Set.delete obj s++ -- remove draw object action from list+ forM_ (Set.toList gps) $ \gp -> do+ let Just rd = Map.lookup gp renderDescriptorMap+ modifyIORef (drawObjectsIORef rd) $ \(ObjectSet _ drawMap) ->+ let drawMap' = Map.delete obj drawMap+ in ObjectSet (sequence_ $ Map.elems drawMap') drawMap'++enableObject :: Object -> Bool -> IO ()+enableObject obj b = writeIORef (objectEnabledIORef obj) b++-- Texture++-- FIXME: Temporary implemenation+compileTexture2DRGBAF :: Bool -> Bool -> Bitmap Word8 -> IO TextureData+compileTexture2DRGBAF isMip isClamped bitmap = do+ glPixelStorei gl_UNPACK_ALIGNMENT 1+ to <- alloca $! \pto -> glGenTextures 1 pto >> peek pto+ glBindTexture gl_TEXTURE_2D to+ let (width,height) = bitmapSize bitmap+ wrapMode = case isClamped of+ True -> gl_CLAMP_TO_EDGE+ False -> gl_REPEAT+ (minFilter,maxLevel) = case isMip of+ False -> (gl_LINEAR,0)+ True -> (gl_LINEAR_MIPMAP_LINEAR, floor $ log (fromIntegral $ max width height) / log 2)+ glTexParameteri gl_TEXTURE_2D gl_TEXTURE_WRAP_S $ fromIntegral wrapMode+ glTexParameteri gl_TEXTURE_2D gl_TEXTURE_WRAP_T $ fromIntegral wrapMode+ glTexParameteri gl_TEXTURE_2D gl_TEXTURE_MIN_FILTER $ fromIntegral minFilter+ glTexParameteri gl_TEXTURE_2D gl_TEXTURE_MAG_FILTER $ fromIntegral gl_LINEAR+ glTexParameteri gl_TEXTURE_2D gl_TEXTURE_BASE_LEVEL 0+ glTexParameteri gl_TEXTURE_2D gl_TEXTURE_MAX_LEVEL $ fromIntegral maxLevel+ withBitmap bitmap $ \(w,h) nchn 0 ptr -> do+ let internalFormat = fromIntegral gl_RGBA8+ dataFormat = fromIntegral $ case nchn of+ 3 -> gl_RGB+ 4 -> gl_RGBA+ _ -> error "unsupported texture format!"+ glTexImage2D gl_TEXTURE_2D 0 internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat gl_UNSIGNED_BYTE $ castPtr ptr+ when isMip $ glGenerateMipmap gl_TEXTURE_2D+ return $ TextureData to++updateTexture2DRGBAF :: TextureData -> Bool -> Bitmap Word8 -> IO ()+updateTexture2DRGBAF tx isMip bitmap = do+ glPixelStorei gl_UNPACK_ALIGNMENT 1+ let to = textureObject tx+ glBindTexture gl_TEXTURE_2D to+ withBitmap bitmap $ \(w,h) nchn 0 ptr -> do+ let internalFormat = fromIntegral gl_RGBA8+ dataFormat = fromIntegral $ case nchn of+ 3 -> gl_RGB+ 4 -> gl_RGBA+ _ -> error "unsupported texture format!"+ glTexSubImage2D gl_TEXTURE_2D 0 0 0 (fromIntegral w) (fromIntegral h) dataFormat gl_UNSIGNED_BYTE $ castPtr ptr+ when isMip $ glGenerateMipmap gl_TEXTURE_2D++putStrLn_ :: String -> IO ()+--putStrLn_ = putStrLn+putStrLn_ _ = return ()
+ src/lib/LambdaCube/GL/GLSLCodeGen.hs view
@@ -0,0 +1,867 @@+module LambdaCube.GL.GLSLCodeGen (+ codeGenVertexShader,+ codeGenGeometryShader,+ codeGenFragmentShader,+ codeGenType+) where++import Debug.Trace++import Control.Applicative hiding (Const)+import Control.Exception+import Control.Monad.State+import Data.ByteString.Char8 (ByteString,pack,unpack)+import Data.Int+import Data.IntMap (IntMap)+import Data.Map (Map)+import Data.Maybe+import Data.Set (Set)+import Data.Word+import Text.PrettyPrint.HughesPJClass+import qualified Data.ByteString.Char8 as SB+import qualified Data.IntMap as IntMap+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.Vector as V++import LambdaCube.Core.Type hiding (And,Or,Equal)+import LambdaCube.Core.PrimFun+import LambdaCube.Core.DeBruijn hiding (ExpC(..))+import LambdaCube.Core.Traversals++import Language.GLSL.Syntax hiding (Const,InterpolationQualifier(..),TypeSpecifierNonArray(..))+import Language.GLSL.Syntax (TypeSpecifierNonArray)+import qualified Language.GLSL.Syntax as GLSL+import Language.GLSL.Pretty++codeGenPrim :: PrimFun -> [InputType] -> [InputType] -> [Expr] -> [Expr]++-- Vec/Mat (de)construction+codeGenPrim PrimTupToV2 ty argTy [a,b]+ | all (==Bool) argTy = [functionCall "bvec2" [a,b]]+ | all (==Float) argTy = [functionCall "vec2" [a,b]]+ | all (==Int) argTy = [functionCall "ivec2" [a,b]]+ | all (==Word) argTy = [functionCall "uvec2" [a,b]]+ | all (==V2F) argTy = [functionCall "mat2" [a,b]]+ | all (==V3F) argTy = [functionCall "mat3x2" [a,b]]+ | all (==V4F) argTy = [functionCall "mat4x2" [a,b]]+codeGenPrim PrimTupToV3 ty argTy [a,b,c]+ | all (==Bool) argTy = [functionCall "bvec3" [a,b,c]]+ | all (==Float) argTy = [functionCall "vec3" [a,b,c]]+ | all (==Int) argTy = [functionCall "ivec3" [a,b,c]]+ | all (==Word) argTy = [functionCall "uvec3" [a,b,c]]+ | all (==V2F) argTy = [functionCall "mat2x3" [a,b,c]]+ | all (==V3F) argTy = [functionCall "mat3" [a,b,c]]+ | all (==V4F) argTy = [functionCall "mat4x3" [a,b,c]]+codeGenPrim PrimTupToV4 ty argTy [a,b,c,d]+ | all (==Bool) argTy = [functionCall "bvec4" [a,b,c,d]]+ | all (==Float) argTy = [functionCall "vec4" [a,b,c,d]]+ | all (==Int) argTy = [functionCall "ivec4" [a,b,c,d]]+ | all (==Word) argTy = [functionCall "uvec4" [a,b,c,d]]+ | all (==V2F) argTy = [functionCall "mat2x4" [a,b,c,d]]+ | all (==V3F) argTy = [functionCall "mat3x4" [a,b,c,d]]+ | all (==V4F) argTy = [functionCall "mat4" [a,b,c,d]]++codeGenPrim PrimV2ToTup ty argTy [a]+ | all isMatrix argTy = [ Bracket a (IntConstant Decimal 0)+ , Bracket a (IntConstant Decimal 1)+ ]+ | otherwise = [ FieldSelection a "x"+ , FieldSelection a "y"+ ]+codeGenPrim PrimV3ToTup ty argTy [a]+ | all isMatrix argTy = [ Bracket a (IntConstant Decimal 0)+ , Bracket a (IntConstant Decimal 1)+ , Bracket a (IntConstant Decimal 2)+ ]+ | otherwise = [ FieldSelection a "x"+ , FieldSelection a "y"+ , FieldSelection a "z"+ ]+codeGenPrim PrimV4ToTup ty argTy [a]+ | all isMatrix argTy = [ Bracket a (IntConstant Decimal 0)+ , Bracket a (IntConstant Decimal 1)+ , Bracket a (IntConstant Decimal 2)+ , Bracket a (IntConstant Decimal 3)+ ]+ | otherwise = [ FieldSelection a "x"+ , FieldSelection a "y"+ , FieldSelection a "z"+ , FieldSelection a "w"+ ]++-- Arithmetic Functions+-- OK+codeGenPrim PrimAdd ty argTy [a,b] = [Add a b]+codeGenPrim PrimAddS ty argTy [a,b] = [Add a b]+codeGenPrim PrimSub ty argTy [a,b] = [Sub a b]+codeGenPrim PrimSubS ty argTy [a,b] = [Sub a b]+codeGenPrim PrimMul ty argTy [a,b]+ | all isMatrix argTy = [functionCall "matrixCompMult" [a,b]]+ | otherwise = [Mul a b]+codeGenPrim PrimMulS ty argTy [a,b] = [Mul a b]+codeGenPrim PrimDiv ty argTy [a,b] = [Div a b]+codeGenPrim PrimDivS ty argTy [a,b] = [Div a b]+codeGenPrim PrimNeg ty argTy [a] = [UnaryNegate a]+codeGenPrim PrimMod ty argTy [a,b]+ | all isIntegral argTy = [Mod a b]+ | otherwise = [functionCall "mod" [a,b]]+codeGenPrim PrimModS ty argTy [a,b]+ | all isIntegral argTy = [Mod a b]+ | otherwise = [functionCall "mod" [a,b]]++-- Bit-wise Functions+-- OK+codeGenPrim PrimBAnd ty argTy [a,b] = [BitAnd a b]+codeGenPrim PrimBAndS ty argTy [a,b] = [BitAnd a b]+codeGenPrim PrimBOr ty argTy [a,b] = [BitOr a b]+codeGenPrim PrimBOrS ty argTy [a,b] = [BitOr a b]+codeGenPrim PrimBXor ty argTy [a,b] = [BitXor a b]+codeGenPrim PrimBXorS ty argTy [a,b] = [BitXor a b]+codeGenPrim PrimBNot ty argTy [a] = [UnaryOneComplement a]+codeGenPrim PrimBShiftL ty argTy [a,b] = [LeftShift a b]+codeGenPrim PrimBShiftLS ty argTy [a,b] = [LeftShift a b]+codeGenPrim PrimBShiftR ty argTy [a,b] = [RightShift a b]+codeGenPrim PrimBShiftRS ty argTy [a,b] = [RightShift a b]++-- Logic Functions+-- OK+codeGenPrim PrimAnd ty argTy [a,b] = [And a b]+codeGenPrim PrimOr ty argTy [a,b] = [Or a b]+codeGenPrim PrimXor ty argTy [a,b] = error "codeGenPrim PrimXor is not implemented yet!" -- TODO: implement in GLSLSyntax+codeGenPrim PrimNot ty argTy [a]+ | all isScalar argTy = [UnaryNot a]+ | otherwise = [functionCall "not" [a]]+codeGenPrim PrimAny ty argTy [a] = [functionCall "any" [a]]+codeGenPrim PrimAll ty argTy [a] = [functionCall "all" [a]]++-- Angle and Trigonometry Functions+-- OK+codeGenPrim PrimACos ty argTy [a] = [functionCall "acos" [a]]+codeGenPrim PrimACosH ty argTy [a] = [functionCall "acosh" [a]]+codeGenPrim PrimASin ty argTy [a] = [functionCall "asin" [a]]+codeGenPrim PrimASinH ty argTy [a] = [functionCall "asinh" [a]]+codeGenPrim PrimATan ty argTy [a] = [functionCall "atan" [a]]+codeGenPrim PrimATan2 ty argTy [a,b] = [functionCall "atan" [a,b]]+codeGenPrim PrimATanH ty argTy [a] = [functionCall "atanh" [a]]+codeGenPrim PrimCos ty argTy [a] = [functionCall "cos" [a]]+codeGenPrim PrimCosH ty argTy [a] = [functionCall "cosh" [a]]+codeGenPrim PrimDegrees ty argTy [a] = [functionCall "degrees" [a]]+codeGenPrim PrimRadians ty argTy [a] = [functionCall "radians" [a]]+codeGenPrim PrimSin ty argTy [a] = [functionCall "sin" [a]]+codeGenPrim PrimSinH ty argTy [a] = [functionCall "sinh" [a]]+codeGenPrim PrimTan ty argTy [a] = [functionCall "tan" [a]]+codeGenPrim PrimTanH ty argTy [a] = [functionCall "tanh" [a]]++-- Exponential Functions+-- OK+codeGenPrim PrimPow ty argTy [a,b] = [functionCall "pow" [a,b]]+codeGenPrim PrimExp ty argTy [a] = [functionCall "exp" [a]]+codeGenPrim PrimLog ty argTy [a] = [functionCall "log" [a]]+codeGenPrim PrimExp2 ty argTy [a] = [functionCall "exp2" [a]]+codeGenPrim PrimLog2 ty argTy [a] = [functionCall "log2" [a]]+codeGenPrim PrimSqrt ty argTy [a] = [functionCall "sqrt" [a]]+codeGenPrim PrimInvSqrt ty argTy [a] = [functionCall "inversesqrt" [a]]++-- Common Functions+-- OK+codeGenPrim PrimIsNan ty argTy [a] = [functionCall "isnan" [a]]+codeGenPrim PrimIsInf ty argTy [a] = [functionCall "isinf" [a]]+codeGenPrim PrimAbs ty argTy [a] = [functionCall "abs" [a]]+codeGenPrim PrimSign ty argTy [a] = [functionCall "sign" [a]]+codeGenPrim PrimFloor ty argTy [a] = [functionCall "floor" [a]]+codeGenPrim PrimTrunc ty argTy [a] = [functionCall "trunc" [a]]+codeGenPrim PrimRound ty argTy [a] = [functionCall "round" [a]]+codeGenPrim PrimRoundEven ty argTy [a] = [functionCall "roundEven" [a]]+codeGenPrim PrimCeil ty argTy [a] = [functionCall "ceil" [a]]+codeGenPrim PrimFract ty argTy [a] = [functionCall "fract" [a]]+codeGenPrim PrimModF ty argTy [a] = error "codeGenPrim PrimModF is not implemented yet!" -- TODO+codeGenPrim PrimMin ty argTy [a,b] = [functionCall "min" [a,b]]+codeGenPrim PrimMinS ty argTy [a,b] = [functionCall "min" [a,b]]+codeGenPrim PrimMax ty argTy [a,b] = [functionCall "max" [a,b]]+codeGenPrim PrimMaxS ty argTy [a,b] = [functionCall "max" [a,b]]+codeGenPrim PrimClamp ty argTy [a,b,c] = [functionCall "clamp" [a,b,c]]+codeGenPrim PrimClampS ty argTy [a,b,c] = [functionCall "clamp" [a,b,c]]+codeGenPrim PrimMix ty argTy [a,b,c] = [functionCall "mix" [a,b,c]]+codeGenPrim PrimMixS ty argTy [a,b,c] = [functionCall "mix" [a,b,c]]+codeGenPrim PrimMixB ty argTy [a,b,c] = [functionCall "mix" [a,b,c]]+codeGenPrim PrimStep ty argTy [a,b] = [functionCall "step" [a,b]]+codeGenPrim PrimStepS ty argTy [a,b] = [functionCall "step" [a,b]]+codeGenPrim PrimSmoothStep ty argTy [a,b,c] = [functionCall "smoothstep" [a,b,c]]+codeGenPrim PrimSmoothStepS ty argTy [a,b,c] = [functionCall "smoothstep" [a,b,c]]++-- Integer/Float Conversion Functions+-- OK+codeGenPrim PrimFloatBitsToInt ty argTy [a] = [functionCall "floatBitsToInt" [a]]+codeGenPrim PrimFloatBitsToUInt ty argTy [a] = [functionCall "floatBitsToUint" [a]]+codeGenPrim PrimIntBitsToFloat ty argTy [a] = [functionCall "intBitsToFloat" [a]]+codeGenPrim PrimUIntBitsToFloat ty argTy [a] = [functionCall "uintBitsToFloat" [a]]++-- Geometric Functions+-- OK+codeGenPrim PrimLength ty argTy [a] = [functionCall "length" [a]]+codeGenPrim PrimDistance ty argTy [a,b] = [functionCall "distance" [a,b]]+codeGenPrim PrimDot ty argTy [a,b] = [functionCall "dot" [a,b]]+codeGenPrim PrimCross ty argTy [a,b] = [functionCall "cross" [a,b]]+codeGenPrim PrimNormalize ty argTy [a] = [functionCall "normalize" [a]]+codeGenPrim PrimFaceForward ty argTy [a,b,c] = [functionCall "faceforward" [a,b,c]]+codeGenPrim PrimReflect ty argTy [a,b] = [functionCall "reflect" [a,b]]+codeGenPrim PrimRefract ty argTy [a,b,c] = [functionCall "refract" [a,b,c]]++-- Matrix Functions+-- OK+codeGenPrim PrimTranspose ty argTy [a] = [functionCall "transpose" [a]]+codeGenPrim PrimDeterminant ty argTy [a] = [functionCall "determinant" [a]]+codeGenPrim PrimInverse ty argTy [a] = [functionCall "inverse" [a]]+codeGenPrim PrimOuterProduct ty argTy [a,b] = [functionCall "outerProduct" [a,b]]+codeGenPrim PrimMulMatVec ty argTy [a,b] = [Mul a b]+codeGenPrim PrimMulVecMat ty argTy [a,b] = [Mul a b]+codeGenPrim PrimMulMatMat ty argTy [a,b] = [Mul a b]++-- Vector and Scalar Relational Functions+-- OK+codeGenPrim PrimLessThan ty argTy [a,b]+ | all isScalarNum argTy = [Lt a b]+ | otherwise = [functionCall "lessThan" [a,b]]+codeGenPrim PrimLessThanEqual ty argTy [a,b]+ | all isScalarNum argTy = [Lte a b]+ | otherwise = [functionCall "lessThanEqual" [a,b]]+codeGenPrim PrimGreaterThan ty argTy [a,b]+ | all isScalarNum argTy = [Gt a b]+ | otherwise = [functionCall "greaterThan" [a,b]]+codeGenPrim PrimGreaterThanEqual ty argTy [a,b]+ | all isScalarNum argTy = [Gte a b]+ | otherwise = [functionCall "greaterThanEqual" [a,b]]+codeGenPrim PrimEqualV ty argTy [a,b]+ | all isScalar argTy = [Equ a b]+ | otherwise = [functionCall "equal" [a,b]]+codeGenPrim PrimEqual ty argTy [a,b] = [Equ a b]+codeGenPrim PrimNotEqualV ty argTy [a,b]+ | all isScalar argTy = [Neq a b]+ | otherwise = [functionCall "notEqual" [a,b]]+codeGenPrim PrimNotEqual ty argTy [a,b] = [Neq a b]++-- Fragment Processing Functions+-- OK+codeGenPrim PrimDFdx ty argTy [a] = [functionCall "dFdx" [a]]+codeGenPrim PrimDFdy ty argTy [a] = [functionCall "dFdy" [a]]+codeGenPrim PrimFWidth ty argTy [a] = [functionCall "fwidth" [a]]++-- Noise Functions+-- OK+codeGenPrim PrimNoise1 ty argTy [a] = [functionCall "noise1" [a]]+codeGenPrim PrimNoise2 ty argTy [a] = [functionCall "noise2" [a]]+codeGenPrim PrimNoise3 ty argTy [a] = [functionCall "noise3" [a]]+codeGenPrim PrimNoise4 ty argTy [a] = [functionCall "noise4" [a]]++-- Texture Lookup Functions+codeGenPrim PrimTextureSize ty argTy [a] = [functionCall "textureSize" [a]]+codeGenPrim PrimTextureSize ty argTy [a,b] = [functionCall "textureSize" [a,b]]+codeGenPrim PrimTexture ty argTy [a,b] = [swizzleV4 ty $ functionCall "texture" [a,b]]+codeGenPrim PrimTexture ty argTy [a,b,c] = [swizzleV4 ty $ functionCall "texture" [a,b,c]]+codeGenPrim PrimTextureProj ty argTy [a,b] = [swizzleV4 ty $ functionCall "textureProj" [a,b]]+codeGenPrim PrimTextureProj ty argTy [a,b,c] = [swizzleV4 ty $ functionCall "textureProj" [a,b,c]]+codeGenPrim PrimTextureLod ty argTy [a,b,c] = [swizzleV4 ty $ functionCall "textureLod" [a,b,c]]+codeGenPrim PrimTextureOffset ty argTy [a,b,c] = [swizzleV4 ty $ functionCall "textureOffset" [a,b,c]]+codeGenPrim PrimTextureOffset ty argTy [a,b,c,d] = [swizzleV4 ty $ functionCall "textureOffset" [a,b,c,d]]+codeGenPrim PrimTexelFetch ty argTy [a,b] = [swizzleV4 ty $ functionCall "texelFetch" [a,b]]+codeGenPrim PrimTexelFetch ty argTy [a,b,c] = [swizzleV4 ty $ functionCall "texelFetch" [a,b,c]]+codeGenPrim PrimTexelFetchOffset ty argTy [a,b,c] = [swizzleV4 ty $ functionCall "texelFetchOffset" [a,b,c]]+codeGenPrim PrimTexelFetchOffset ty argTy [a,b,c,d] = [swizzleV4 ty $ functionCall "texelFetchOffset" [a,b,c,d]]+codeGenPrim PrimTextureProjOffset ty argTy [a,b,c] = [swizzleV4 ty $ functionCall "textureProjOffset" [a,b,c]]+codeGenPrim PrimTextureProjOffset ty argTy [a,b,c,d] = [swizzleV4 ty $ functionCall "textureProjOffset" [a,b,c,d]]+codeGenPrim PrimTextureLodOffset ty argTy [a,b,c,d] = [swizzleV4 ty $ functionCall "textureLodOffset" [a,b,c,d]]+codeGenPrim PrimTextureProjLod ty argTy [a,b,c] = [swizzleV4 ty $ functionCall "textureProjLod" [a,b,c]]+codeGenPrim PrimTextureProjLodOffset ty argTy [a,b,c,d] = [swizzleV4 ty $ functionCall "textureProjLodOffset" [a,b,c,d]]+codeGenPrim PrimTextureGrad ty argTy [a,b,c,d] = [swizzleV4 ty $ functionCall "textureGrad" [a,b,c,d]]+codeGenPrim PrimTextureGradOffset ty argTy [a,b,c,d,e] = [swizzleV4 ty $ functionCall "textureGradOffset" [a,b,c,d,e]]+codeGenPrim PrimTextureProjGrad ty argTy [a,b,c,d] = [swizzleV4 ty $ functionCall "textureProjGrad" [a,b,c,d]]+codeGenPrim PrimTextureProjGradOffset ty argTy [a,b,c,d,e] = [swizzleV4 ty $ functionCall "textureProjGradOffset" [a,b,c,d,e]]++-- unmatched primitive function+codeGenPrim prim ty argTy params = throw $ userError $ unlines $+ [ "codeGenPrim failed: "+ , " name: " ++ show prim+ , " parameter types: " ++ show ty+ , " parameter values: " ++ show params+ ]++swizzleV4 :: [InputType] -> Expr -> Expr+swizzleV4 [ty] a+ | elem ty [V4F, V4I, V4U] = a+ | elem ty [V3F, V3I, V3U] = FieldSelection a "rgb"+ | elem ty [V2F, V2I, V2U] = FieldSelection a "rg"+ | elem ty [Float, Int, Word] = FieldSelection a "r"+ | otherwise = error $ "swizzleV4 - illegal type: " ++ show ty++-- glsl ast utility+functionCall :: String -> [Expr] -> Expr+functionCall name params = FunctionCall (FuncId name) (Params params)++isMatrix :: InputType -> Bool+isMatrix ty = elem ty $+ [ M22F, M23F, M24F+ , M32F, M33F, M34F+ , M42F, M43F, M44F+ ]++isIntegral :: InputType -> Bool+isIntegral ty = elem ty $+ [ Word, V2U, V3U, V4U+ , Int, V2I, V3I, V4I+ ]++isScalarNum :: InputType -> Bool+isScalarNum ty = elem ty [Int, Word, Float]++isScalar :: InputType -> Bool+isScalar ty = elem ty [Bool, Int, Word, Float]++wordC :: Word32 -> Expr+wordC v = IntConstant Decimal (fromIntegral v)++intC :: Int32 -> Expr+intC v = IntConstant Decimal (fromIntegral v)++boolC :: Bool -> Expr+boolC v = BoolConstant v++floatC :: Float -> Expr+floatC v = FloatConstant v++v2C :: String -> (a -> Expr) -> V2 a -> Expr+v2C name f (V2 x y) = functionCall name [f x, f y]++v3C :: String -> (a -> Expr) -> V3 a -> Expr+v3C name f (V3 x y z) = functionCall name [f x, f y, f z]++v4C :: String -> (a -> Expr) -> V4 a -> Expr+v4C name f (V4 x y z w) = functionCall name [f x, f y, f z, f w]++matX2C :: String -> (v Float -> Expr) -> V2 (v Float) -> Expr+matX2C name f (V2 x y) = functionCall name [f x, f y]++matX3C :: String -> (v Float -> Expr) -> V3 (v Float) -> Expr+matX3C name f (V3 x y z) = functionCall name [f x, f y, f z]++matX4C :: String -> (v Float -> Expr) -> V4 (v Float) -> Expr+matX4C name f (V4 x y z w) = functionCall name [f x, f y, f z, f w]++codeGenConst :: Value -> Expr+codeGenConst (VBool v) = boolC v+codeGenConst (VV2B v) = v2C "bvec2" boolC v+codeGenConst (VV3B v) = v3C "bvec3" boolC v+codeGenConst (VV4B v) = v4C "bvec4" boolC v+codeGenConst (VWord v) = wordC v+codeGenConst (VV2U v) = v2C "uvec2" wordC v+codeGenConst (VV3U v) = v3C "uvec3" wordC v+codeGenConst (VV4U v) = v4C "uvec4" wordC v+codeGenConst (VInt v) = intC v+codeGenConst (VV2I v) = v2C "ivec2" intC v+codeGenConst (VV3I v) = v3C "ivec3" intC v+codeGenConst (VV4I v) = v4C "ivec4" intC v+codeGenConst (VFloat v) = floatC v+codeGenConst (VV2F v) = v2C "vec2" floatC v+codeGenConst (VV3F v) = v3C "vec3" floatC v+codeGenConst (VV4F v) = v4C "vec4" floatC v+codeGenConst (VM22F v) = matX2C "mat2" (v2C "vec2" floatC) v+codeGenConst (VM23F v) = matX3C "mat2x3" (v2C "vec2" floatC) v+codeGenConst (VM24F v) = matX4C "mat2x4" (v2C "vec2" floatC) v+codeGenConst (VM32F v) = matX2C "mat3x2" (v3C "vec3" floatC) v+codeGenConst (VM33F v) = matX3C "mat3" (v3C "vec3" floatC) v+codeGenConst (VM34F v) = matX4C "mat3x4" (v3C "vec3" floatC) v+codeGenConst (VM42F v) = matX2C "mat4x2" (v4C "vec4" floatC) v+codeGenConst (VM43F v) = matX3C "mat4x3" (v4C "vec4" floatC) v+codeGenConst (VM44F v) = matX4C "mat4" (v4C "vec4" floatC) v++type CGen a = State ([Statement],IntMap [Expr]) a++store :: DAG -> Int -> Expr -> CGen [Expr]+store dag expId exp = do+ let name = "val" ++ show expId+ newVar = Variable name+ t = codeGenType $ expIdType dag expId+ [ty] = {-trace (show expId ++ " [ty] = " ++ show t)-} t+ newStmt = varStmt name (toGLSLType ty) exp+ cnt = expIdCount dag expId+ case cnt > 0 of+ True -> do+ (stmt,varMap) <- get+ put (newStmt:stmt,IntMap.insert expId [newVar] varMap)+ return [newVar]+ False -> return [exp]++addStmt :: Statement -> CGen ()+addStmt s = do+ (stmt,varMap) <- get+ put (s:stmt,varMap)+ return ()++addExpr :: ExpId -> [Expr] -> CGen ()+addExpr expId exprs = do+ (stmt,varMap) <- get+ put (stmt,IntMap.insert expId exprs varMap)+ return ()++type Env = V.Vector [Expr]++codeGenExp' :: DAG -> Map Exp String -> Env -> ExpId -> CGen [Expr]+codeGenExp' dag smpName env expId = do+ (stmt,varMap) <- get+ case IntMap.lookup expId varMap of+ Just v -> return v+ Nothing -> case toExp dag expId of+ + Loop st lc sr is -> do+ -- state transform, loop condition, state to result, initial state+ isE <- codeGenExp' dag smpName env is+ let getBody a = case toExp dag a of+ Lam b -> case toExp dag b of+ Body c -> c+ _ -> error "internal error: illegal lambda function!"+ _ -> error "internal error: illegal lambda function!"+ name = "state" ++ show expId ++ "_"+ t = codeGenType $ expIdType dag is+ (stS,stE) = unzip $ [(varStmt n (toGLSLType ty) e, Variable n) | (e,ty,i) <- zip3 isE t [0..], let n = name ++ show i]+ mapM addStmt stS+ {-+ done - create state variable+ done - create while loop:+ done - loop condition expression+ done - state transformation expression+ done - create result from final state+ -}+ (_,loopCGenState) <- get+ let loop = While (Condition $ BoolConstant True) (CompoundStatement $ Compound $ reverse body)+ env' = (V.snoc env stE)+ (_,(body,_)) = (flip runState) ([],loopCGenState) $ do+ [lcE] <- codeGenExp' dag smpName env' (getBody lc)+ addStmt (SelectionStatement (UnaryNot lcE) Break Nothing)+ stE' <- codeGenExp' dag smpName env' (getBody st)+ mapM_ addStmt $ zipWith assign stE stE'+ return ()+ addStmt loop+ rE <- codeGenExp' dag smpName env' (getBody sr)+ addExpr expId rE+ return rE+ Const c -> store dag expId $ codeGenConst c+ Uni n -> return [Variable $! unpack n]+ PrimVar n -> return [Variable $! unpack n]+ PrimApp f arg -> do+ arg' <- codeGenExp' dag smpName env arg+ let argTy = codeGenType $ expIdType dag arg+ ty = codeGenType $ expIdType dag expId+ e = codeGenPrim f ty argTy arg'+ if length e > 1 then return e else+ store dag expId $ head $ e ++ error "PrimApp - head"+ s@(Sampler f e t) -> case Map.lookup s smpName of+ Just name -> return [Variable name]+ Nothing -> error "Internal error: Unknown sampler value!"+ Cond p t e -> do+ [p'] <- codeGenExp' dag smpName env p+ t' <- codeGenExp' dag smpName env t+ e' <- codeGenExp' dag smpName env e+ let branch a b = Selection p' a b+ return $ zipWith branch t' e'+ e@(Var i li) -> do+ let ty = expType dag e+ arity = length $! codeGenType ty+ errEx = throw $ userError $ unlines $+ [ "codeGenExp failed: "+ , " Var " ++ show i ++ " (" ++ show li ++ ") :: " ++ show ty+ , " input names: " ++ show env+ , " arity: " ++ show arity+ ]+ case env V.!? i of+ Nothing -> errEx+ Just v -> return v --if length v == arity then return v else errEx++ Tup t -> concat <$> mapM (codeGenExp' dag smpName env) t+ p@(Prj idx e) -> do+ let ty = expType dag p+ e' <- codeGenExp' dag smpName env e+ return $ reverse . take (length $ codeGenType ty) . drop idx . reverse $ e'+{-+ required info: output variable names+ if we disable inline functions, it simplifies variable name gen+-}++codeGenVertexShader :: DAG+ -> Map Exp String+ -> [(ByteString,InputType)]+ -> Exp+ -> (ByteString, [(ByteString,GLSL.InterpolationQualifier,InputType)])+codeGenVertexShader dag smpName inVars = cvt+ where+ genExp :: ExpId -> CGen [Expr]+ genExp = codeGenExp' dag smpName $ V.singleton [Variable (unpack n) | n <- map fst inVars]++ genIExp :: Exp -> CGen (GLSL.InterpolationQualifier,[Expr],[InputType])+ genIExp (Flat e) = (GLSL.Flat,,codeGenType $ expIdType dag e) <$> genExp e+ genIExp (Smooth e) = (GLSL.Smooth,,codeGenType $ expIdType dag e) <$> genExp e+ genIExp (NoPerspective e) = (GLSL.NoPerspective,,codeGenType $ expIdType dag e) <$> genExp e++ cvt :: Exp -> (ByteString, [(ByteString,GLSL.InterpolationQualifier,InputType)])+ cvt (Lam lam) = cvt $ toExp dag lam+ cvt (Body bodyExp) = (SB.unlines $!+ [ "#version 330 core"+ -- , "#extension GL_EXT_gpu_shader4 : enable"+ -- , "#pragma optimize(off)"+ , pp [uniform (unpack n) (toGLSLType t) | (n,t) <- uniVars]+ , pp [uniform n (toGLSLType t) | (n,t) <- smpVars]+ , pp [inVar (unpack n) (toGLSLType t) | (n,t) <- inVars]+ , pp [outVarIQ (unpack n) iq (toGLSLType t) | n <- oNames | iq <- oQ | [t] <- oT]+ , "void main ()"+ , ppE (posE:sizeE:concat oE ++ clipE) ("gl_Position":"gl_PointSize":oNames ++ take clipCount clipNames)+ ], [(n,q,t) | n <- oNames | q <- oQ | [t] <- oT])+ where+ clipCount = length clipE+ clipNames = [pack $ "gl_ClipDistance[" ++ show i ++ "]" | i <- [0..]]+ VertexOut pos size clips outs = toExp dag bodyExp+ ppE e a = pack $! show $! pPrint $! Compound $ reverse stmt ++ [assign (Variable (unpack n)) ex | ex <- e | n <- a]+ pp a = pack $! show $! pPrint $! TranslationUnit a+ uniVars = Set.toList $ Set.fromList [(n,t) | u@(Uni n) <- expUniverse' dag (toExp dag bodyExp), let Single t = expType dag u]+ smpVars = Set.toList $ Set.fromList [(n,t) | s@Sampler {} <- expUniverse' dag (toExp dag bodyExp), let Single t = expType dag s, let Just n = Map.lookup s smpName]+ ((clipE,posE,sizeE,oQ,oE,oT),(stmt,_)) = runState genSrc ([],IntMap.empty)+ genSrc = do+ --[posE'] <- genExp pos+ a <- genExp pos+ let [posE'] = {-trace ("let [posE'] = " ++ show a)-} a+ [sizeE'] <- genExp size+ clipE' <- concat <$> mapM genExp clips+ (oQ',oE',oT') <- unzip3 <$> mapM genIExp (map (toExp dag) outs)+ return (clipE',posE',sizeE',oQ',oE',oT')+ oNames = [pack $ "v" ++ show i | i <- [0..]]++codeGenGeometryShader :: DAG+ -> Map Exp String+ -> FetchPrimitive+ -> [(ByteString,GLSL.InterpolationQualifier,InputType)]+ -> Exp+ -> (ByteString, [(ByteString,GLSL.InterpolationQualifier,InputType)])+codeGenGeometryShader dag samplerNameMap inPrim inVars geomSh@(GeometryShader layerCount outPrim maxGenVertices funPrimCnt funPrim funVert) = (SB.concat [srcPre, src], outVars)+ where+{-+ done - uniforms+ done - samplers+ done - input variables+ - output variables+ + - primitive count expression+ - primitive loop+ - vertex loop+-}+ srcPre = pack $ unlines $+ [ "#version 330 core"+ -- , "#extension GL_EXT_gpu_shader4 : enable"+ , "layout(" ++ cvtInputPrim inPrim ++ ") in;"+ , "layout (" ++ cvtOutputPrim outPrim ++ ", max_vertices=" ++ show maxGenVertices ++ ") out;"+ ]+ src = SB.unlines $+ [ pp [uniform (unpack n) (toGLSLType t) | (n,t) <- uniVars]+ , pp [uniform n (toGLSLType t) | (n,t) <- smpVars]+ , pp [inVarArr (unpack n) iq (toGLSLType t) | (n,iq,t) <- inVars]+ , pp [outVarIQ n iq (toGLSLType t) | n <- oNames | iq <- oQ | [t] <- oT]+ , pack "void main ()"+ -- , pack "{ for(int i = 0; i < gl_in.length(); i++) { gl_Position = gl_in[i].gl_Position; gl_PointSize = gl_in[i].gl_PointSize; EmitVertex(); } }"+ , pack $! show $! pPrint $! Compound $ reverse stmt+ ]++ pp a = pack $! show $! pPrint $! TranslationUnit a+ uniVars = Set.toList $ Set.fromList [(n,t) | u@(Uni n) <- expUniverse' dag geomSh, let Single t = expType dag u]+ smpVars = Set.toList $ Set.fromList [(n,t) | s@Sampler {} <- expUniverse' dag geomSh, let Single t = expType dag s, let Just n = Map.lookup s samplerNameMap]++ cvtInputPrim a = case a of+ Points -> "points"+ Lines -> "lines"+ Triangles -> "triangles"+ LinesAdjacency -> "lines_adjacency"+ TrianglesAdjacency -> "triangles_adjacency"++ cvtOutputPrim a = case a of+ TrianglesOutput -> "triangle_strip"+ LinesOutput -> "line_strip"+ PointsOutput -> "points"++ genExp :: Env -> ExpId -> CGen [Expr]+ genExp = codeGenExp' dag samplerNameMap++ genIExp :: Env -> Exp -> CGen (GLSL.InterpolationQualifier,[Expr],[InputType])+ genIExp env (Flat e) = (GLSL.Flat,,codeGenType $ expIdType dag e) <$> genExp env e+ genIExp env (Smooth e) = (GLSL.Smooth,,codeGenType $ expIdType dag e) <$> genExp env e+ genIExp env (NoPerspective e) = (GLSL.NoPerspective,,codeGenType $ expIdType dag e) <$> genExp env e++ oNames = ["g" ++ show i | i <- [0..]]+ ((oQ,oT),(stmt,_)) = runState genSrc ([],IntMap.empty)+ outVars = zip3 (map pack oNames) oQ (concat oT)+ genSrc = do+ -- calculate how many primitives should we generate+ -- create primitive loop (ends with EndPrimitive())+ -- create vertex loop (EmitVertex())+ let primCntBody = getBody funPrimCnt+ primCntLam = funPrimCnt+ primBody = getBody funPrim+ vertBody = getBody funVert+ vertLam = funVert+ GeometryOut stE pE sE cE oE = toExp dag vertBody+ --Tuple [iTy,Single Int] = expIdType dag primCntBody+ Tuple iTyInt = expIdType dag primCntBody+ iTy = Tuple $ take (length iTyInt-1) iTyInt+ (inputTy,clipsTy) = case expIdType dag primCntLam of+ Tuple it@((Tuple [Single V4F,Single Float,ct,_]):_) -> (it,ct)+ it@(Tuple [Single V4F,Single Float,ct,_]) -> ([it],ct)+ t -> error $ "clipsTy error: " ++ show t+ vertStTy = expIdType dag vertLam+ -- create expressions for input primitive vertices+ primVert i = [pre ++ "gl_Position", pre ++ "gl_PointSize"] +++ [pre ++ "gl_ClipDistance[" ++ show n ++ "]" | n <- [0..tySize clipsTy-1]] +++ [unpack n ++ post | (n,_,_) <- inVars]+ where+ pre = "gl_in[" ++ i ++ "]."+ post = "[" ++ i ++ "]"+ inputVerts = map Variable $ concat [primVert (show i) | i <- [0..length inputTy-1]]+ eCnt <- codeGenExp' dag samplerNameMap (V.singleton inputVerts) primCntBody+ (_,varMapP) <- get+ let (primStateE,[primCntE]) = splitAt (length eCnt - 1) eCnt+ (stPS,stPE) = unzip $ [(varStmt n (toGLSLType ty) e, Variable n) | (e,ty,i) <- zip3 primStateE (codeGenType iTy) [0..], let n = "statePrim_" ++ show i]+ primCntVar = Variable "primCnt"+ primIdVar = Variable "gl_PrimitiveID"+ layerVar = Variable "gl_Layer"+ clipVars = [Variable $ "gl_ClipDistance[" ++ show i ++ "]" | i <- [0..]]+ (resP,(sP,_)) = runState primLoop ([],varMapP)+ primLoop = do+ (primIdE:layerE:stPrimStVertCntVert) <- genExp (V.singleton stPE) primBody+ let (stPrimE',xsE) = splitAt (length primStateE) stPrimStVertCntVert+ (stVertE,[vertCntE]) = splitAt (length xsE - 1) xsE+ (stVS,stVE) = unzip $ [(varStmt n (toGLSLType ty) e, Variable n) | (e,ty,i) <- zip3 stVertE (codeGenType vertStTy) [0..], let n = "stateVert_" ++ show i]+ vertCntVar = GLSL.Variable "vertCnt"+ mapM addStmt stVS+ (_,varMapV) <- get+ let (resV,(sV,_)) = runState genVertFun ([],varMapV)+ genVertFun = do+ let env = V.singleton stVE+ genVert = genExp env+ stVE' <- genVert stE+ [posE] <- genVert pE+ [sizeE] <- genVert sE+ clipsE <- concat <$> mapM genVert cE+ (oQ',oE',oT') <- unzip3 <$> mapM (genIExp env) (map (toExp dag) oE)+ -- set vertex variables - position, size, clip distances, outputs+ addStmt $ assign (Variable "gl_Position") posE+ addStmt $ assign (Variable "gl_PointSize") sizeE+ mapM_ addStmt $ zipWith assign clipVars clipsE+ mapM_ addStmt $ zipWith assign (map Variable oNames) (concat oE')+ addStmt $ ExpressionStatement $ Just $ functionCall "EmitVertex" []+ mapM_ addStmt $ zipWith assign stVE stVE'+ return (oQ',oT')+ addStmt $ varStmt "vertCnt" GLSL.Int vertCntE+ addStmt $ assign primIdVar primIdE+ addStmt $ assign layerVar layerE+ addStmt $ GLSL.For (Left Nothing)+ (Just $ GLSL.Condition $ GLSL.Gt vertCntVar (GLSL.IntConstant GLSL.Decimal 0))+ (Just $ GLSL.PostDec vertCntVar)+ (CompoundStatement $ Compound $ reverse sV)+ addStmt $ ExpressionStatement $ Just $ functionCall "EndPrimitive" []+ mapM_ addStmt $ zipWith assign stPE stPrimE'+ return resV+ mapM addStmt stPS+ addStmt $ varStmt "primCnt" GLSL.Int primCntE+ addStmt $ GLSL.For (Left Nothing)+ (Just $ GLSL.Condition $ GLSL.Gt primCntVar (GLSL.IntConstant GLSL.Decimal 0))+ (Just $ GLSL.PostDec primCntVar)+ (CompoundStatement $ Compound $ reverse sP)+ return resP++ getBody a = b+ where+ Lam l = toExp dag a+ Body b = toExp dag l++codeGenFragmentShader :: DAG+ -> Map Exp String+ -> [(ByteString,GLSL.InterpolationQualifier,InputType)]+ -> Exp+ -> Exp+ -> (ByteString, [(ByteString,InputType)],Int)+codeGenFragmentShader dag smpName inVars ffilter = cvt+ where+ cvtF :: Exp -> CGen Expr+ cvtF (Lam lam) = cvtF $ toExp dag lam+ cvtF (Body bodyExp) = do+ [e] <- genExp bodyExp+ return e++ cvt :: Exp -> (ByteString, [(ByteString,InputType)],Int)+ cvt (Lam lam) = cvt $ toExp dag lam+ cvt (Body bodyExp) = case toExp dag bodyExp of+ FragmentOut e -> src e []+ FragmentOutDepth de e -> src e [("gl_FragDepth",de)]+ FragmentOutRastDepth e -> src e []++ genExp :: ExpId -> CGen [Expr]+ genExp = codeGenExp' dag smpName $ V.singleton [Variable (unpack n) | (n,_,_) <- inVars]++ genFExp :: ExpId -> CGen ([Expr],[InputType])+ genFExp e = (,codeGenType $ expIdType dag e) <$> genExp e++ oNames :: [ByteString]+ oNames = [pack $ "f" ++ show i | i <- [0..]]++ src :: [ExpId] -> [(ByteString,ExpId)] -> (ByteString, [(ByteString,InputType)],Int)+ src outs outs' = (SB.unlines $!+ [ "#version 330 core"+ -- , "#extension GL_EXT_gpu_shader4 : enable"+ -- , "#pragma optimize(off)"+ , pp [uniform (unpack n) (toGLSLType t) | (n,t) <- uniVars]+ , pp [uniform n (toGLSLType t) | (n,t) <- smpVars]+ , pp [inVarIQ (unpack n) iq (toGLSLType t) | (n,iq,t) <- inVars]+ , pp [outVar (unpack n) (toGLSLType t) | n <- oNames | [t] <- oT]+ , "void main ()"+ , ppBody $ case ffilter of+ PassAll -> reverse stmt ++ body+ Filter f -> reverse fstmt ++ [SelectionStatement (UnaryNot fexpr) Discard $ Just (CompoundStatement $ Compound $ reverse stmt ++ body)]+ ], [(n,t) | n <- oNames | [t] <- oT], length outs)+ where+ assigns a e = [assign (Variable (unpack n)) ex | ex <- e | n <- a]+ ppBody l = pack $! show $! pPrint $! Compound l+ pp a = pack $! show $! pPrint $! TranslationUnit a+ allExps = concat [expUniverse' dag outs, expUniverse' dag (map snd outs'), filterExps]+ filterExps = case ffilter of+ PassAll -> []+ Filter f -> expUniverse' dag f+ uniVars = Set.toList $ Set.fromList [(n,t) | u@(Uni n) <- allExps, let Single t = expType dag u]+ smpVars = Set.toList $ Set.fromList [(n,t) | s@Sampler {} <- allExps, let Single t = expType dag s, let Just n = Map.lookup s smpName]+ body = assigns (oN' ++ oNames) (concat oE' ++ concat oE)+ ((oE',oN',oE,oT,fstmt,fexpr),(stmt,_)) = runState genSrc ([],IntMap.empty)+ genSrc = do+ fexpr' <- case ffilter of+ PassAll -> return $ boolC True+ Filter f -> cvtF $ toExp dag f+ (fstmt',s) <- get+ put ([],s)+ (oE'',oN'') <- unzip <$> sequence [(,n) <$> genExp e | (n,e) <- outs']+ (oE',oT') <- unzip <$> mapM genFExp outs+ return (oE'',oN'',oE',oT',fstmt',fexpr')+++codeGenType :: Ty -> [InputType]+codeGenType (Single ty) = [ty]+codeGenType (Tuple l) = concatMap codeGenType l+codeGenType t = error $ "codeGenType error: " ++ show t++-- Utility functions+toGLSLType :: InputType -> TypeSpecifierNonArray+toGLSLType t = case t of+ Bool -> GLSL.Bool+ V2B -> GLSL.BVec2+ V3B -> GLSL.BVec3+ V4B -> GLSL.BVec4+ Word -> GLSL.UInt+ V2U -> GLSL.UVec2+ V3U -> GLSL.UVec3+ V4U -> GLSL.UVec4+ Int -> GLSL.Int+ V2I -> GLSL.IVec2+ V3I -> GLSL.IVec3+ V4I -> GLSL.IVec4+ Float -> GLSL.Float+ V2F -> GLSL.Vec2+ V3F -> GLSL.Vec3+ V4F -> GLSL.Vec4+ M22F -> GLSL.Mat2+ M23F -> GLSL.Mat2x3+ M24F -> GLSL.Mat2x4+ M32F -> GLSL.Mat3x2+ M33F -> GLSL.Mat3+ M34F -> GLSL.Mat3x4+ M42F -> GLSL.Mat4x2+ M43F -> GLSL.Mat4x3+ M44F -> GLSL.Mat4+ -- shadow textures+ STexture1D -> GLSL.Sampler1DShadow+ STexture2D -> GLSL.Sampler2DShadow+ STextureCube -> GLSL.SamplerCubeShadow+ STexture1DArray -> GLSL.Sampler1DArrayShadow+ STexture2DArray -> GLSL.Sampler2DArrayShadow+ STexture2DRect -> GLSL.Sampler2DRectShadow+ -- float textures+ FTexture1D -> GLSL.Sampler1D+ FTexture2D -> GLSL.Sampler2D+ FTexture3D -> GLSL.Sampler3D+ FTextureCube -> GLSL.SamplerCube+ FTexture1DArray -> GLSL.Sampler1DArray+ FTexture2DArray -> GLSL.Sampler2DArray+ FTexture2DMS -> GLSL.Sampler2DMS+ FTexture2DMSArray -> GLSL.Sampler2DMSArray+ FTextureBuffer -> GLSL.SamplerBuffer+ FTexture2DRect -> GLSL.Sampler2DRect+ -- int textures+ ITexture1D -> GLSL.ISampler1D+ ITexture2D -> GLSL.ISampler2D+ ITexture3D -> GLSL.ISampler3D+ ITextureCube -> GLSL.ISamplerCube+ ITexture1DArray -> GLSL.ISampler1DArray+ ITexture2DArray -> GLSL.ISampler2DArray+ ITexture2DMS -> GLSL.ISampler2DMS+ ITexture2DMSArray -> GLSL.ISampler2DMSArray+ ITextureBuffer -> GLSL.ISamplerBuffer+ ITexture2DRect -> GLSL.ISampler2DRect+ -- uint textures+ UTexture1D -> GLSL.USampler1D+ UTexture2D -> GLSL.USampler2D+ UTexture3D -> GLSL.USampler3D+ UTextureCube -> GLSL.USamplerCube+ UTexture1DArray -> GLSL.USampler1DArray+ UTexture2DArray -> GLSL.USampler2DArray+ UTexture2DMS -> GLSL.USampler2DMS+ UTexture2DMSArray -> GLSL.USampler2DMSArray+ UTextureBuffer -> GLSL.USamplerBuffer+ UTexture2DRect -> GLSL.USampler2DRect++varInit :: String -> TypeSpecifierNonArray -> Maybe TypeQualifier -> Maybe Expr -> Declaration+varInit name ty tq val = InitDeclaration (TypeDeclarator varType) [InitDecl name Nothing val]+ where+ varTySpecNoPrec = TypeSpecNoPrecision ty Nothing+ varTySpec = TypeSpec Nothing varTySpecNoPrec+ varType = FullType tq varTySpec++var :: String -> TypeSpecifierNonArray -> Maybe TypeQualifier -> Declaration+var name ty tq = varInit name ty tq Nothing++uniform :: String -> TypeSpecifierNonArray -> ExternalDeclaration+uniform name ty = Declaration $ var name ty (Just $ TypeQualSto Uniform)++inVar :: String -> TypeSpecifierNonArray -> ExternalDeclaration+inVar name ty = Declaration $ var name ty (Just $ TypeQualSto In)++inVarArr :: String -> GLSL.InterpolationQualifier -> TypeSpecifierNonArray -> ExternalDeclaration+inVarArr name iq ty = Declaration $ InitDeclaration (TypeDeclarator varType) [InitDecl name (Just Nothing) Nothing]+ where+ tq = Just $ TypeQualInt iq $ Just In+ varTySpecNoPrec = TypeSpecNoPrecision ty Nothing+ varTySpec = TypeSpec Nothing varTySpecNoPrec+ varType = FullType tq varTySpec++inVarIQ :: String -> GLSL.InterpolationQualifier -> TypeSpecifierNonArray -> ExternalDeclaration+inVarIQ name iq ty = Declaration $ var name ty (Just $ TypeQualInt iq $ Just In)++outVar :: String -> TypeSpecifierNonArray -> ExternalDeclaration+outVar name ty = Declaration $ var name ty (Just $ TypeQualSto Out)++outVarIQ :: String -> GLSL.InterpolationQualifier -> TypeSpecifierNonArray -> ExternalDeclaration+outVarIQ name iq ty = Declaration $ var name ty (Just $ TypeQualInt iq $ Just Out)+{-+attribute :: String -> TypeSpecifierNonArray -> ExternalDeclaration+attribute name ty = Declaration $ var name ty (Just $ TypeQualSto Attribute)++varying :: String -> TypeSpecifierNonArray -> ExternalDeclaration+varying name ty = Declaration $ var name ty (Just $ TypeQualSto Varying)++varyingIQ :: String -> GLSL.InterpolationQualifier -> TypeSpecifierNonArray -> ExternalDeclaration+varyingIQ name iq ty = Declaration $ var name ty (Just $ TypeQualInt iq $ Just Varying)+-}+assign :: Expr -> Expr -> Statement+assign l r = ExpressionStatement $ Just $ Equal l r++varStmt :: String -> TypeSpecifierNonArray -> Expr -> Statement+varStmt name ty val = DeclarationStatement $ varInit name ty Nothing $ Just val
+ src/lib/LambdaCube/GL/Mesh.hs view
@@ -0,0 +1,229 @@+module LambdaCube.GL.Mesh (+ loadMesh,+ saveMesh,+ addMesh,+ compileMesh,+ updateMesh,+ Mesh(..),+ MeshPrimitive(..),+ MeshAttribute(..)+) where++import Control.Applicative+import Control.Monad+import Data.Binary+import Data.ByteString.Char8 (ByteString)+import Foreign.Ptr+import Data.Int+import Foreign.Storable+import Foreign.Marshal.Utils+import System.IO.Unsafe+import qualified Data.ByteString.Char8 as SB+import qualified Data.ByteString.Lazy as LB+import qualified Data.Trie as T+import qualified Data.Vector.Storable as V+import qualified Data.Vector.Storable.Mutable as MV++import LambdaCube.GL++fileVersion :: Int32+fileVersion = 1++data MeshAttribute+ = A_Float (V.Vector Float)+ | A_V2F (V.Vector V2F)+ | A_V3F (V.Vector V3F)+ | A_V4F (V.Vector V4F)+ | A_M22F (V.Vector M22F)+ | A_M33F (V.Vector M33F)+ | A_M44F (V.Vector M44F)+ | A_Int (V.Vector Int32)+ | A_Word (V.Vector Word32)++data MeshPrimitive+ = P_Points+ | P_TriangleStrip+ | P_Triangles+ | P_TriangleStripI (V.Vector Int32)+ | P_TrianglesI (V.Vector Int32)++data Mesh+ = Mesh + { mAttributes :: T.Trie MeshAttribute+ , mPrimitive :: MeshPrimitive+ , mGPUData :: Maybe GPUData+ }++data GPUData+ = GPUData+ { dPrimitive :: Primitive+ , dStreams :: T.Trie (Stream Buffer)+ , dIndices :: Maybe (IndexStream Buffer)+ }++loadMesh :: ByteString -> IO Mesh+loadMesh n = compileMesh =<< decode <$> LB.readFile (SB.unpack n)++saveMesh :: ByteString -> Mesh -> IO ()+saveMesh n m = LB.writeFile (SB.unpack n) (encode m)++addMesh :: Renderer -> ByteString -> Mesh -> [ByteString] -> IO Object+addMesh renderer slotName (Mesh _ _ (Just (GPUData prim streams indices))) objUniNames = do+ -- select proper attributes+ let Just (slotPrim,slotStreams) = T.lookup slotName $! slotStream renderer+ filterStream n s+ | T.member n slotStreams = Just s+ | otherwise = Nothing+ addObject renderer slotName prim indices (T.mapBy filterStream streams) objUniNames+addMesh _ _ _ _ = fail "addMesh: only compiled mesh with GPUData is supported"++withV w a f = w a (\p -> f $ castPtr p)++meshAttrToArray :: MeshAttribute -> Array+meshAttrToArray (A_Float v) = Array ArrFloat (1 * V.length v) $ withV V.unsafeWith v+meshAttrToArray (A_V2F v) = Array ArrFloat (2 * V.length v) $ withV V.unsafeWith v+meshAttrToArray (A_V3F v) = Array ArrFloat (3 * V.length v) $ withV V.unsafeWith v+meshAttrToArray (A_V4F v) = Array ArrFloat (4 * V.length v) $ withV V.unsafeWith v+meshAttrToArray (A_M22F v) = Array ArrFloat (4 * V.length v) $ withV V.unsafeWith v+meshAttrToArray (A_M33F v) = Array ArrFloat (9 * V.length v) $ withV V.unsafeWith v+meshAttrToArray (A_M44F v) = Array ArrFloat (16 * V.length v) $ withV V.unsafeWith v+meshAttrToArray (A_Int v) = Array ArrInt32 (1 * V.length v) $ withV V.unsafeWith v+meshAttrToArray (A_Word v) = Array ArrWord32 (1 * V.length v) $ withV V.unsafeWith v++meshAttrToStream :: Buffer -> Int -> MeshAttribute -> Stream Buffer+meshAttrToStream b i (A_Float v) = Stream TFloat b i 0 (V.length v)+meshAttrToStream b i (A_V2F v) = Stream TV2F b i 0 (V.length v)+meshAttrToStream b i (A_V3F v) = Stream TV3F b i 0 (V.length v)+meshAttrToStream b i (A_V4F v) = Stream TV4F b i 0 (V.length v)+meshAttrToStream b i (A_M22F v) = Stream TM22F b i 0 (V.length v)+meshAttrToStream b i (A_M33F v) = Stream TM33F b i 0 (V.length v)+meshAttrToStream b i (A_M44F v) = Stream TM44F b i 0 (V.length v)+meshAttrToStream b i (A_Int v) = Stream TInt b i 0 (V.length v)+meshAttrToStream b i (A_Word v) = Stream TWord b i 0 (V.length v)++{-+updateBuffer :: Buffer -> [(Int,Array)] -> IO ()++ | Stream + { streamType :: StreamType+ , streamBuffer :: b+ , streamArrIdx :: Int+ , streamStart :: Int+ , streamLength :: Int+ }++-- stream of index values (for index buffer)+data IndexStream b+ = IndexStream+ { indexBuffer :: b+ , indexArrIdx :: Int+ , indexStart :: Int+ , indexLength :: Int+ }+-}+updateMesh :: Mesh -> [(ByteString,MeshAttribute)] -> Maybe MeshPrimitive -> IO ()+updateMesh (Mesh dMA dMP (Just (GPUData _ dS dI))) al mp = do+ -- check type match+ let arrayChk (Array t1 s1 _) (Array t2 s2 _) = t1 == t2 && s1 == s2+ ok = and [T.member n dMA && arrayChk (meshAttrToArray a1) (meshAttrToArray a2) | (n,a1) <- al, let Just a2 = T.lookup n dMA]+ if not ok then putStrLn "updateMesh: attribute mismatch!"+ else do+ forM_ al $ \(n,a) -> do+ case T.lookup n dS of+ Just (Stream _ b i _ _) -> updateBuffer b [(i,meshAttrToArray a)]+ _ -> return ()+{-+ case mp of+ Nothing -> return ()+ Just p -> do+ let ok2 = case (dMP,p) of+ (Just (P_TriangleStripI v1, P_TriangleStripI v2) -> V.length v1 == V.length v2+ (P_TrianglesI v1, P_TrianglesI v2) -> V.length v1 == V.length v2+ (a,b) -> a == b+-}++compileMesh :: Mesh -> IO Mesh+compileMesh (Mesh attrs mPrim Nothing) = do+ let mkIndexBuf v = do+ iBuf <- compileBuffer [Array ArrWord32 (V.length v) $ withV V.unsafeWith v]+ return $! Just $! IndexStream iBuf 0 0 (V.length v)+ vBuf <- compileBuffer [meshAttrToArray a | a <- T.elems attrs]+ (indices,prim) <- case mPrim of+ P_Points -> return (Nothing,PointList)+ P_TriangleStrip -> return (Nothing,TriangleStrip)+ P_Triangles -> return (Nothing,TriangleList)+ P_TriangleStripI v -> (,TriangleStrip) <$> mkIndexBuf v+ P_TrianglesI v -> (,TriangleList) <$> mkIndexBuf v+ let streams = T.fromList $! zipWith (\i (n,a) -> (n,meshAttrToStream vBuf i a)) [0..] (T.toList attrs)+ gpuData = GPUData prim streams indices+ return $! Mesh attrs mPrim (Just gpuData)++compileMesh mesh = return mesh++sblToV :: Storable a => [SB.ByteString] -> V.Vector a+sblToV ls = v+ where+ offs o (s:xs) = (o,s):offs (o + SB.length s) xs+ offs _ [] = []+ cnt = sum (map SB.length ls) `div` (sizeOf $ V.head v)+ v = unsafePerformIO $ do+ mv <- MV.new cnt+ MV.unsafeWith mv $ \dst -> forM_ (offs 0 ls) $ \(o,s) ->+ SB.useAsCStringLen s $ \(src,len) -> moveBytes (plusPtr dst o) src len+ V.unsafeFreeze mv++vToSB :: Storable a => V.Vector a -> SB.ByteString+vToSB v = unsafePerformIO $ do+ let len = V.length v * sizeOf (V.head v)+ V.unsafeWith v $ \p -> SB.packCStringLen (castPtr p,len)++instance Storable a => Binary (V.Vector a) where+ put v = put $ vToSB v+ get = do s <- get ; return $ sblToV [s]++instance Binary MeshAttribute where+ put (A_Float a) = putWord8 0 >> put a+ put (A_V2F a) = putWord8 1 >> put a+ put (A_V3F a) = putWord8 2 >> put a+ put (A_V4F a) = putWord8 3 >> put a+ put (A_M22F a) = putWord8 4 >> put a+ put (A_M33F a) = putWord8 5 >> put a+ put (A_M44F a) = putWord8 6 >> put a+ put (A_Int a) = putWord8 7 >> put a+ put (A_Word a) = putWord8 8 >> put a+ get = do+ tag_ <- getWord8+ case tag_ of+ 0 -> A_Float <$> get+ 1 -> A_V2F <$> get+ 2 -> A_V3F <$> get+ 3 -> A_V4F <$> get+ 4 -> A_M22F <$> get+ 5 -> A_M33F <$> get+ 6 -> A_M44F <$> get+ 7 -> A_Int <$> get+ 8 -> A_Word <$> get+ _ -> fail "no parse"++instance Binary MeshPrimitive where+ put P_Points = putWord8 0+ put P_TriangleStrip = putWord8 1+ put P_Triangles = putWord8 2+ put (P_TriangleStripI a) = putWord8 3 >> put a+ put (P_TrianglesI a) = putWord8 4 >> put a+ get = do+ tag_ <- getWord8+ case tag_ of+ 0 -> return P_Points+ 1 -> return P_TriangleStrip+ 2 -> return P_Triangles+ 3 -> P_TriangleStripI <$> get+ 4 -> P_TrianglesI <$> get+ _ -> fail "no parse"++instance Binary Mesh where+ put (Mesh a b _) = put (T.toList a) >> put b+ get = do+ a <- get+ b <- get+ return $! Mesh (T.fromList a) b Nothing
+ src/lib/LambdaCube/GL/Type.hs view
@@ -0,0 +1,476 @@+module LambdaCube.GL.Type where++import Data.ByteString.Char8 (ByteString)+import Data.IORef+import Data.Word+import Data.Map (Map)+--import Data.IntMap (IntMap)+import Data.Set (Set)+import Data.Trie (Trie)+import Data.Vector.Unboxed.Mutable (IOVector)+import qualified Data.Vector as V+import qualified Data.Vector.Unboxed.Mutable as MV++import Graphics.Rendering.OpenGL.Raw.Core32 (GLint, GLuint)+import Foreign.Storable+import Foreign.Ptr+import Data.Int+import Data.Typeable++import LambdaCube.Core.Type+import LambdaCube.Core.DeBruijn++{-+ we should store:+ generic attributer setters (default values in that case when an attribute is missing from a mesh)+ question:+ should we provide default attributes or should we require a full attribute description from the user?+ answer: the latter seems better idea!+ question:+ is a mesh object constant in vertex attributes? e.g. if we'd like to change the value of an attribute buffer or generic attribute+ then we have to swap the old mesh object with a new one.+ answer: seems a good and reasonable idea, because we can customize object rendering using per object uniforms!+ PUBLIC:+ - slotUniforms :: Trie (Trie InputType)+ - slotStreams :: Trie (PrimitiveType, Trie InputType)+ - uniformSetter :: Trie InputSetter+ - render :: IO ()+ - dispose :: IO ()+ INTERNAL:+ - object sets :: Trie (TVar ObjectSet)+ - globalUniformSetup :: Trie (GLint -> IO ())+ - uniform setup actions :: Trie (STM (GLint -> IO (), InputSetter))+ - attribute setup actions :: Trie (GLuint -> StreamSetter)++ note: if we'd like to support slot sharing between different sub gfx networks,+ then we have to check that they have the same primitve type and+ there is no type collision if we build the union of they stream input+ otherwise we can not support slot sharing.+ should we use namespaces in stream input names?+ e.g "slot name/atribute name" in this case we can store stream attribute descriptions in a single trie.+ or should we use trie of tries?+ discussion:+ how to handle sub network uniform/attribute naming+ - global all+ - namespace prefix in name+ - trie of tries+ temporary decision:+ i'll use global names++ minimal restricition for (global name) uniforms and attributes:+ a name sould bound to only one type!++ TODO:+ proper handling of attribute and uniform sharing between shader programs+ two alternatives:+ - use same mapping for every program (more efficient, but requires more gl features)+ - use custom mapping per program with custom attribute/uniform setter (less efficient, but more compatible/less restricitive)+-}++---------+-- API --+---------+{-+-- Buffer+ compileBuffer :: [Array] -> IO Buffer+ bufferSize :: Buffer -> Int+ arraySize :: Buffer -> Int -> Int+ arrayType :: Buffer -> Int -> ArrayType++-- Renderer+ compileRenderer :: GPOutput -> IO Renderer+ slotUniforms :: Renderer -> Trie (Trie InputType)+ slotStreams :: Renderer -> Trie (PrimitiveType, Trie InputType)+ uniformSetter :: Renderer -> Trie InputSetter+ render :: Renderer -> IO ()+ dispose :: Renderer -> IO ()++-- Object+ addObject :: Renderer -> ByteString -> Primitive -> Maybe (IndexStream Buffer) -> Trie (Stream Buffer) -> [ByteString] -> IO Object+ removeObject :: Renderer -> Object -> IO ()+ objectUniformSetter :: Object -> Trie InputSetter+-}++data Renderer -- internal type+ = Renderer+ -- public+ { slotUniform :: Trie (Trie InputType)+ , slotStream :: Trie (FetchPrimitive, Trie InputType)+ , uniformSetter :: Trie InputSetter -- global uniform+ , render :: IO ()+ , dispose :: IO ()+ , setScreenSize :: Word -> Word -> IO ()+ , samplerOutput :: Trie TextureData++ -- internal+ , mkUniformSetup :: Trie (GLint -> IO ()) -- global unifiorm+ , slotDescriptor :: Trie SlotDescriptor+ , renderDescriptor :: Map Exp RenderDescriptor --Map GP RenderDescriptor+ , renderState :: RenderState+ , objectIDSeed :: IORef Int+ }++data RenderDescriptor+ = RenderDescriptor+ { uniformLocation :: Trie GLint -- Uniform name -> GLint+ , streamLocation :: Trie GLuint -- Attribute name -> GLuint+ , renderAction :: IO ()+ , disposeAction :: IO ()+ , drawObjectsIORef :: IORef ObjectSet -- updated internally, according objectSet+ -- hint: Map is required to support slot sharing across different Accumulation nodes,+ -- because each node requires it's own render action list: [IO ()]+ , fragmentOutCount :: Int+ }++data SlotDescriptor+ = SlotDescriptor+ { attachedGP :: Set Exp+ , objectSet :: IORef (Set Object) -- objects, added to this slot (set by user)+ }++data ObjectSet+ = ObjectSet+ { drawObject :: IO () -- synthetized/sorted render action+ , drawObjectMap :: Map Object (IO ()) -- original render actions+ }++data Object -- internal type+ = Object+ { objectSlotName :: ByteString+ , objectUniformSetter :: Trie InputSetter+ , objectID :: Int+ , objectEnabledIORef :: IORef Bool+ }++instance Eq Object where+ a == b = objectID a == objectID b++instance Ord Object where+ a `compare` b = objectID a `compare` objectID b++data RenderState+ = RenderState+ { textureUnitState :: IOVector Int+ , renderTargetSize :: IORef V2U+ }++type StreamSetter = Stream Buffer -> IO ()++data Buffer -- internal type+ = Buffer+ { bufArrays :: V.Vector ArrayDesc+ , bufGLObj :: GLuint+ }+ deriving (Show,Eq)++data ArrayDesc+ = ArrayDesc+ { arrType :: ArrayType+ , arrLength :: Int -- item count+ , arrOffset :: Int -- byte position in buffer+ , arrSize :: Int -- size in bytes+ }+ deriving (Show,Eq)++-- storable instances+instance Storable a => Storable (V2 a) where+ sizeOf _ = 2 * sizeOf (undefined :: a)+ alignment _ = sizeOf (undefined :: a)++ peek q = do+ let p = castPtr q :: Ptr a+ k = sizeOf (undefined :: a)+ x <- peek p + y <- peekByteOff p k+ return $! (V2 x y)++ poke q (V2 x y) = do+ let p = castPtr q :: Ptr a+ k = sizeOf (undefined :: a)+ poke p x+ pokeByteOff p k y++instance Storable a => Storable (V3 a) where+ sizeOf _ = 3 * sizeOf (undefined :: a)+ alignment _ = sizeOf (undefined :: a)++ peek q = do+ let p = castPtr q :: Ptr a+ k = sizeOf (undefined :: a)+ x <- peek p + y <- peekByteOff p k+ z <- peekByteOff p (k*2)+ return $! (V3 x y z)++ poke q (V3 x y z) = do+ let p = castPtr q :: Ptr a+ k = sizeOf (undefined :: a)+ poke p x+ pokeByteOff p k y+ pokeByteOff p (k*2) z++instance Storable a => Storable (V4 a) where+ sizeOf _ = 4 * sizeOf (undefined :: a)+ alignment _ = sizeOf (undefined :: a)++ peek q = do+ let p = castPtr q :: Ptr a+ k = sizeOf (undefined :: a)+ x <- peek p + y <- peekByteOff p k+ z <- peekByteOff p (k*2)+ w <- peekByteOff p (k*3)+ return $! (V4 x y z w)++ poke q (V4 x y z w) = do+ let p = castPtr q :: Ptr a+ k = sizeOf (undefined :: a)+ poke p x+ pokeByteOff p k y+ pokeByteOff p (k*2) z+ pokeByteOff p (k*3) w++data TextureData+ = TextureData+ { textureObject :: GLuint+ } deriving Show++type SetterFun a = a -> IO ()+newtype Getter a = Getter (IO a)+newtype Setter a = Setter (SetterFun a)++type InputGetter = Input Getter+type InputSetter = Input Setter++-- user will provide scalar input data via this type+data Input a+ = SBool (a Bool)+ | SV2B (a V2B)+ | SV3B (a V3B)+ | SV4B (a V4B)+ | SWord (a Word32)+ | SV2U (a V2U)+ | SV3U (a V3U)+ | SV4U (a V4U)+ | SInt (a Int32)+ | SV2I (a V2I)+ | SV3I (a V3I)+ | SV4I (a V4I)+ | SFloat (a Float)+ | SV2F (a V2F)+ | SV3F (a V3F)+ | SV4F (a V4F)+ | SM22F (a M22F)+ | SM23F (a M23F)+ | SM24F (a M24F)+ | SM32F (a M32F)+ | SM33F (a M33F)+ | SM34F (a M34F)+ | SM42F (a M42F)+ | SM43F (a M43F)+ | SM44F (a M44F)+ -- shadow textures+ | SSTexture1D+ | SSTexture2D+ | SSTextureCube+ | SSTexture1DArray+ | SSTexture2DArray+ | SSTexture2DRect+ -- float textures+ | SFTexture1D+ | SFTexture2D (a TextureData)+ | SFTexture3D+ | SFTextureCube+ | SFTexture1DArray+ | SFTexture2DArray+ | SFTexture2DMS+ | SFTexture2DMSArray+ | SFTextureBuffer+ | SFTexture2DRect+ -- int textures+ | SITexture1D+ | SITexture2D+ | SITexture3D+ | SITextureCube+ | SITexture1DArray+ | SITexture2DArray+ | SITexture2DMS+ | SITexture2DMSArray+ | SITextureBuffer+ | SITexture2DRect+ -- uint textures+ | SUTexture1D+ | SUTexture2D+ | SUTexture3D+ | SUTextureCube+ | SUTexture1DArray+ | SUTexture2DArray+ | SUTexture2DMS+ | SUTexture2DMSArray+ | SUTextureBuffer+ | SUTexture2DRect++-- buffer handling+{-+ user can fills a buffer (continuous memory region)+ each buffer have a data descriptor, what describes the+ buffer content. e.g. a buffer can contain more arrays of stream types+-}++-- user will provide stream data using this setup function+type BufferSetter = (Ptr () -> IO ()) -> IO ()++-- specifies array component type (stream type in storage side)+-- this type can be overridden in GPU side, e.g ArrWord8 can be seen as TFloat or TWord also+data ArrayType+ = ArrWord8+ | ArrWord16+ | ArrWord32+ | ArrInt8+ | ArrInt16+ | ArrInt32+ | ArrFloat+ | ArrHalf -- Hint: half float is not supported in haskell+ deriving (Read,Typeable,Show,Eq,Ord)++sizeOfArrayType :: ArrayType -> Int+sizeOfArrayType ArrWord8 = 1+sizeOfArrayType ArrWord16 = 2+sizeOfArrayType ArrWord32 = 4+sizeOfArrayType ArrInt8 = 1+sizeOfArrayType ArrInt16 = 2+sizeOfArrayType ArrInt32 = 4+sizeOfArrayType ArrFloat = 4+sizeOfArrayType ArrHalf = 2++-- describes an array in a buffer+data Array -- array type, element count (NOT byte size!), setter+ = Array ArrayType Int BufferSetter++data Primitive+ = TriangleStrip+ | TriangleList+ | TriangleFan+ | LineStrip+ | LineList+ | PointList+ | TriangleStripAdjacency+ | TriangleListAdjacency+ | LineStripAdjacency+ | LineListAdjacency+ deriving (Read,Typeable,Eq,Ord,Bounded,Enum,Show)++-- dev hint: this should be InputType+-- we restrict StreamType using type class+-- subset of InputType, describes a stream type (in GPU side)+data StreamType+ = TWord+ | TV2U+ | TV3U+ | TV4U+ | TInt+ | TV2I+ | TV3I+ | TV4I+ | TFloat+ | TV2F+ | TV3F+ | TV4F+ | TM22F+ | TM23F+ | TM24F+ | TM32F+ | TM33F+ | TM34F+ | TM42F+ | TM43F+ | TM44F+ deriving (Read,Typeable,Show,Eq,Ord)++toStreamType :: InputType -> Maybe StreamType+toStreamType Word = Just TWord+toStreamType V2U = Just TV2U+toStreamType V3U = Just TV3U+toStreamType V4U = Just TV4U+toStreamType Int = Just TInt+toStreamType V2I = Just TV2I+toStreamType V3I = Just TV3I+toStreamType V4I = Just TV4I+toStreamType Float = Just TFloat+toStreamType V2F = Just TV2F+toStreamType V3F = Just TV3F+toStreamType V4F = Just TV4F+toStreamType M22F = Just TM22F+toStreamType M23F = Just TM23F+toStreamType M24F = Just TM24F+toStreamType M32F = Just TM32F+toStreamType M33F = Just TM33F+toStreamType M34F = Just TM34F+toStreamType M42F = Just TM42F+toStreamType M43F = Just TM43F+toStreamType M44F = Just TM44F+toStreamType _ = Nothing++fromStreamType :: StreamType -> InputType+fromStreamType TWord = Word+fromStreamType TV2U = V2U+fromStreamType TV3U = V3U+fromStreamType TV4U = V4U+fromStreamType TInt = Int+fromStreamType TV2I = V2I+fromStreamType TV3I = V3I+fromStreamType TV4I = V4I+fromStreamType TFloat = Float+fromStreamType TV2F = V2F+fromStreamType TV3F = V3F+fromStreamType TV4F = V4F+fromStreamType TM22F = M22F+fromStreamType TM23F = M23F+fromStreamType TM24F = M24F+fromStreamType TM32F = M32F+fromStreamType TM33F = M33F+fromStreamType TM34F = M34F+fromStreamType TM42F = M42F+fromStreamType TM43F = M43F+fromStreamType TM44F = M44F++-- user can specify streams using Stream type+-- a stream can be constant (ConstXXX) or can came from a buffer+data Stream b+ = ConstWord Word32+ | ConstV2U V2U+ | ConstV3U V3U+ | ConstV4U V4U+ | ConstInt Int32+ | ConstV2I V2I+ | ConstV3I V3I+ | ConstV4I V4I+ | ConstFloat Float+ | ConstV2F V2F+ | ConstV3F V3F+ | ConstV4F V4F+ | ConstM22F M22F+ | ConstM23F M23F+ | ConstM24F M24F+ | ConstM32F M32F+ | ConstM33F M33F+ | ConstM34F M34F+ | ConstM42F M42F+ | ConstM43F M43F+ | ConstM44F M44F+ | Stream + { streamType :: StreamType+ , streamBuffer :: b+ , streamArrIdx :: Int+ , streamStart :: Int+ , streamLength :: Int+ }++-- stream of index values (for index buffer)+data IndexStream b+ = IndexStream+ { indexBuffer :: b+ , indexArrIdx :: Int+ , indexStart :: Int+ , indexLength :: Int+ }
+ src/lib/LambdaCube/GL/Util.hs view
@@ -0,0 +1,990 @@+module LambdaCube.GL.Util (+ queryUniforms,+ queryStreams,+ mkUniformSetter,+ mkSSetter,+ compileShader,+ printProgramLog,+ glGetShaderiv1,+ glGetProgramiv1,+ Buffer(..),+ ArrayDesc(..),+ StreamSetter,+ streamToInputType,+ arrayTypeToGLType,+ comparisonFunctionToGLType,+ logicOperationToGLType,+ blendEquationToGLType,+ blendingFactorToGLType,+ checkGL,+ textureDataTypeToGLType,+ textureDataTypeToGLArityType,+ glGetIntegerv1,+ setSampler,+ checkFBO,+ createGLTextureObject+) where++import Control.Applicative+import Control.Exception+import Control.Monad+import Data.ByteString.Char8 (ByteString)+import Data.IORef+import Data.List as L+import Data.Trie as T+import Foreign+import qualified Data.ByteString.Char8 as SB+import qualified Data.Vector as V+import Data.Vector.Unboxed.Mutable (IOVector)+import qualified Data.Vector.Unboxed.Mutable as MV++import Graphics.Rendering.OpenGL.Raw.Core32+ ( GLchar+ , GLenum+ , GLint+ , GLsizei+ , GLuint+ , gl_FALSE+ , gl_TRUE+ , glGetIntegerv++ -- ERROR CHECKING related+ -- error handling+ , glGetError+ , glCheckFramebufferStatus+ -- error checking+ , gl_COMPILE_STATUS+ , gl_DRAW_FRAMEBUFFER+ , gl_FRAMEBUFFER_COMPLETE+ , gl_FRAMEBUFFER_INCOMPLETE_ATTACHMENT+ , gl_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER+ , gl_FRAMEBUFFER_INCOMPLETE_LAYER_TARGETS+ , gl_FRAMEBUFFER_INCOMPLETE_MULTISAMPLE+ , gl_FRAMEBUFFER_INCOMPLETE_READ_BUFFER+ , gl_FRAMEBUFFER_UNDEFINED+ , gl_FRAMEBUFFER_UNSUPPORTED+ , gl_INFO_LOG_LENGTH+ , gl_INVALID_ENUM+ , gl_INVALID_FRAMEBUFFER_OPERATION+ , gl_INVALID_OPERATION+ , gl_INVALID_VALUE+ , gl_NO_ERROR+ , gl_OUT_OF_MEMORY++ -- TEXTURE related+ -- texture data+ , glActiveTexture+ , glBindTexture+ , glGenTextures+ , glTexImage2D+ , glTexImage3D+ , glTexParameteri+ , gl_TEXTURE0++ -- texture parameters+ , gl_CLAMP_TO_BORDER+ , gl_CLAMP_TO_EDGE+ , gl_MIRRORED_REPEAT+ , gl_REPEAT+ , gl_LINEAR+ , gl_NEAREST++ , gl_TEXTURE_CUBE_MAP+ , gl_TEXTURE_CUBE_MAP_POSITIVE_X+ , gl_TEXTURE_CUBE_MAP_NEGATIVE_X+ , gl_TEXTURE_CUBE_MAP_POSITIVE_Y+ , gl_TEXTURE_CUBE_MAP_NEGATIVE_Y+ , gl_TEXTURE_CUBE_MAP_POSITIVE_Z+ , gl_TEXTURE_CUBE_MAP_NEGATIVE_Z+ , gl_TEXTURE_2D+ , gl_TEXTURE_2D_ARRAY+ , gl_TEXTURE_MAG_FILTER+ , gl_TEXTURE_MIN_FILTER+ , gl_TEXTURE_WRAP_S+ , gl_TEXTURE_WRAP_T+ , gl_TEXTURE_BASE_LEVEL+ , gl_TEXTURE_MAX_LEVEL++ -- texture format+ , gl_R32F+ , gl_R32I+ , gl_R32UI+ , gl_RED+ , gl_RG+ , gl_RG32F+ , gl_RG32I+ , gl_RG32UI+ , gl_RGB+ , gl_RGB32F+ , gl_RGB32I+ , gl_RGB32UI+ , gl_RGBA+ , gl_RGBA32F+ , gl_RGBA32I+ , gl_RGBA32UI++ -- SHADER related+ -- shader program+ , glCompileShader+ , glGetActiveAttrib+ , glGetActiveUniform+ , glGetAttribLocation+ , glGetProgramInfoLog+ , glGetProgramiv+ , glGetShaderInfoLog+ , glGetShaderiv+ , glGetUniformLocation+ , glShaderSource++ -- stream data (stream parameter)+ , glBindBuffer+ , glDisableVertexAttribArray+ , glEnableVertexAttribArray+ , glVertexAttrib1fv+ , glVertexAttrib2fv+ , glVertexAttrib3fv+ , glVertexAttrib4fv+ , glVertexAttribI1iv+ , glVertexAttribI1uiv+ , glVertexAttribI2iv+ , glVertexAttribI2uiv+ , glVertexAttribI3iv+ , glVertexAttribI3uiv+ , glVertexAttribI4iv+ , glVertexAttribI4uiv+ , glVertexAttribIPointer+ , glVertexAttribPointer+ , gl_ACTIVE_ATTRIBUTES+ , gl_ACTIVE_ATTRIBUTE_MAX_LENGTH+ , gl_ARRAY_BUFFER++ -- stream value representation+ , gl_BYTE+ , gl_HALF_FLOAT+ , gl_SHORT+ , gl_UNSIGNED_BYTE+ , gl_UNSIGNED_SHORT++ -- uniform data (constant parameter)+ , glUniform1fv+ , glUniform1i+ , glUniform1iv+ , glUniform1uiv+ , glUniform2fv+ , glUniform2iv+ , glUniform2uiv+ , glUniform3fv+ , glUniform3iv+ , glUniform3uiv+ , glUniform4fv+ , glUniform4iv+ , glUniform4uiv+ , glUniformMatrix2fv+ , glUniformMatrix2x3fv+ , glUniformMatrix2x4fv+ , glUniformMatrix3fv+ , glUniformMatrix3x2fv+ , glUniformMatrix3x4fv+ , glUniformMatrix4fv+ , glUniformMatrix4x2fv+ , glUniformMatrix4x3fv+ , gl_ACTIVE_UNIFORMS+ , gl_ACTIVE_UNIFORM_MAX_LENGTH++ -- uniform types (constant value types)+ , gl_BOOL+ , gl_BOOL_VEC2+ , gl_BOOL_VEC3+ , gl_BOOL_VEC4+ , gl_FLOAT+ , gl_FLOAT_MAT2+ , gl_FLOAT_MAT2x3+ , gl_FLOAT_MAT2x4+ , gl_FLOAT_MAT3+ , gl_FLOAT_MAT3x2+ , gl_FLOAT_MAT3x4+ , gl_FLOAT_MAT4+ , gl_FLOAT_MAT4x2+ , gl_FLOAT_MAT4x3+ , gl_FLOAT_VEC2+ , gl_FLOAT_VEC3+ , gl_FLOAT_VEC4+ , gl_INT+ , gl_INT_SAMPLER_1D+ , gl_INT_SAMPLER_1D_ARRAY+ , gl_INT_SAMPLER_2D+ , gl_INT_SAMPLER_2D_ARRAY+ , gl_INT_SAMPLER_2D_MULTISAMPLE+ , gl_INT_SAMPLER_2D_MULTISAMPLE_ARRAY+ , gl_INT_SAMPLER_2D_RECT+ , gl_INT_SAMPLER_3D+ , gl_INT_SAMPLER_BUFFER+ , gl_INT_SAMPLER_CUBE+ , gl_INT_VEC2+ , gl_INT_VEC3+ , gl_INT_VEC4+ , gl_SAMPLER_1D+ , gl_SAMPLER_1D_ARRAY+ , gl_SAMPLER_1D_ARRAY_SHADOW+ , gl_SAMPLER_1D_SHADOW+ , gl_SAMPLER_2D+ , gl_SAMPLER_2D_ARRAY+ , gl_SAMPLER_2D_ARRAY_SHADOW+ , gl_SAMPLER_2D_MULTISAMPLE+ , gl_SAMPLER_2D_MULTISAMPLE_ARRAY+ , gl_SAMPLER_2D_RECT+ , gl_SAMPLER_2D_RECT_SHADOW+ , gl_SAMPLER_2D_SHADOW+ , gl_SAMPLER_3D+ , gl_SAMPLER_BUFFER+ , gl_SAMPLER_CUBE+ , gl_SAMPLER_CUBE_SHADOW+ , gl_UNSIGNED_INT+ , gl_UNSIGNED_INT_SAMPLER_1D+ , gl_UNSIGNED_INT_SAMPLER_1D_ARRAY+ , gl_UNSIGNED_INT_SAMPLER_2D+ , gl_UNSIGNED_INT_SAMPLER_2D_ARRAY+ , gl_UNSIGNED_INT_SAMPLER_2D_MULTISAMPLE+ , gl_UNSIGNED_INT_SAMPLER_2D_MULTISAMPLE_ARRAY+ , gl_UNSIGNED_INT_SAMPLER_2D_RECT+ , gl_UNSIGNED_INT_SAMPLER_3D+ , gl_UNSIGNED_INT_SAMPLER_BUFFER+ , gl_UNSIGNED_INT_SAMPLER_CUBE+ , gl_UNSIGNED_INT_VEC2+ , gl_UNSIGNED_INT_VEC3+ , gl_UNSIGNED_INT_VEC4++ -- CONTEXT PARAMETER realted+ -- depth and stencil operation+ , gl_ALWAYS+ , gl_EQUAL+ , gl_GEQUAL+ , gl_GREATER+ , gl_LEQUAL+ , gl_LESS+ , gl_NEVER+ , gl_NOTEQUAL++ -- blending function+ , gl_FUNC_ADD+ , gl_FUNC_REVERSE_SUBTRACT+ , gl_FUNC_SUBTRACT+ , gl_MAX+ , gl_MIN++ -- blending+ , gl_CONSTANT_ALPHA+ , gl_CONSTANT_COLOR+ , gl_DST_ALPHA+ , gl_DST_COLOR+ , gl_ONE+ , gl_ONE_MINUS_CONSTANT_ALPHA+ , gl_ONE_MINUS_CONSTANT_COLOR+ , gl_ONE_MINUS_DST_ALPHA+ , gl_ONE_MINUS_DST_COLOR+ , gl_ONE_MINUS_SRC_ALPHA+ , gl_ONE_MINUS_SRC_COLOR+ , gl_SRC_ALPHA+ , gl_SRC_ALPHA_SATURATE+ , gl_SRC_COLOR+ , gl_ZERO++ -- logic operation+ , gl_AND+ , gl_AND_INVERTED+ , gl_AND_REVERSE+ , gl_CLEAR+ , gl_COPY+ , gl_COPY_INVERTED+ , gl_EQUIV+ , gl_INVERT+ , gl_NAND+ , gl_NOOP+ , gl_NOR+ , gl_OR+ , gl_OR_INVERTED+ , gl_OR_REVERSE+ , gl_SET+ , gl_XOR+ )++import LambdaCube.Core.Type+import LambdaCube.Core.DeBruijn+import LambdaCube.GL.Type++setSampler :: GLint -> Int32 -> IO ()+setSampler i v = glUniform1i i $ fromIntegral v++z2 = V2 0 0 :: V2F+z3 = V3 0 0 0 :: V3F+z4 = V4 0 0 0 0 :: V4F++-- uniform functions+queryUniforms :: GLuint -> IO (Trie GLint, Trie InputType)+queryUniforms po = do+ ul <- getNameTypeSize po glGetActiveUniform glGetUniformLocation gl_ACTIVE_UNIFORMS gl_ACTIVE_UNIFORM_MAX_LENGTH+ let uNames = [n | (n,_,_,_) <- ul]+ uTypes = [fromGLType (e,s) | (_,_,e,s) <- ul]+ uLocation = [i | (_,i,_,_) <- ul]+ return $! (T.fromList $! zip uNames uLocation, T.fromList $! zip uNames uTypes)++mkUniformSetter :: RenderState -> InputType -> IO (GLint -> IO (), InputSetter, InputGetter)+mkUniformSetter _ Bool = do {t <- newIORef False; return $! (\i -> readIORef t >>= setUBool i, SBool $! Setter $ writeIORef t, SBool $ Getter $ readIORef t)}+mkUniformSetter _ V2B = do {t <- newIORef (V2 False False); return $! (\i -> readIORef t >>= setUV2B i, SV2B $! Setter $ writeIORef t, SV2B $ Getter $ readIORef t)}+mkUniformSetter _ V3B = do {t <- newIORef (V3 False False False); return $! (\i -> readIORef t >>= setUV3B i, SV3B $! Setter $ writeIORef t, SV3B $ Getter $ readIORef t)}+mkUniformSetter _ V4B = do {t <- newIORef (V4 False False False False); return $! (\i -> readIORef t >>= setUV4B i, SV4B $! Setter $ writeIORef t, SV4B $ Getter $ readIORef t)}+mkUniformSetter _ Word = do {t <- newIORef 0; return $! (\i -> readIORef t >>= setUWord i, SWord $! Setter $ writeIORef t, SWord $ Getter $ readIORef t)}+mkUniformSetter _ V2U = do {t <- newIORef (V2 0 0); return $! (\i -> readIORef t >>= setUV2U i, SV2U $! Setter $ writeIORef t, SV2U $ Getter $ readIORef t)}+mkUniformSetter _ V3U = do {t <- newIORef (V3 0 0 0); return $! (\i -> readIORef t >>= setUV3U i, SV3U $! Setter $ writeIORef t, SV3U $ Getter $ readIORef t)}+mkUniformSetter _ V4U = do {t <- newIORef (V4 0 0 0 0); return $! (\i -> readIORef t >>= setUV4U i, SV4U $! Setter $ writeIORef t, SV4U $ Getter $ readIORef t)}+mkUniformSetter _ Int = do {t <- newIORef 0; return $! (\i -> readIORef t >>= setUInt i, SInt $! Setter $ writeIORef t, SInt $ Getter $ readIORef t)}+mkUniformSetter _ V2I = do {t <- newIORef (V2 0 0); return $! (\i -> readIORef t >>= setUV2I i, SV2I $! Setter $ writeIORef t, SV2I $ Getter $ readIORef t)}+mkUniformSetter _ V3I = do {t <- newIORef (V3 0 0 0); return $! (\i -> readIORef t >>= setUV3I i, SV3I $! Setter $ writeIORef t, SV3I $ Getter $ readIORef t)}+mkUniformSetter _ V4I = do {t <- newIORef (V4 0 0 0 0); return $! (\i -> readIORef t >>= setUV4I i, SV4I $! Setter $ writeIORef t, SV4I $ Getter $ readIORef t)}+mkUniformSetter _ Float = do {t <- newIORef 0; return $! (\i -> readIORef t >>= setUFloat i, SFloat $! Setter $ writeIORef t, SFloat $ Getter $ readIORef t)}+mkUniformSetter _ V2F = do {t <- newIORef (V2 0 0); return $! (\i -> readIORef t >>= setUV2F i, SV2F $! Setter $ writeIORef t, SV2F $ Getter $ readIORef t)}+mkUniformSetter _ V3F = do {t <- newIORef (V3 0 0 0); return $! (\i -> readIORef t >>= setUV3F i, SV3F $! Setter $ writeIORef t, SV3F $ Getter $ readIORef t)}+mkUniformSetter _ V4F = do {t <- newIORef (V4 0 0 0 0); return $! (\i -> readIORef t >>= setUV4F i, SV4F $! Setter $ writeIORef t, SV4F $ Getter $ readIORef t)}+mkUniformSetter _ M22F = do {t <- newIORef (V2 z2 z2); return $! (\i -> readIORef t >>= setUM22F i, SM22F $! Setter $ writeIORef t, SM22F $ Getter $ readIORef t)}+mkUniformSetter _ M23F = do {t <- newIORef (V3 z2 z2 z2); return $! (\i -> readIORef t >>= setUM23F i, SM23F $! Setter $ writeIORef t, SM23F $ Getter $ readIORef t)}+mkUniformSetter _ M24F = do {t <- newIORef (V4 z2 z2 z2 z2); return $! (\i -> readIORef t >>= setUM24F i, SM24F $! Setter $ writeIORef t, SM24F $ Getter $ readIORef t)}+mkUniformSetter _ M32F = do {t <- newIORef (V2 z3 z3); return $! (\i -> readIORef t >>= setUM32F i, SM32F $! Setter $ writeIORef t, SM32F $ Getter $ readIORef t)}+mkUniformSetter _ M33F = do {t <- newIORef (V3 z3 z3 z3); return $! (\i -> readIORef t >>= setUM33F i, SM33F $! Setter $ writeIORef t, SM33F $ Getter $ readIORef t)}+mkUniformSetter _ M34F = do {t <- newIORef (V4 z3 z3 z3 z3); return $! (\i -> readIORef t >>= setUM34F i, SM34F $! Setter $ writeIORef t, SM34F $ Getter $ readIORef t)}+mkUniformSetter _ M42F = do {t <- newIORef (V2 z4 z4); return $! (\i -> readIORef t >>= setUM42F i, SM42F $! Setter $ writeIORef t, SM42F $ Getter $ readIORef t)}+mkUniformSetter _ M43F = do {t <- newIORef (V3 z4 z4 z4); return $! (\i -> readIORef t >>= setUM43F i, SM43F $! Setter $ writeIORef t, SM43F $ Getter $ readIORef t)}+mkUniformSetter _ M44F = do {t <- newIORef (V4 z4 z4 z4 z4); return $! (\i -> readIORef t >>= setUM44F i, SM44F $! Setter $ writeIORef t, SM44F $ Getter $ readIORef t)}+mkUniformSetter rendState FTexture2D = do+ let texUnitState = textureUnitState rendState+ t <- newIORef (TextureData 0)+ return $! (\i -> readIORef t >>= setTextureData texUnitState i, SFTexture2D $! Setter $ writeIORef t, SFTexture2D $ Getter $ readIORef t)++-- FIXME: implement properly+setTextureData :: IOVector Int -> GLint -> TextureData -> IO ()+setTextureData texUnitState texUnitIdx (TextureData texObj) = do+ let texUnitIdx' = fromIntegral texUnitIdx+ texObj' = fromIntegral texObj+ curTexObj <- MV.read texUnitState texUnitIdx'+ when (curTexObj /= texObj') $ do+ MV.write texUnitState texUnitIdx' texObj'+ glActiveTexture $ gl_TEXTURE0 + fromIntegral texUnitIdx+ glBindTexture gl_TEXTURE_2D texObj+ --putStrLn (" -- uniform setup - Texture bind (TexUnit " ++ show (texUnitIdx,texObj) ++ " TexObj)")++b2w :: Bool -> GLuint+b2w True = 1+b2w False = 0++setUBool :: GLint -> Bool -> IO ()+setUV2B :: GLint -> V2B -> IO ()+setUV3B :: GLint -> V3B -> IO ()+setUV4B :: GLint -> V4B -> IO ()+setUBool i v = with (b2w v) $! \p -> glUniform1uiv i 1 p+setUV2B i (V2 x y) = with (V2 (b2w x) (b2w y)) $! \p -> glUniform2uiv i 1 $! castPtr p+setUV3B i (V3 x y z) = with (V3 (b2w x) (b2w y) (b2w z)) $! \p -> glUniform3uiv i 1 $! castPtr p+setUV4B i (V4 x y z w) = with (V4 (b2w x) (b2w y) (b2w z) (b2w w)) $! \p -> glUniform4uiv i 1 $! castPtr p++setUWord :: GLint -> Word32 -> IO ()+setUV2U :: GLint -> V2U -> IO ()+setUV3U :: GLint -> V3U -> IO ()+setUV4U :: GLint -> V4U -> IO ()+setUWord i v = with v $! \p -> glUniform1uiv i 1 $! castPtr p+setUV2U i v = with v $! \p -> glUniform2uiv i 1 $! castPtr p+setUV3U i v = with v $! \p -> glUniform3uiv i 1 $! castPtr p+setUV4U i v = with v $! \p -> glUniform4uiv i 1 $! castPtr p++setUInt :: GLint -> Int32 -> IO ()+setUV2I :: GLint -> V2I -> IO ()+setUV3I :: GLint -> V3I -> IO ()+setUV4I :: GLint -> V4I -> IO ()+setUInt i v = with v $! \p -> glUniform1iv i 1 $! castPtr p+setUV2I i v = with v $! \p -> glUniform2iv i 1 $! castPtr p+setUV3I i v = with v $! \p -> glUniform3iv i 1 $! castPtr p+setUV4I i v = with v $! \p -> glUniform4iv i 1 $! castPtr p++setUFloat :: GLint -> Float -> IO ()+setUV2F :: GLint -> V2F -> IO ()+setUV3F :: GLint -> V3F -> IO ()+setUV4F :: GLint -> V4F -> IO ()+setUFloat i v = with v $! \p -> glUniform1fv i 1 $! castPtr p+setUV2F i v = with v $! \p -> glUniform2fv i 1 $! castPtr p+setUV3F i v = with v $! \p -> glUniform3fv i 1 $! castPtr p+setUV4F i v = with v $! \p -> glUniform4fv i 1 $! castPtr p++setUM22F :: GLint -> M22F -> IO ()+setUM23F :: GLint -> M23F -> IO ()+setUM24F :: GLint -> M24F -> IO ()+setUM22F i v = with v $! \p -> glUniformMatrix2fv i 1 (fromIntegral gl_FALSE) $! castPtr p+setUM23F i v = with v $! \p -> glUniformMatrix2x3fv i 1 (fromIntegral gl_FALSE) $! castPtr p+setUM24F i v = with v $! \p -> glUniformMatrix2x4fv i 1 (fromIntegral gl_FALSE) $! castPtr p++setUM32F :: GLint -> M32F -> IO ()+setUM33F :: GLint -> M33F -> IO ()+setUM34F :: GLint -> M34F -> IO ()+setUM32F i v = with v $! \p -> glUniformMatrix3x2fv i 1 (fromIntegral gl_FALSE) $! castPtr p+setUM33F i v = with v $! \p -> glUniformMatrix3fv i 1 (fromIntegral gl_FALSE) $! castPtr p+setUM34F i v = with v $! \p -> glUniformMatrix3x4fv i 1 (fromIntegral gl_FALSE) $! castPtr p++setUM42F :: GLint -> M42F -> IO ()+setUM43F :: GLint -> M43F -> IO ()+setUM44F :: GLint -> M44F -> IO ()+setUM42F i v = with v $! \p -> glUniformMatrix4x2fv i 1 (fromIntegral gl_FALSE) $! castPtr p+setUM43F i v = with v $! \p -> glUniformMatrix4x3fv i 1 (fromIntegral gl_FALSE) $! castPtr p+setUM44F i v = with v $! \p -> glUniformMatrix4fv i 1 (fromIntegral gl_FALSE) $! castPtr p++-- attribute functions+queryStreams :: GLuint -> IO (Trie GLuint, Trie InputType)+queryStreams po = do+ al <- getNameTypeSize po glGetActiveAttrib glGetAttribLocation gl_ACTIVE_ATTRIBUTES gl_ACTIVE_ATTRIBUTE_MAX_LENGTH+ let aNames = [n | (n,_,_,_) <- al]+ aTypes = [fromGLType (e,s) | (_,_,e,s) <- al]+ aLocation = [fromIntegral i | (_,i,_,_) <- al]+ return $! (T.fromList $! zip aNames aLocation, T.fromList $! zip aNames aTypes)++-- should handle constant value and buffer value as well+mkSSetter :: InputType -> GLuint -> StreamSetter+mkSSetter Word i (ConstWord v) = setAWord i v+mkSSetter V2U i (ConstV2U v) = setAV2U i v+mkSSetter V3U i (ConstV3U v) = setAV3U i v+mkSSetter V4U i (ConstV4U v) = setAV4U i v+mkSSetter Word i (Stream TWord b a s l) = setBufInteger 1 i b a s+mkSSetter V2U i (Stream TV2U b a s l) = setBufInteger 2 i b a s+mkSSetter V3U i (Stream TV3U b a s l) = setBufInteger 3 i b a s+mkSSetter V4U i (Stream TV4U b a s l) = setBufInteger 4 i b a s+ +mkSSetter Int i (ConstInt v) = setAInt i v+mkSSetter V2I i (ConstV2I v) = setAV2I i v+mkSSetter V3I i (ConstV3I v) = setAV3I i v+mkSSetter V4I i (ConstV4I v) = setAV4I i v+mkSSetter Int i (Stream TInt b a s l) = setBufInteger 1 i b a s+mkSSetter V2I i (Stream TV2I b a s l) = setBufInteger 2 i b a s+mkSSetter V3I i (Stream TV3I b a s l) = setBufInteger 3 i b a s+mkSSetter V4I i (Stream TV4I b a s l) = setBufInteger 4 i b a s+ +mkSSetter Float i (ConstFloat v) = setAFloat i v+mkSSetter V2F i (ConstV2F v) = setAV2F i v+mkSSetter V3F i (ConstV3F v) = setAV3F i v+mkSSetter V4F i (ConstV4F v) = setAV4F i v+mkSSetter Float i (Stream TFloat b a s l) = setBufFloat 1 i b a s+mkSSetter V2F i (Stream TV2F b a s l) = setBufFloat 2 i b a s+mkSSetter V3F i (Stream TV3F b a s l) = setBufFloat 3 i b a s+mkSSetter V4F i (Stream TV4F b a s l) = setBufFloat 4 i b a s+ +mkSSetter M22F i (ConstM22F v) = setAM22F i v+mkSSetter M23F i (ConstM23F v) = setAM23F i v+mkSSetter M24F i (ConstM24F v) = setAM24F i v+mkSSetter M22F i (Stream TM22F b a s l) = setBufFloat 4 i b a s+mkSSetter M23F i (Stream TM23F b a s l) = setBufFloat 6 i b a s+mkSSetter M24F i (Stream TM24F b a s l) = setBufFloat 8 i b a s+ +mkSSetter M32F i (ConstM32F v) = setAM32F i v+mkSSetter M33F i (ConstM33F v) = setAM33F i v+mkSSetter M34F i (ConstM34F v) = setAM34F i v+mkSSetter M32F i (Stream TM32F b a s l) = setBufFloat 6 i b a s+mkSSetter M33F i (Stream TM33F b a s l) = setBufFloat 9 i b a s+mkSSetter M34F i (Stream TM34F b a s l) = setBufFloat 12 i b a s+ +mkSSetter M42F i (ConstM42F v) = setAM42F i v+mkSSetter M43F i (ConstM43F v) = setAM43F i v+mkSSetter M44F i (ConstM44F v) = setAM44F i v+mkSSetter M42F i (Stream TM42F b a s l) = setBufFloat 8 i b a s+mkSSetter M43F i (Stream TM43F b a s l) = setBufFloat 12 i b a s+mkSSetter M44F i (Stream TM44F b a s l) = setBufFloat 16 i b a s+mkSSetter _ _ _ = fail "mkSSetter type mismatch!"++arrayTypeToGLType :: ArrayType -> GLenum+arrayTypeToGLType ArrWord8 = gl_UNSIGNED_BYTE+arrayTypeToGLType ArrWord16 = gl_UNSIGNED_SHORT+arrayTypeToGLType ArrWord32 = gl_UNSIGNED_INT+arrayTypeToGLType ArrInt8 = gl_BYTE+arrayTypeToGLType ArrInt16 = gl_SHORT+arrayTypeToGLType ArrInt32 = gl_INT+arrayTypeToGLType ArrFloat = gl_FLOAT+arrayTypeToGLType ArrHalf = gl_HALF_FLOAT++setBufFloat :: GLint -> GLuint -> Buffer -> Int -> Int -> IO ()+setBufFloat compCnt i (Buffer arrs bo) arrIdx start = do+ let ArrayDesc arrType arrLen arrOffs arrSize = arrs V.! arrIdx+ glType = arrayTypeToGLType arrType+ ptr = intPtrToPtr $! fromIntegral (arrOffs + start * fromIntegral compCnt * sizeOfArrayType arrType)+ glBindBuffer gl_ARRAY_BUFFER bo+ glEnableVertexAttribArray i+ glVertexAttribPointer i compCnt glType (fromIntegral gl_FALSE) 0 ptr++setBufInteger :: GLint -> GLuint -> Buffer -> Int -> Int -> IO ()+--setBufInteger = setBufFloat -- FIXME: GL 2.1 does not have glVertexAttribIPointer+setBufInteger compCnt i (Buffer arrs bo) arrIdx start = do+ let ArrayDesc arrType arrLen arrOffs arrSize = arrs V.! arrIdx+ glType = arrayTypeToGLType arrType+ ptr = intPtrToPtr $! fromIntegral (arrOffs + start * fromIntegral compCnt * sizeOfArrayType arrType)+ glBindBuffer gl_ARRAY_BUFFER bo+ glEnableVertexAttribArray i+ -- GL 3.X version+ glVertexAttribIPointer i compCnt glType 0 ptr++setAWord :: GLuint -> Word32 -> IO ()+setAV2U :: GLuint -> V2U -> IO ()+setAV3U :: GLuint -> V3U -> IO ()+setAV4U :: GLuint -> V4U -> IO ()+setAWord i v = glDisableVertexAttribArray i >> (with v $! \p -> glVertexAttribI1uiv i $! castPtr p)+setAV2U i v = glDisableVertexAttribArray i >> (with v $! \p -> glVertexAttribI2uiv i $! castPtr p)+setAV3U i v = glDisableVertexAttribArray i >> (with v $! \p -> glVertexAttribI3uiv i $! castPtr p)+setAV4U i v = glDisableVertexAttribArray i >> (with v $! \p -> glVertexAttribI4uiv i $! castPtr p)++setAInt :: GLuint -> Int32 -> IO ()+setAV2I :: GLuint -> V2I -> IO ()+setAV3I :: GLuint -> V3I -> IO ()+setAV4I :: GLuint -> V4I -> IO ()+setAInt i v = glDisableVertexAttribArray i >> (with v $! \p -> glVertexAttribI1iv i $! castPtr p)+setAV2I i v = glDisableVertexAttribArray i >> (with v $! \p -> glVertexAttribI2iv i $! castPtr p)+setAV3I i v = glDisableVertexAttribArray i >> (with v $! \p -> glVertexAttribI3iv i $! castPtr p)+setAV4I i v = glDisableVertexAttribArray i >> (with v $! \p -> glVertexAttribI4iv i $! castPtr p)++setAFloat :: GLuint -> Float -> IO ()+setAV2F :: GLuint -> V2F -> IO ()+setAV3F :: GLuint -> V3F -> IO ()+setAV4F :: GLuint -> V4F -> IO ()+setAFloat i v = glDisableVertexAttribArray i >> (with v $! \p -> glVertexAttrib1fv i $! castPtr p)+setAV2F i v = glDisableVertexAttribArray i >> (with v $! \p -> glVertexAttrib2fv i $! castPtr p)+setAV3F i v = glDisableVertexAttribArray i >> (with v $! \p -> glVertexAttrib3fv i $! castPtr p)+setAV4F i v = glDisableVertexAttribArray i >> (with v $! \p -> glVertexAttrib4fv i $! castPtr p)++setAM22F :: GLuint -> M22F -> IO ()+setAM23F :: GLuint -> M23F -> IO ()+setAM24F :: GLuint -> M24F -> IO ()+setAM22F i (V2 x y) = setAV2F i x >> setAV2F (i+1) y+setAM23F i (V3 x y z) = setAV2F i x >> setAV2F (i+1) y >> setAV2F (i+2) z+setAM24F i (V4 x y z w) = setAV2F i x >> setAV2F (i+1) y >> setAV2F (i+2) z >> setAV2F (i+3) w++setAM32F :: GLuint -> M32F -> IO ()+setAM33F :: GLuint -> M33F -> IO ()+setAM34F :: GLuint -> M34F -> IO ()+setAM32F i (V2 x y) = setAV3F i x >> setAV3F (i+1) y+setAM33F i (V3 x y z) = setAV3F i x >> setAV3F (i+1) y >> setAV3F (i+2) z+setAM34F i (V4 x y z w) = setAV3F i x >> setAV3F (i+1) y >> setAV3F (i+2) z >> setAV3F (i+3) w++setAM42F :: GLuint -> M42F -> IO ()+setAM43F :: GLuint -> M43F -> IO ()+setAM44F :: GLuint -> M44F -> IO ()+setAM42F i (V2 x y) = setAV4F i x >> setAV4F (i+1) y+setAM43F i (V3 x y z) = setAV4F i x >> setAV4F (i+1) y >> setAV4F (i+2) z+setAM44F i (V4 x y z w) = setAV4F i x >> setAV4F (i+1) y >> setAV4F (i+2) z >> setAV4F (i+3) w++-- result list: [(name string,location,gl type,component count)]+getNameTypeSize :: GLuint -> (GLuint -> GLuint -> GLsizei -> Ptr GLsizei -> Ptr GLint -> Ptr GLenum -> Ptr GLchar -> IO ())+ -> (GLuint -> Ptr GLchar -> IO GLint) -> GLenum -> GLenum -> IO [(ByteString,GLint,GLenum,GLint)]+getNameTypeSize o f g enum enumLen = do+ nameLen <- glGetProgramiv1 enumLen o+ allocaArray (fromIntegral nameLen) $! \namep -> alloca $! \sizep -> alloca $! \typep -> do+ n <- glGetProgramiv1 enum o+ forM [0..n-1] $! \i -> f o (fromIntegral i) (fromIntegral nameLen) nullPtr sizep typep namep >>+ (,,,) <$> SB.packCString (castPtr namep) <*> g o namep <*> peek typep <*> peek sizep+{-+filterSamplers :: [(ByteString,GLint,GLenum,GLint)] -> ([(ByteString,GLint,GLenum,GLint)],[(ByteString,GLint,GLenum,GLint)])+filterSamplers l = partition (\(_,_,e,_) -> elem e samplerTypes) l+ where+ samplerTypes = [gl_SAMPLER_2D]+-}+fromGLType :: (GLenum,GLint) -> InputType+fromGLType (t,1)+ | t == gl_BOOL = Bool+ | t == gl_BOOL_VEC2 = V2B+ | t == gl_BOOL_VEC3 = V3B+ | t == gl_BOOL_VEC4 = V4B+ | t == gl_UNSIGNED_INT = Word+ | t == gl_UNSIGNED_INT_VEC2 = V2U+ | t == gl_UNSIGNED_INT_VEC3 = V3U+ | t == gl_UNSIGNED_INT_VEC4 = V4U+ | t == gl_INT = Int+ | t == gl_INT_VEC2 = V2I+ | t == gl_INT_VEC3 = V3I+ | t == gl_INT_VEC4 = V4I+ | t == gl_FLOAT = Float+ | t == gl_FLOAT_VEC2 = V2F+ | t == gl_FLOAT_VEC3 = V3F+ | t == gl_FLOAT_VEC4 = V4F+ | t == gl_FLOAT_MAT2 = M22F+ | t == gl_FLOAT_MAT2x3 = M23F+ | t == gl_FLOAT_MAT2x4 = M24F+ | t == gl_FLOAT_MAT3x2 = M32F+ | t == gl_FLOAT_MAT3 = M33F+ | t == gl_FLOAT_MAT3x4 = M34F+ | t == gl_FLOAT_MAT4x2 = M42F+ | t == gl_FLOAT_MAT4x3 = M43F+ | t == gl_FLOAT_MAT4 = M44F+ | t == gl_SAMPLER_1D_ARRAY_SHADOW = STexture1DArray+ | t == gl_SAMPLER_1D_SHADOW = STexture1D+ | t == gl_SAMPLER_2D_ARRAY_SHADOW = STexture2DArray+ | t == gl_SAMPLER_2D_RECT_SHADOW = STexture2DRect+ | t == gl_SAMPLER_2D_SHADOW = STexture2D+ | t == gl_SAMPLER_CUBE_SHADOW = STextureCube+ | t == gl_INT_SAMPLER_1D = ITexture1D+ | t == gl_INT_SAMPLER_1D_ARRAY = ITexture1DArray+ | t == gl_INT_SAMPLER_2D = ITexture2D+ | t == gl_INT_SAMPLER_2D_ARRAY = ITexture2DArray+ | t == gl_INT_SAMPLER_2D_MULTISAMPLE = ITexture2DMS+ | t == gl_INT_SAMPLER_2D_MULTISAMPLE_ARRAY = ITexture2DMSArray+ | t == gl_INT_SAMPLER_2D_RECT = ITexture2DRect+ | t == gl_INT_SAMPLER_3D = ITexture3D+ | t == gl_INT_SAMPLER_BUFFER = ITextureBuffer+ | t == gl_INT_SAMPLER_CUBE = ITextureCube+ | t == gl_SAMPLER_1D = FTexture1D+ | t == gl_SAMPLER_1D_ARRAY = FTexture1DArray+ | t == gl_SAMPLER_2D = FTexture2D+ | t == gl_SAMPLER_2D_ARRAY = FTexture2DArray+ | t == gl_SAMPLER_2D_MULTISAMPLE = FTexture2DMS+ | t == gl_SAMPLER_2D_MULTISAMPLE_ARRAY = FTexture2DMSArray+ | t == gl_SAMPLER_2D_RECT = FTexture2DRect+ | t == gl_SAMPLER_3D = FTexture3D+ | t == gl_SAMPLER_BUFFER = FTextureBuffer+ | t == gl_SAMPLER_CUBE = FTextureCube+ | t == gl_UNSIGNED_INT_SAMPLER_1D = UTexture1D+ | t == gl_UNSIGNED_INT_SAMPLER_1D_ARRAY = UTexture1DArray+ | t == gl_UNSIGNED_INT_SAMPLER_2D = UTexture2D+ | t == gl_UNSIGNED_INT_SAMPLER_2D_ARRAY = UTexture2DArray+ | t == gl_UNSIGNED_INT_SAMPLER_2D_MULTISAMPLE = UTexture2DMS+ | t == gl_UNSIGNED_INT_SAMPLER_2D_MULTISAMPLE_ARRAY = UTexture2DMSArray+ | t == gl_UNSIGNED_INT_SAMPLER_2D_RECT = UTexture2DRect+ | t == gl_UNSIGNED_INT_SAMPLER_3D = UTexture3D+ | t == gl_UNSIGNED_INT_SAMPLER_BUFFER = UTextureBuffer+ | t == gl_UNSIGNED_INT_SAMPLER_CUBE = UTextureCube+ | otherwise = error "Failed fromGLType"+fromGLUniformType _ = error "Failed fromGLType"++printShaderLog :: GLuint -> IO ()+printShaderLog o = do+ i <- glGetShaderiv1 gl_INFO_LOG_LENGTH o+ when (i > 0) $+ alloca $ \sizePtr -> allocaArray (fromIntegral i) $! \ps -> do+ glGetShaderInfoLog o (fromIntegral i) sizePtr ps+ size <- peek sizePtr+ log <- SB.packCStringLen (castPtr ps, fromIntegral size)+ SB.putStrLn log++glGetShaderiv1 :: GLenum -> GLuint -> IO GLint+glGetShaderiv1 pname o = alloca $! \pi -> glGetShaderiv o pname pi >> peek pi++glGetProgramiv1 :: GLenum -> GLuint -> IO GLint+glGetProgramiv1 pname o = alloca $! \pi -> glGetProgramiv o pname pi >> peek pi++printProgramLog :: GLuint -> IO ()+printProgramLog o = do+ i <- glGetProgramiv1 gl_INFO_LOG_LENGTH o+ when (i > 0) $+ alloca $ \sizePtr -> allocaArray (fromIntegral i) $! \ps -> do+ glGetProgramInfoLog o (fromIntegral i) sizePtr ps+ size <- peek sizePtr+ log <- SB.packCStringLen (castPtr ps, fromIntegral size)+ SB.putStrLn log++compileShader :: GLuint -> [ByteString] -> IO ()+compileShader o srcl = withMany SB.useAsCString srcl $! \l -> withArray l $! \p -> do+ glShaderSource o (fromIntegral $! length srcl) (castPtr p) nullPtr+ glCompileShader o+ printShaderLog o+ status <- glGetShaderiv1 gl_COMPILE_STATUS o+ when (status /= fromIntegral gl_TRUE) $ fail "compileShader failed!"++checkGL :: IO ByteString+checkGL = do+ let f e | e == gl_INVALID_ENUM = "INVALID_ENUM"+ | e == gl_INVALID_VALUE = "INVALID_VALUE"+ | e == gl_INVALID_OPERATION = "INVALID_OPERATION"+ | e == gl_INVALID_FRAMEBUFFER_OPERATION = "INVALID_FRAMEBUFFER_OPERATION"+ | e == gl_OUT_OF_MEMORY = "OUT_OF_MEMORY"+ | e == gl_NO_ERROR = "OK"+ | otherwise = "Unknown error"+ e <- glGetError+ return $ f e++streamToInputType :: Stream Buffer -> InputType+streamToInputType (ConstWord _) = Word+streamToInputType (ConstV2U _) = V2U+streamToInputType (ConstV3U _) = V3U+streamToInputType (ConstV4U _) = V4U+streamToInputType (ConstInt _) = Int+streamToInputType (ConstV2I _) = V2I+streamToInputType (ConstV3I _) = V3I+streamToInputType (ConstV4I _) = V4I+streamToInputType (ConstFloat _) = Float+streamToInputType (ConstV2F _) = V2F+streamToInputType (ConstV3F _) = V3F+streamToInputType (ConstV4F _) = V4F+streamToInputType (ConstM22F _) = M22F+streamToInputType (ConstM23F _) = M23F+streamToInputType (ConstM24F _) = M24F+streamToInputType (ConstM32F _) = M32F+streamToInputType (ConstM33F _) = M33F+streamToInputType (ConstM34F _) = M34F+streamToInputType (ConstM42F _) = M42F+streamToInputType (ConstM43F _) = M43F+streamToInputType (ConstM44F _) = M44F+streamToInputType (Stream t (Buffer a _) i _ _)+ | 0 <= i && i < V.length a &&+ if elem t integralTypes then elem at integralArrTypes else True+ = fromStreamType t+ | otherwise = throw $ userError "streamToInputType failed"+ where+ at = arrType $! (a V.! i)+ integralTypes = [TWord, TV2U, TV3U, TV4U, TInt, TV2I, TV3I, TV4I]+ integralArrTypes = [ArrWord8, ArrWord16, ArrWord32, ArrInt8, ArrInt16, ArrInt32]++comparisonFunctionToGLType :: ComparisonFunction -> GLenum+comparisonFunctionToGLType Always = gl_ALWAYS+comparisonFunctionToGLType Equal = gl_EQUAL+comparisonFunctionToGLType Gequal = gl_GEQUAL+comparisonFunctionToGLType Greater = gl_GREATER+comparisonFunctionToGLType Lequal = gl_LEQUAL+comparisonFunctionToGLType Less = gl_LESS+comparisonFunctionToGLType Never = gl_NEVER+comparisonFunctionToGLType Notequal = gl_NOTEQUAL++logicOperationToGLType :: LogicOperation -> GLenum+logicOperationToGLType And = gl_AND+logicOperationToGLType AndInverted = gl_AND_INVERTED+logicOperationToGLType AndReverse = gl_AND_REVERSE+logicOperationToGLType Clear = gl_CLEAR+logicOperationToGLType Copy = gl_COPY+logicOperationToGLType CopyInverted = gl_COPY_INVERTED+logicOperationToGLType Equiv = gl_EQUIV+logicOperationToGLType Invert = gl_INVERT+logicOperationToGLType Nand = gl_NAND+logicOperationToGLType Noop = gl_NOOP+logicOperationToGLType Nor = gl_NOR+logicOperationToGLType Or = gl_OR+logicOperationToGLType OrInverted = gl_OR_INVERTED+logicOperationToGLType OrReverse = gl_OR_REVERSE+logicOperationToGLType Set = gl_SET+logicOperationToGLType Xor = gl_XOR++blendEquationToGLType :: BlendEquation -> GLenum+blendEquationToGLType FuncAdd = gl_FUNC_ADD+blendEquationToGLType FuncReverseSubtract = gl_FUNC_REVERSE_SUBTRACT+blendEquationToGLType FuncSubtract = gl_FUNC_SUBTRACT+blendEquationToGLType Max = gl_MAX+blendEquationToGLType Min = gl_MIN++blendingFactorToGLType :: BlendingFactor -> GLenum+blendingFactorToGLType ConstantAlpha = gl_CONSTANT_ALPHA+blendingFactorToGLType ConstantColor = gl_CONSTANT_COLOR+blendingFactorToGLType DstAlpha = gl_DST_ALPHA+blendingFactorToGLType DstColor = gl_DST_COLOR+blendingFactorToGLType One = gl_ONE+blendingFactorToGLType OneMinusConstantAlpha = gl_ONE_MINUS_CONSTANT_ALPHA+blendingFactorToGLType OneMinusConstantColor = gl_ONE_MINUS_CONSTANT_COLOR+blendingFactorToGLType OneMinusDstAlpha = gl_ONE_MINUS_DST_ALPHA+blendingFactorToGLType OneMinusDstColor = gl_ONE_MINUS_DST_COLOR+blendingFactorToGLType OneMinusSrcAlpha = gl_ONE_MINUS_SRC_ALPHA+blendingFactorToGLType OneMinusSrcColor = gl_ONE_MINUS_SRC_COLOR+blendingFactorToGLType SrcAlpha = gl_SRC_ALPHA+blendingFactorToGLType SrcAlphaSaturate = gl_SRC_ALPHA_SATURATE+blendingFactorToGLType SrcColor = gl_SRC_COLOR+blendingFactorToGLType Zero = gl_ZERO++{-+data ColorArity = Red | RG | RGB | RGBA deriving (Show,Eq,Ord)+data TextureDataType+ = FloatT ColorArity+ | IntT ColorArity+ | WordT ColorArity+ | ShadowT+ deriving (Show, Eq, Ord)+-}+textureDataTypeToGLType :: TextureDataType -> GLenum+textureDataTypeToGLType (FloatT Red) = gl_R32F+textureDataTypeToGLType (IntT Red) = gl_R32I+textureDataTypeToGLType (WordT Red) = gl_R32UI+textureDataTypeToGLType (FloatT RG) = gl_RG32F+textureDataTypeToGLType (IntT RG) = gl_RG32I+textureDataTypeToGLType (WordT RG) = gl_RG32UI+textureDataTypeToGLType (FloatT RGB) = gl_RGB32F+textureDataTypeToGLType (IntT RGB) = gl_RGB32I+textureDataTypeToGLType (WordT RGB) = gl_RGB32UI+textureDataTypeToGLType (FloatT RGBA) = gl_RGBA32F+textureDataTypeToGLType (IntT RGBA) = gl_RGBA32I+textureDataTypeToGLType (WordT RGBA) = gl_RGBA32UI+textureDataTypeToGLType a = error $ "FIXME: This texture format is not yet supported " ++ show a++textureDataTypeToGLArityType :: TextureDataType -> GLenum+textureDataTypeToGLArityType (FloatT Red) = gl_RED+textureDataTypeToGLArityType (IntT Red) = gl_RED+textureDataTypeToGLArityType (WordT Red) = gl_RED+textureDataTypeToGLArityType (FloatT RG) = gl_RG+textureDataTypeToGLArityType (IntT RG) = gl_RG+textureDataTypeToGLArityType (WordT RG) = gl_RG+textureDataTypeToGLArityType (FloatT RGB) = gl_RGB+textureDataTypeToGLArityType (IntT RGB) = gl_RGB+textureDataTypeToGLArityType (WordT RGB) = gl_RGB+textureDataTypeToGLArityType (FloatT RGBA) = gl_RGBA+textureDataTypeToGLArityType (IntT RGBA) = gl_RGBA+textureDataTypeToGLArityType (WordT RGBA) = gl_RGBA+textureDataTypeToGLArityType a = error $ "FIXME: This texture format is not yet supported " ++ show a+{-+Texture and renderbuffer color formats (R):+ R11F_G11F_B10F+ R16+ R16F+ R16I+ R16UI+ R32F+ R32I+ R32UI+ R8+ R8I+ R8UI+ RG16+ RG16F+ RG16I+ RG16UI+ RG32F+ RG32I+ RG32UI+ RG8+ RG8I+ RG8UI+ RGB10_A2+ RGB10_A2UI+ RGBA16+ RGBA16F+ RGBA16I+ RGBA16UI+ RGBA32F+ RGBA32I+ RGBA32UI+ RGBA8+ RGBA8I+ RGBA8UI+ SRGB8_ALPHA8+-}++glGetIntegerv1 :: GLenum -> IO GLint+glGetIntegerv1 e = alloca $ \pi -> glGetIntegerv e pi >> peek pi++checkFBO :: IO ByteString+checkFBO = do+ let f e | e == gl_FRAMEBUFFER_UNDEFINED = "FRAMEBUFFER_UNDEFINED"+ | e == gl_FRAMEBUFFER_INCOMPLETE_ATTACHMENT = "FRAMEBUFFER_INCOMPLETE_ATTACHMENT"+ | e == gl_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER = "FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER"+ | e == gl_FRAMEBUFFER_INCOMPLETE_READ_BUFFER = "FRAMEBUFFER_INCOMPLETE_READ_BUFFER"+ | e == gl_FRAMEBUFFER_UNSUPPORTED = "FRAMEBUFFER_UNSUPPORTED"+ | e == gl_FRAMEBUFFER_INCOMPLETE_MULTISAMPLE = "FRAMEBUFFER_INCOMPLETE_MULTISAMPLE"+ | e == gl_FRAMEBUFFER_INCOMPLETE_LAYER_TARGETS = "FRAMEBUFFER_INCOMPLETE_LAYER_TARGETS"+ | e == gl_FRAMEBUFFER_COMPLETE = "FRAMEBUFFER_COMPLETE"+ | otherwise = "Unknown error"+ e <- glCheckFramebufferStatus gl_DRAW_FRAMEBUFFER+ return $ f e++{-+data TextureDataType - gl internal representation+ = FloatT ColorArity+ | IntT ColorArity+ | WordT ColorArity+ | ShadowT+ deriving (Show, Eq, Ord)++data TextureType - gl texture target+ = Texture1D TextureDataType Int+ | Texture2D TextureDataType Int+ | Texture3D TextureDataType+ | TextureCube TextureDataType+ | TextureRect TextureDataType+ | Texture2DMS TextureDataType Int+ | TextureBuffer TextureDataType+ deriving (Show, Eq, Ord)+-}+createGLTextureObject :: DAG -> Exp -> IO GLuint+createGLTextureObject dag (Sampler txFilter txEdgeMode tx) = do+ let Texture txType txSize txMipMap txGPList = toExp dag tx+ wrapMode = case txEdgeMode of+ Repeat -> gl_REPEAT+ MirroredRepeat -> gl_MIRRORED_REPEAT+ ClampToEdge -> gl_CLAMP_TO_EDGE+ ClampToBorder -> gl_CLAMP_TO_BORDER+ filterMode = case txFilter of+ PointFilter -> gl_NEAREST+ LinearFilter -> gl_LINEAR+ to <- alloca $! \pto -> glGenTextures 1 pto >> peek pto+ {-+ void glTexImage1D( GLenum target, GLint level, GLint internalformat, GLsizei width, GLint border, GLenum format, GLenum type, void *data );+ void glTexImage2D( GLenum target, GLint level, GLint internalformat, GLsizei width, GLsizei height, GLint border, GLenum format, GLenum type, void *data );+ void glTexImage3D( GLenum target, GLint level, GLint internalformat, GLsizei width, GLsizei height, GLsizei depth, GLint border, GLenum format, GLenum type, void *data );+ void glTexImage2DMultisample( GLenum target, GLsizei samples, GLint internalformat, GLsizei width, GLsizei height, GLboolean fixedsamplelocations );+ void glTexImage3DMultisample( GLenum target, GLsizei samples, GLint internalformat, GLsizei width, GLsizei height, GLsizei depth, GLboolean fixedsamplelocations );+ -}+ -- FIXME: for now we support only single 2D texture+ case txType of+ {-+ Texture1D dTy n -> return ()+ Texture2D dTy n -> return ()+ Texture3D dTy -> return ()+ TextureCube dTy -> return ()+ TextureRect dTy -> return ()+ Texture2DMS dTy n -> return ()+ TextureBuffer dTy -> return ()+ -}+{-+ let (width,height) = bitmapSize bitmap+ wrapMode = case isClamped of+ True -> gl_CLAMP_TO_EDGE+ False -> gl_REPEAT+ (minFilter,maxLevel) = case isMip of+ False -> (gl_LINEAR,0)+ True -> (gl_LINEAR_MIPMAP_LINEAR, floor $ log (fromIntegral $ max width height) / log 2)+ glTexParameteri gl_TEXTURE_2D gl_TEXTURE_WRAP_S $ fromIntegral wrapMode+ glTexParameteri gl_TEXTURE_2D gl_TEXTURE_WRAP_T $ fromIntegral wrapMode+ glTexParameteri gl_TEXTURE_2D gl_TEXTURE_MIN_FILTER $ fromIntegral minFilter+ glTexParameteri gl_TEXTURE_2D gl_TEXTURE_MAG_FILTER $ fromIntegral gl_LINEAR+ glTexParameteri gl_TEXTURE_2D gl_TEXTURE_BASE_LEVEL 0+ glTexParameteri gl_TEXTURE_2D gl_TEXTURE_MAX_LEVEL $ fromIntegral maxLevel+ withBitmap bitmap $ \(w,h) nchn 0 ptr -> do+ let internalFormat = fromIntegral gl_RGBA8+ dataFormat = fromIntegral $ case nchn of+ 3 -> gl_RGB+ 4 -> gl_RGBA+ _ -> error "unsupported texture format!"+ glTexImage2D gl_TEXTURE_2D 0 internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat gl_UNSIGNED_BYTE $ castPtr ptr+ when isMip $ glGenerateMipmap gl_TEXTURE_2D+-}+ TextureCube dTy -> if txMipMap /= NoMip then error "FIXME: Only NoMip textures are supported yet!" else + if length txGPList /= 1 then error "Invalid texture source specification!" else do+ let internalFormat = fromIntegral $ textureDataTypeToGLType dTy+ dataFormat = fromIntegral $ textureDataTypeToGLArityType dTy+ VV2U (V2 w h) = txSize+ glBindTexture gl_TEXTURE_CUBE_MAP to+ glTexParameteri gl_TEXTURE_CUBE_MAP gl_TEXTURE_WRAP_S $ fromIntegral wrapMode+ glTexParameteri gl_TEXTURE_CUBE_MAP gl_TEXTURE_WRAP_T $ fromIntegral wrapMode+ glTexParameteri gl_TEXTURE_CUBE_MAP gl_TEXTURE_MAG_FILTER $ fromIntegral filterMode+ glTexParameteri gl_TEXTURE_CUBE_MAP gl_TEXTURE_MIN_FILTER $ fromIntegral filterMode+ glTexParameteri gl_TEXTURE_CUBE_MAP gl_TEXTURE_BASE_LEVEL 0+ glTexParameteri gl_TEXTURE_CUBE_MAP gl_TEXTURE_MAX_LEVEL 0+ let l = [ gl_TEXTURE_CUBE_MAP_POSITIVE_X + , gl_TEXTURE_CUBE_MAP_NEGATIVE_X+ , gl_TEXTURE_CUBE_MAP_POSITIVE_Y+ , gl_TEXTURE_CUBE_MAP_NEGATIVE_Y+ , gl_TEXTURE_CUBE_MAP_POSITIVE_Z+ , gl_TEXTURE_CUBE_MAP_NEGATIVE_Z+ ]+ forM_ l $ \t -> glTexImage2D t 0 internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat gl_UNSIGNED_BYTE nullPtr++ -- temporary texture support: 2D NoMip Float/Int/Word Red/RG/RGBA+ Texture2D dTy layerCnt -> if txMipMap /= NoMip then error "FIXME: Only NoMip textures are supported yet!" else + if length txGPList /= 1 then error "Invalid texture source specification!" else do+ let internalFormat = fromIntegral $ textureDataTypeToGLType dTy+ dataFormat = fromIntegral $ textureDataTypeToGLArityType dTy+ VV2U (V2 w h) = txSize+ txTarget = if layerCnt > 1 then gl_TEXTURE_2D_ARRAY else gl_TEXTURE_2D+ glBindTexture txTarget to+ -- temp+ glTexParameteri txTarget gl_TEXTURE_WRAP_S $ fromIntegral wrapMode+ glTexParameteri txTarget gl_TEXTURE_WRAP_T $ fromIntegral wrapMode+ glTexParameteri txTarget gl_TEXTURE_MAG_FILTER $ fromIntegral filterMode+ glTexParameteri txTarget gl_TEXTURE_MIN_FILTER $ fromIntegral filterMode+ glTexParameteri txTarget gl_TEXTURE_BASE_LEVEL 0+ glTexParameteri txTarget gl_TEXTURE_MAX_LEVEL 0+ -- temp end+ case layerCnt > 1 of+ True -> glTexImage3D gl_TEXTURE_2D_ARRAY 0 internalFormat (fromIntegral w) (fromIntegral h) (fromIntegral layerCnt) 0 dataFormat gl_UNSIGNED_BYTE nullPtr+ False -> glTexImage2D gl_TEXTURE_2D 0 internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat gl_UNSIGNED_BYTE nullPtr+ return ()+ _ -> error $ "FIXME: This texture format is not yet supported: " ++ show txType+ return to