diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/lambdacube-gl.cabal b/lambdacube-gl.cabal new file mode 100644 --- /dev/null +++ b/lambdacube-gl.cabal @@ -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 + 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 diff --git a/src/lib/LambdaCube/GL.hs b/src/lib/LambdaCube/GL.hs new file mode 100644 --- /dev/null +++ b/src/lib/LambdaCube/GL.hs @@ -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" diff --git a/src/lib/LambdaCube/GL/Backend.hs b/src/lib/LambdaCube/GL/Backend.hs new file mode 100644 --- /dev/null +++ b/src/lib/LambdaCube/GL/Backend.hs @@ -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 + } diff --git a/src/lib/LambdaCube/GL/Compile.hs b/src/lib/LambdaCube/GL/Compile.hs new file mode 100644 --- /dev/null +++ b/src/lib/LambdaCube/GL/Compile.hs @@ -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 () diff --git a/src/lib/LambdaCube/GL/Data.hs b/src/lib/LambdaCube/GL/Data.hs new file mode 100644 --- /dev/null +++ b/src/lib/LambdaCube/GL/Data.hs @@ -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 () diff --git a/src/lib/LambdaCube/GL/GLSLCodeGen.hs b/src/lib/LambdaCube/GL/GLSLCodeGen.hs new file mode 100644 --- /dev/null +++ b/src/lib/LambdaCube/GL/GLSLCodeGen.hs @@ -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 diff --git a/src/lib/LambdaCube/GL/Mesh.hs b/src/lib/LambdaCube/GL/Mesh.hs new file mode 100644 --- /dev/null +++ b/src/lib/LambdaCube/GL/Mesh.hs @@ -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 diff --git a/src/lib/LambdaCube/GL/Type.hs b/src/lib/LambdaCube/GL/Type.hs new file mode 100644 --- /dev/null +++ b/src/lib/LambdaCube/GL/Type.hs @@ -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 + } diff --git a/src/lib/LambdaCube/GL/Util.hs b/src/lib/LambdaCube/GL/Util.hs new file mode 100644 --- /dev/null +++ b/src/lib/LambdaCube/GL/Util.hs @@ -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