lambdacube-core (empty) → 0.1.0
raw patch · 26 files changed
+7892/−0 lines, 26 filesdep +OpenGLRawdep +basedep +binarysetup-changed
Dependencies added: OpenGLRaw, base, binary, bitmap, bytestring, bytestring-trie, containers, language-glsl, mtl, prettyclass, vector
Files
- BiMap.hs +54/−0
- LC_API.hs +240/−0
- LC_B_GL.hs +385/−0
- LC_B_GLCompile.hs +540/−0
- LC_B_GLData.hs +312/−0
- LC_B_GLSLCodeGen.hs +869/−0
- LC_B_GLType.hs +168/−0
- LC_B_GLUtil.hs +972/−0
- LC_B_Traversals.hs +94/−0
- LC_C_Convert.hs +279/−0
- LC_C_PrimFun.hs +167/−0
- LC_G_APIType.hs +394/−0
- LC_G_Type.hs +240/−0
- LC_Mesh.hs +187/−0
- LC_T_APIType.hs +518/−0
- LC_T_DSLType.hs +622/−0
- LC_T_HOAS.hs +236/−0
- LC_T_Language.hs +508/−0
- LC_T_PrimFun.hs +172/−0
- LC_T_Sampler.hs +263/−0
- LC_U_APIType.hs +81/−0
- LC_U_DeBruijn.hs +308/−0
- LC_U_PrimFun.hs +160/−0
- LICENSE +28/−0
- Setup.hs +2/−0
- lambdacube-core.cabal +93/−0
+ BiMap.hs view
@@ -0,0 +1,54 @@+-- Establishing a bijection between the values of the type a and integers, with+-- the operations to retrieve the value given its key,+-- to find the key for the existing value, and to extend the +-- bijection with a new association.++-- The type 'a' of values should at least permit equality comparison;+-- In the present implementation, we require 'a' to be a member+-- of Ord.++-- There are many ways to implement bi-maps, for example, using hash tables,+-- or maps.+-- Our implementation uses Data.Map and Data.IntMap to record+-- both parts of the association.++module BiMap (+ BiMap(..), empty,+ lookup_key, + lookup_val, + insert,+ size,+ )+ where++import qualified Data.Map as M+import qualified Data.IntMap as IM++data BiMap a = BiMap (M.Map a Int) (IM.IntMap a)++-- Find a key for a value+lookup_key :: Ord a => a -> BiMap a -> Maybe Int+lookup_key v (BiMap m _) = M.lookup v m++-- Find a value for a key+lookup_val :: Int -> BiMap a -> a+lookup_val k (BiMap _ m) = m IM.! k++-- Insert the value and return the corresponding key+-- and the new map+-- Alas, Map interface does not have an operation to insert and find the index +-- at the same time (although such an operation is easily possible)+insert :: Ord a => a -> BiMap a -> (Int, BiMap a)+insert v (BiMap m im) = (k, BiMap m' im')+ where m' = M.insert v k m+ im' = IM.insert k v im+ k = IM.size im++empty :: BiMap a+empty = BiMap (M.empty) (IM.empty)++instance Show a => Show (BiMap a) where+ show (BiMap _ m) = "BiMap" ++ show (IM.toList m)++size :: BiMap a -> Int+size (BiMap _ m) = IM.size m
+ LC_API.hs view
@@ -0,0 +1,240 @@+module LC_API (+ -- language+ module LC_G_Type,+ module LC_G_APIType,+ module LC_T_APIType,+ module LC_T_DSLType,+ module LC_T_HOAS,+ module LC_T_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,++ Object,+ addObject,+ removeObject,+ objectUniformSetter,+ enableObject,++ -- texture (temporary)+ compileTexture2DRGBAF+) where++import Data.Int+import Data.Word++import LC_G_APIType hiding (InputType(..))+import LC_G_Type++import LC_T_APIType+import LC_T_DSLType hiding (Buffer,Shadow)+import LC_T_HOAS+import LC_T_Language+import qualified LC_T_APIType as H+import qualified LC_T_HOAS as H++import qualified LC_U_DeBruijn as U+import LC_C_Convert++import LC_B_GL hiding (compileRenderer)+import LC_B_GLCompile+import LC_B_GLData+import LC_B_GLType+import LC_B_GLUtil (Buffer)+import qualified LC_B_GL as GL++import Control.Monad.State+import Data.ByteString.Char8 (ByteString)+import Data.ByteString.Char8 as SB+import Data.Trie as T++compileRenderer :: H.GPOutput H.SingleOutput -> IO Renderer+compileRenderer l = GL.compileRenderer dag $ U.toExp dag l'+ where+ (l', dag) = runState (U.unN $ convertGPOutput l) U.emptyDAG++nullSetter :: ByteString -> String -> a -> IO ()+nullSetter n t _ = 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 fun) -> fun+ _ -> nullSetter n "Bool"++uniformV2B n is = case T.lookup n is of+ Just (SV2B fun) -> fun+ _ -> nullSetter n "V2B"++uniformV3B n is = case T.lookup n is of+ Just (SV3B fun) -> fun+ _ -> nullSetter n "V3B"++uniformV4B n is = case T.lookup n is of+ Just (SV4B fun) -> fun+ _ -> nullSetter n "V4B"++uniformWord n is = case T.lookup n is of+ Just (SWord fun) -> fun+ _ -> nullSetter n "Word"++uniformV2U n is = case T.lookup n is of+ Just (SV2U fun) -> fun+ _ -> nullSetter n "V2U"++uniformV3U n is = case T.lookup n is of+ Just (SV3U fun) -> fun+ _ -> nullSetter n "V3U"++uniformV4U n is = case T.lookup n is of+ Just (SV4U fun) -> fun+ _ -> nullSetter n "V4U"++uniformInt n is = case T.lookup n is of+ Just (SInt fun) -> fun+ _ -> nullSetter n "Int"++uniformV2I n is = case T.lookup n is of+ Just (SV2I fun) -> fun+ _ -> nullSetter n "V2I"++uniformV3I n is = case T.lookup n is of+ Just (SV3I fun) -> fun+ _ -> nullSetter n "V3I"++uniformV4I n is = case T.lookup n is of+ Just (SV4I fun) -> fun+ _ -> nullSetter n "V4I"++uniformFloat n is = case T.lookup n is of+ Just (SFloat fun) -> fun+ _ -> nullSetter n "Float"++uniformV2F n is = case T.lookup n is of+ Just (SV2F fun) -> fun+ _ -> nullSetter n "V2F"++uniformV3F n is = case T.lookup n is of+ Just (SV3F fun) -> fun+ _ -> nullSetter n "V3F"++uniformV4F n is = case T.lookup n is of+ Just (SV4F fun) -> fun+ _ -> nullSetter n "V4F"++uniformM22F n is = case T.lookup n is of+ Just (SM22F fun) -> fun+ _ -> nullSetter n "M22F"++uniformM23F n is = case T.lookup n is of+ Just (SM23F fun) -> fun+ _ -> nullSetter n "M23F"++uniformM24F n is = case T.lookup n is of+ Just (SM24F fun) -> fun+ _ -> nullSetter n "M24F"++uniformM32F n is = case T.lookup n is of+ Just (SM32F fun) -> fun+ _ -> nullSetter n "M32F"++uniformM33F n is = case T.lookup n is of+ Just (SM33F fun) -> fun+ _ -> nullSetter n "M33F"++uniformM34F n is = case T.lookup n is of+ Just (SM34F fun) -> fun+ _ -> nullSetter n "M34F"++uniformM42F n is = case T.lookup n is of+ Just (SM42F fun) -> fun+ _ -> nullSetter n "M42F"++uniformM43F n is = case T.lookup n is of+ Just (SM43F fun) -> fun+ _ -> nullSetter n "M43F"++uniformM44F n is = case T.lookup n is of+ Just (SM44F fun) -> fun+ _ -> nullSetter n "M44F"++uniformFTexture2D n is = case T.lookup n is of+ Just (SFTexture2D fun) -> fun+ _ -> nullSetter n "FTexture2D"
+ LC_B_GL.hs view
@@ -0,0 +1,385 @@+module LC_B_GL 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 LC_G_Type+import LC_G_APIType+import LC_U_APIType+import LC_U_DeBruijn++import LC_B_GLType+import LC_B_GLUtil+import LC_B_GLSLCodeGen+import LC_B_Traversals+import LC_B_GLCompile++-- 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)+orderedFrameBuffersFromGP :: DAG -> Exp -> [Exp]+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] -> IO (Map Exp String, Map Exp String, Map Exp GLuint, IO (), Exp -> [Exp])+mkRenderTextures dag allGPs = do+ let samplers = nubS [s | s@Sampler {} <- expUniverse' dag allGPs]+ 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 ++ ": ") >> printGLStatus+ 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 :: DAG -> RenderState -> Map Exp String -> Map Exp String -> Map Exp GLuint -> Exp -> IO RenderDescriptor+mkRenderDescriptor 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+ --putStr (" -- Texture bind (TexUnit " ++ show (texUnitIdx,texObj) ++ " TexObj): ") >> printGLStatus++ drawRef <- newIORef $ ObjectSet (return ()) Map.empty+ (rA,dA,uT,sT,outColorCnt) <- compileRenderFrameBuffer 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) -> DAG -> Map Exp GLuint -> (Exp -> [Exp]) -> (Bool,Int,Int) -> Exp -> IO (IO (), IO ())+mkPassSetup screenSizeIORef 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+ glViewport 0 0 (fromIntegral screenW) (fromIntegral screenH)+ 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+ 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+ glBindFramebuffer gl_DRAW_FRAMEBUFFER glFBO+ putStr " - bind: " >> printGLStatus+ let depSamplers = dependentSamplers fb+ hasDepthOp = case fb of+ Accumulate (AccumulationContext _ ops) _ _ _ _ -> not $ L.null [() | DepthOp {} <- ops]+ 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+ 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++ -- check all texture size maches+ unless (all (== head texSizes) texSizes) $ error ("Framebuffer attachment size mismatch! \n" ++ " - sizes: " ++ show texSizes)+ -- create and attach depth buffer+ let VV2U (V2 depthW depthH) = head texSizes+ when hasDepthOp $ do+ {-+ depthTex <- alloca $! \pto -> glGenRenderbuffers 1 pto >> peek pto+ putStr " - alloc depth texture: " >> printGLStatus+ glBindRenderbuffer gl_RENDERBUFFER depthTex+ putStr " - bind depth texture: " >> printGLStatus+ glRenderbufferStorage gl_RENDERBUFFER gl_DEPTH_COMPONENT32 (fromIntegral depthW) (fromIntegral depthH)+ putStr " - define depth texture: " >> printGLStatus+ glFramebufferRenderbuffer gl_DRAW_FRAMEBUFFER gl_DEPTH_ATTACHMENT gl_RENDERBUFFER depthTex+ putStr " - attach depth texture: " >> printGLStatus+ -}+ depthTex <- alloca $! \pto -> glGenTextures 1 pto >> peek pto+ putStr " - alloc depth texture: " >> printGLStatus+ let layerCnt = head layerCnts+ txTarget = if layerCnt > 1 then gl_TEXTURE_2D_ARRAY else gl_TEXTURE_2D+ internalFormat = fromIntegral gl_DEPTH_COMPONENT32+ dataFormat = fromIntegral gl_DEPTH_COMPONENT+ glBindTexture txTarget depthTex+ putStr " - bind depth texture: " >> printGLStatus+ -- 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+ 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+++ putStr " - check FBO completeness: " >> printFBOStatus++ let renderAct = do+ glBindFramebuffer gl_DRAW_FRAMEBUFFER glFBO+ glViewport 0 0 (fromIntegral depthW) (fromIntegral depthH)+ --putStr " -- FBO bind: " >> printGLStatus+ --putStr " -- FBO status: " >> printFBOStatus+ 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)+ return $ RenderState+ { textureUnitState = texUnitState+ }+{-+ 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 (ScreenOut img) = do+ let PrjFrameBuffer n idx gpId = toExp dag img+ gp = toExp dag gpId+ 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 = nubS $ concatMap (gpUniverse' dag) 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 $ "GP universe size: " ++ show (length allGPs)+ putStrLn $ "Exp universe size: " ++ show (length (nubS $ expUniverse' dag gp))++ -- create RenderState+ rendState <- mkRenderState++ (uSetup,uSetter) <- unzip <$> mapM (mkUniformSetter rendState) uniformTypes+ let uniformSetterTrie = T.fromList $! zip uniformNames uSetter+ 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++ -- create RenderDescriptors+ renderDescriptors <- Map.fromList <$> mapM (\a -> (a,) <$> mkRenderDescriptor 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 dag renderTexGLObj dependentSamplers (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"+ sequence_ passRender+ --print " * Frame Ended"+ , dispose = renderTexDispose >> sequence_ passDispose+ , setScreenSize = \w h -> writeIORef screenSizeIORef (w,h)++ -- internal+ , mkUniformSetup = mkUniformSetupTrie+ , slotDescriptor = slotDescriptors+ , renderDescriptor = renderDescriptors+ , renderState = rendState+ , objectIDSeed = objIDSeed+ }
+ LC_B_GLCompile.hs view
@@ -0,0 +1,540 @@+module LC_B_GLCompile 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.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 *+ -- 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+ )++import LC_G_Type+import LC_G_APIType+import LC_U_APIType+import LC_U_DeBruijn++import LC_B_GLType+import LC_B_GLUtil+import LC_B_GLSLCodeGen+import LC_B_Traversals++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+ -- cull mode+ case cm of+ CullNone -> glDisable gl_CULL_FACE+ CullFront f -> do+ glEnable gl_CULL_FACE+ glCullFace gl_FRONT+ glFrontFace $ cff f+ CullBack f -> do+ glEnable gl_CULL_FACE+ glCullFace gl_BACK+ glFrontFace $ cff f++ -- polygon mode+ case pm of+ PolygonPoint ps -> do+ setPointSize ps+ glPolygonMode gl_FRONT_AND_BACK gl_POINT+ PolygonLine lw -> do+ glLineWidth (realToFrac lw)+ glPolygonMode gl_FRONT_AND_BACK gl_LINE+ PolygonFill -> glPolygonMode gl_FRONT_AND_BACK gl_FILL++ -- polygon offset+ glDisable gl_POLYGON_OFFSET_POINT+ glDisable gl_POLYGON_OFFSET_LINE+ glDisable gl_POLYGON_OFFSET_FILL+ case po of+ NoOffset -> return ()+ Offset f u -> do+ glPolygonOffset (realToFrac f) (realToFrac u)+ glEnable $ case pm of+ PolygonPoint _ -> gl_POLYGON_OFFSET_POINT+ PolygonLine _ -> gl_POLYGON_OFFSET_LINE+ PolygonFill -> gl_POLYGON_OFFSET_FILL++ -- provoking vertex+ setProvokingVertex pv++setupAccumulationContext :: AccumulationContext -> IO ()+setupAccumulationContext (AccumulationContext n ops) = cvt ops+ where+ cvt :: [FragmentOperation] -> IO ()+ cvt (StencilOp a b c : DepthOp f m : xs) = do+ -- TODO+ cvtC 0 xs+ cvt (StencilOp a b c : xs) = do+ -- TODO+ cvtC 0 xs+ cvt (DepthOp df dm : xs) = do+ -- TODO+ glDisable gl_STENCIL_TEST+ case df == Always && dm == False of+ True -> glDisable gl_DEPTH_TEST+ False -> do+ glEnable gl_DEPTH_TEST+ glDepthFunc $! comparisonFunctionToGLType df+ glDepthMask (cvtBool dm)+ cvtC 0 xs+ cvt xs = do + glDisable gl_DEPTH_TEST+ glDisable gl_STENCIL_TEST+ cvtC 0 xs++ cvtC :: Int -> [FragmentOperation] -> IO ()+ cvtC i (ColorOp b m : xs) = do+ -- TODO+ case b of+ NoBlending -> do+ -- FIXME: requires GL 3.1+ --glDisablei gl_BLEND $ fromIntegral gl_DRAW_BUFFER0 + fromIntegral i+ glDisable gl_BLEND -- workaround+ glDisable gl_COLOR_LOGIC_OP+ BlendLogicOp op -> do+ glDisable gl_BLEND+ glEnable gl_COLOR_LOGIC_OP+ glLogicOp $ logicOperationToGLType op+ Blend (cEq,aEq) ((scF,dcF),(saF,daF)) (V4 r g b a) -> do+ glDisable gl_COLOR_LOGIC_OP+ -- FIXME: requires GL 3.1+ --glEnablei gl_BLEND $ fromIntegral gl_DRAW_BUFFER0 + fromIntegral i+ glEnable gl_BLEND -- workaround+ glBlendEquationSeparate (blendEquationToGLType cEq) (blendEquationToGLType aEq)+ glBlendFuncSeparate (blendingFactorToGLType scF) (blendingFactorToGLType dcF)+ (blendingFactorToGLType saF) (blendingFactorToGLType daF)+ glBlendColor (realToFrac r) (realToFrac g) (realToFrac b) (realToFrac a)+ let cvt True = 1+ cvt False = 0+ (mr,mg,mb,ma) = case m of+ VBool r -> (cvt r, 1, 1, 1)+ VV2B (V2 r g) -> (cvt r, cvt g, 1, 1)+ VV3B (V3 r g b) -> (cvt r, cvt g, cvt b, 1)+ VV4B (V4 r g b a) -> (cvt r, cvt g, cvt b, cvt a)+ _ -> (1,1,1,1)+ glColorMask mr mg mb ma+ cvtC (i + 1) xs+ cvtC _ [] = return ()++ cvtBool :: Bool -> GLboolean+ cvtBool True = 1+ cvtBool False = 0++{-+ 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) = 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 [] = 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 :: DAG -> [(Exp,String)] -> [(Exp,String)] -> IORef ObjectSet -> Exp -> IO (IO (), IO (), Trie GLint, Trie GLuint, Int)+compileRenderFrameBuffer 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 (Map.null objsMap) $ do+ --putStrLn $ "Slot: " ++ show slotName ++ " object count: " ++ show (Map.size objsMap)+ setupRasterContext rCtx+ setupAccumulationContext aCtx+ glUseProgram po+ drawObjs+ print slotName+ print uLoc'+ return $! (renderFun, disposeFun, uLoc', sLoc, outColorCnt)
+ LC_B_GLData.hs view
@@ -0,0 +1,312 @@+module LC_B_GLData 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 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+ , 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 LC_B_GLType+import LC_B_GLUtil+import LC_G_APIType+import LC_U_APIType+import LC_U_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++ 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 (glBindBuffer gl_ELEMENT_ARRAY_BUFFER 0, 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 (glBindBuffer gl_ELEMENT_ARRAY_BUFFER bo, 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) <- unzip <$> (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 $ " setup object uniforms: " ++ show [n | n <- objUniforms, T.member n uLocs]+ objUSetup+ 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
+ LC_B_GLSLCodeGen.hs view
@@ -0,0 +1,869 @@+module LC_B_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 LC_G_Type+import LC_G_APIType hiding (LogicOperation(..), ComparisonFunction(..))+import LC_U_APIType+import LC_U_PrimFun+import LC_U_DeBruijn hiding (ExpC(..))++import Language.GLSL.Syntax hiding (Const,InterpolationQualifier(..),TypeSpecifierNonArray(..))+import Language.GLSL.Syntax (TypeSpecifierNonArray)+import qualified Language.GLSL.Syntax as GLSL+import Language.GLSL.Pretty+import LC_B_Traversals++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+ 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 -> 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 150 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 150 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 150 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 Nothing Nothing]+ where+ tq = Just $ TypeQualInt iq $ Just In+ varTySpecNoPrec = TypeSpecNoPrecision ty (Just 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
+ LC_B_GLType.hs view
@@ -0,0 +1,168 @@+module LC_B_GLType 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 LC_G_APIType+import LC_U_APIType+import LC_U_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 ()++ -- 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+ }++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)
+ LC_B_GLUtil.hs view
@@ -0,0 +1,972 @@+module LC_B_GLUtil (+ 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_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 LC_G_Type+import LC_G_APIType+import LC_U_APIType+import LC_U_DeBruijn+import LC_B_GLType++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)+mkUniformSetter _ Bool = do {t <- newIORef False; return $! (\i -> readIORef t >>= setUBool i, SBool $! writeIORef t)}+mkUniformSetter _ V2B = do {t <- newIORef (V2 False False); return $! (\i -> readIORef t >>= setUV2B i, SV2B $! writeIORef t)}+mkUniformSetter _ V3B = do {t <- newIORef (V3 False False False); return $! (\i -> readIORef t >>= setUV3B i, SV3B $! writeIORef t)}+mkUniformSetter _ V4B = do {t <- newIORef (V4 False False False False); return $! (\i -> readIORef t >>= setUV4B i, SV4B $! writeIORef t)}+mkUniformSetter _ Word = do {t <- newIORef 0; return $! (\i -> readIORef t >>= setUWord i, SWord $! writeIORef t)}+mkUniformSetter _ V2U = do {t <- newIORef (V2 0 0); return $! (\i -> readIORef t >>= setUV2U i, SV2U $! writeIORef t)}+mkUniformSetter _ V3U = do {t <- newIORef (V3 0 0 0); return $! (\i -> readIORef t >>= setUV3U i, SV3U $! writeIORef t)}+mkUniformSetter _ V4U = do {t <- newIORef (V4 0 0 0 0); return $! (\i -> readIORef t >>= setUV4U i, SV4U $! writeIORef t)}+mkUniformSetter _ Int = do {t <- newIORef 0; return $! (\i -> readIORef t >>= setUInt i, SInt $! writeIORef t)}+mkUniformSetter _ V2I = do {t <- newIORef (V2 0 0); return $! (\i -> readIORef t >>= setUV2I i, SV2I $! writeIORef t)}+mkUniformSetter _ V3I = do {t <- newIORef (V3 0 0 0); return $! (\i -> readIORef t >>= setUV3I i, SV3I $! writeIORef t)}+mkUniformSetter _ V4I = do {t <- newIORef (V4 0 0 0 0); return $! (\i -> readIORef t >>= setUV4I i, SV4I $! writeIORef t)}+mkUniformSetter _ Float = do {t <- newIORef 0; return $! (\i -> readIORef t >>= setUFloat i, SFloat $! writeIORef t)}+mkUniformSetter _ V2F = do {t <- newIORef (V2 0 0); return $! (\i -> readIORef t >>= setUV2F i, SV2F $! writeIORef t)}+mkUniformSetter _ V3F = do {t <- newIORef (V3 0 0 0); return $! (\i -> readIORef t >>= setUV3F i, SV3F $! writeIORef t)}+mkUniformSetter _ V4F = do {t <- newIORef (V4 0 0 0 0); return $! (\i -> readIORef t >>= setUV4F i, SV4F $! writeIORef t)}+mkUniformSetter _ M22F = do {t <- newIORef (V2 z2 z2); return $! (\i -> readIORef t >>= setUM22F i, SM22F $! writeIORef t)}+mkUniformSetter _ M23F = do {t <- newIORef (V3 z2 z2 z2); return $! (\i -> readIORef t >>= setUM23F i, SM23F $! writeIORef t)}+mkUniformSetter _ M24F = do {t <- newIORef (V4 z2 z2 z2 z2); return $! (\i -> readIORef t >>= setUM24F i, SM24F $! writeIORef t)}+mkUniformSetter _ M32F = do {t <- newIORef (V2 z3 z3); return $! (\i -> readIORef t >>= setUM32F i, SM32F $! writeIORef t)}+mkUniformSetter _ M33F = do {t <- newIORef (V3 z3 z3 z3); return $! (\i -> readIORef t >>= setUM33F i, SM33F $! writeIORef t)}+mkUniformSetter _ M34F = do {t <- newIORef (V4 z3 z3 z3 z3); return $! (\i -> readIORef t >>= setUM34F i, SM34F $! writeIORef t)}+mkUniformSetter _ M42F = do {t <- newIORef (V2 z4 z4); return $! (\i -> readIORef t >>= setUM42F i, SM42F $! writeIORef t)}+mkUniformSetter _ M43F = do {t <- newIORef (V3 z4 z4 z4); return $! (\i -> readIORef t >>= setUM43F i, SM43F $! writeIORef t)}+mkUniformSetter _ M44F = do {t <- newIORef (V4 z4 z4 z4 z4); return $! (\i -> readIORef t >>= setUM44F i, SM44F $! writeIORef t)}+mkUniformSetter rendState FTexture2D = do+ let texUnitState = textureUnitState rendState+ t <- newIORef (TextureData 0)+ return $! (\i -> readIORef t >>= setTextureData texUnitState i, SFTexture2D $! writeIORef 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+ allocaArray (fromIntegral i) $! \ps -> glGetShaderInfoLog o (fromIntegral i) nullPtr ps >> SB.packCString (castPtr ps) >>= SB.putStr++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+ allocaArray (fromIntegral i) $! \ps -> glGetProgramInfoLog o (fromIntegral i) nullPtr ps >> SB.packCString (castPtr ps) >>= SB.putStr++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 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 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
+ LC_B_Traversals.hs view
@@ -0,0 +1,94 @@+module LC_B_Traversals where++import Data.List+import Data.IntSet (IntSet)+import qualified Data.IntSet as IntSet++import LC_U_APIType+import LC_U_DeBruijn++class HasExp a where+ expUniverse :: DAG -> a -> [Exp]+ expUniverse' :: DAG -> a -> [Exp] -- includes the origin++instance HasExp a => HasExp [a] where+ expUniverse dag a = concatMap (expUniverse dag) a+ expUniverse' dag a = concatMap (expUniverse' dag) a++instance HasExp ExpId where+ expUniverse dag e = expUniverse dag $ toExp dag e+ expUniverse' dag e = expUniverse' dag $ toExp dag e++instance HasExp Exp where+ expUniverse dag exp = case exp of+ Lam f -> expUniverse dag f+ Body f -> let a = toExp dag f+ in a : expUniverse dag f+ Apply ia ib -> let [a,b] = map (toExp dag) [ia,ib]+ in a : b : expUniverse dag a ++ expUniverse dag b+ Tup l -> let e = map (toExp dag) l+ in e ++ expUniverse dag e+ Prj _ i -> let e = toExp dag i + in e : expUniverse dag e+ Cond ia ib ic -> let [a,b,c] = map (toExp dag) [ia,ib,ic]+ in a : b : c : expUniverse dag a ++ expUniverse dag b ++ expUniverse dag c+ PrimApp _ ia -> let a = toExp dag ia+ in a : expUniverse dag a+ Loop ia ib ic id -> let [a,b,c,d] = map (toExp dag) [ia,ib,ic,id]+ in a : b : c : d : expUniverse dag a ++ expUniverse dag b ++ expUniverse dag c ++ expUniverse dag d+ VertexOut ia ib ic id -> let [a,b] = map (toExp dag) [ia,ib]+ in a : b : expUniverse dag a ++ expUniverse dag b ++ expUniverse dag ic ++ expUniverse dag id+ GeometryOut i j k l m -> let [a,b,c] = map (toExp dag) [i,j,k]+ in a : b : c : expUniverse dag a ++ expUniverse dag b ++ expUniverse dag c ++ expUniverse dag l ++ expUniverse dag m+ FragmentOut i -> let a = map (toExp dag) i+ in a ++ expUniverse dag a+ FragmentOutDepth i j -> let a:b = map (toExp dag) (i:j)+ in a : b ++ expUniverse dag a ++ expUniverse dag b+ FragmentOutRastDepth i -> let a = map (toExp dag) i+ in a ++ expUniverse dag a+ Transform a b -> expUniverse dag a ++ expUniverse dag b+ Reassemble a b -> expUniverse dag a ++ expUniverse dag b+ Rasterize _ a -> expUniverse dag a+ Accumulate _ a b c _ -> expUniverse dag a ++ expUniverse dag b ++ expUniverse dag c+ PrjFrameBuffer _ _ a -> expUniverse dag a+ PrjImage _ _ a -> expUniverse dag a+ Filter f -> expUniverse dag f+ Flat a -> toExp dag a : expUniverse dag a+ Smooth a -> toExp dag a : expUniverse dag a+ NoPerspective a -> toExp dag a : expUniverse dag a + GeometryShader _ _ _ a b c -> expUniverse dag a ++ expUniverse dag b ++ expUniverse dag c+ _ -> []++ expUniverse' dag exp = exp : expUniverse dag exp++gpUniverse :: DAG -> Exp -> [Exp]+gpUniverse dag gp = gp : case gp of+ Transform _ a -> gpUniverse dag $ toExp dag a+ Reassemble _ a -> gpUniverse dag $ toExp dag a+ Rasterize _ a -> gpUniverse dag $ toExp dag a+ Accumulate _ _ _ a b -> gpUniverse dag (toExp dag a) ++ gpUniverse dag (toExp dag b)+ PrjFrameBuffer _ _ a -> gpUniverse dag $ toExp dag a+ PrjImage _ _ a -> gpUniverse dag $ toExp dag a+ _ -> []++-- includes the origin+gpUniverse' :: DAG -> Exp -> [Exp]+gpUniverse' dag gp = gp : gpUniverse dag gp++findFrameBuffer :: DAG -> Exp -> Exp+findFrameBuffer dag a = head $ dropWhile notFrameBuffer $ gpUniverse' dag a+ where+ notFrameBuffer (Accumulate {}) = False+ notFrameBuffer (FrameBuffer {}) = False+ notFrameBuffer _ = True++-- starts from a FrameBuffer GP and track the draw action chain until the FrameBuffer definition+renderChain :: DAG -> Exp -> [Exp]+renderChain _ fb@(FrameBuffer {}) = [fb]+renderChain dag fb@(Accumulate _ _ _ _ a) = renderChain dag (toExp dag a) ++ [fb]+renderChain _ _ = []++drawOperations :: DAG -> Exp -> [Exp]+drawOperations dag fb@(FrameBuffer {}) = [fb]+drawOperations dag fb@(Accumulate _ _ _ a _) = fb : gpUniverse' dag (toExp dag a)+drawOperations _ _ = []
+ LC_C_Convert.hs view
@@ -0,0 +1,279 @@+module LC_C_Convert (convertGPOutput) where++import GHC.TypeLits++import Debug.Trace++import LC_T_APIType (FlatTuple(..),Frequency(..))+import LC_T_DSLType (GPU,Tuple(..),TupleIdx(..))+import qualified LC_T_APIType as T+import qualified LC_T_DSLType as T hiding (Shadow)+import qualified LC_T_PrimFun as T+import qualified LC_T_HOAS as H+import LC_U_DeBruijn+import LC_U_APIType+import LC_G_APIType+import LC_C_PrimFun+import LC_G_Type as G++toInt :: SingI n => T.NatNum n -> Int+toInt (a :: T.NatNum n) = fromInteger $ fromSing (sing :: Sing (n :: Nat))++prjIdx i lyt = i--length lyt - i - 1+++prjToInt :: TupleIdx t e -> Int+prjToInt ZeroTupIdx = 0+prjToInt (SuccTupIdx i) = 1 + prjToInt i++genTupLen :: GPU a => Int -> a -> Int+genTupLen i a = sum $ map tySize $ take i rt+ where+ rt = reverse t+ Tuple t = genTy a++type Layout = [[Ty]]++genTy :: GPU a => a -> Ty+genTy = T.tupleType++convertGPOutput :: ExpC exp => H.GPOutput o -> exp+convertGPOutput (H.ImageOut a b c) = imageOut a b $ convertGP c+convertGPOutput (H.ScreenOut a) = screenOut $ convertGP a+convertGPOutput (H.MultiOut a) = multiOut $ map convertGPOutput a++-- GP+convertGP :: ExpC exp => H.Exp T.Obj t -> exp+convertGP = convertOpenGP []++convertOpenGP :: ExpC exp => Layout -> H.Exp T.Obj t -> exp+convertOpenGP = cvt+ where+ cvt :: ExpC exp => Layout -> H.Exp T.Obj t -> exp+ cvt lyt (H.Fetch n p i) = fetch n (convertFetchPrimitive p) (T.toInputList i)+ cvt lyt (H.Transform vs ps) = transform (convertFun1Vert lyt vs) (cvt lyt ps)+ cvt lyt (H.Reassemble sh ps) = reassemble (convertGeometryShader lyt sh) (cvt lyt ps)+ cvt lyt (H.Rasterize ctx ps) = rasterize (convertRasterContext ctx) $ cvt lyt ps+ cvt lyt (H.FrameBuffer fb) = frameBuffer (convertFrameBuffer fb)+ cvt lyt (H.Accumulate ctx f sh fs fb) = accumulate (convertAccumulationContext ctx) (convertFragmentFilter lyt f)+ (convertFun1Frag lyt sh)+ (cvt lyt fs)+ (cvt lyt fb)+ cvt lyt (H.PrjFrameBuffer n idx fb) = prjFrameBuffer n (prjToInt idx) $ convertGP fb+ cvt lyt (H.PrjImage n idx img) = prjImage n (toInt idx) $ convertGP img++-- Vertex+convertOpenVertexOut :: ExpC exp => forall t.+ Layout -- environment+ -> H.VertexOut clipDistances t -- expression to be converted+ -> exp+convertOpenVertexOut lyt = cvt+ where+ cvt :: ExpC exp => H.VertexOut clipDistances t' -> exp+ cvt (H.VertexOut e1 e2 e3 ie :: H.VertexOut clipDistances t') = vertexOut (convertOpenExp lyt e1) (convertOpenExp lyt e2) (convertOpenFlatExp lyt e3) (convertOpenInterpolatedFlatExp lyt ie)++-- Fragment+convertOpenFragmentOut :: ExpC exp => forall t.+ Layout -- environment+ -> H.FragmentOut t -- expression to be converted+ -> exp+convertOpenFragmentOut lyt = cvt+ where+ cvt :: ExpC exp => H.FragmentOut t' -> exp+ cvt (H.FragmentOut fe :: H.FragmentOut t') = fragmentOut $ convertOpenFlatExp lyt fe+ cvt (H.FragmentOutDepth e fe :: H.FragmentOut t') = fragmentOutDepth (convertOpenExp lyt e) (convertOpenFlatExp lyt fe)+ cvt (H.FragmentOutRastDepth fe :: H.FragmentOut t') = fragmentOutRastDepth $ convertOpenFlatExp lyt fe++convertFragmentFilter :: (ExpC exp, GPU a)+ => Layout+ -> H.FragmentFilter a+ -> exp+convertFragmentFilter = cvt+ where+ cvt :: (ExpC exp, GPU a) => Layout -> H.FragmentFilter a -> exp+ cvt lyt H.PassAll = passAll+ cvt lyt (H.Filter f) = filter_ $ convertFun1Exp lyt f++-- Geometry+convertOpenGeometryOut :: ExpC exp => forall i clipDistances t.+ Layout -- environment+ -> H.GeometryOut i clipDistances t -- expression to be converted+ -> exp+convertOpenGeometryOut lyt = cvt+ where+ cvt :: ExpC exp => H.GeometryOut i clipDistances t' -> exp+ cvt (H.GeometryOut e1 e2 e3 e4 ie :: H.GeometryOut i clipDistances t') = geometryOut (convertOpenExp lyt e1)+ (convertOpenExp lyt e2)+ (convertOpenExp lyt e3)+ (convertOpenFlatExp lyt e4)+ (convertOpenInterpolatedFlatExp lyt ie)++convertGeometryShader :: ExpC exp+ => Layout+ -> H.GeometryShader inputPrimitive outputPrimitive inputClipDistances outputClipDistances layerCount a b+ -> exp+convertGeometryShader = cvt+ where+ cvt :: ExpC exp => Layout -> H.GeometryShader inputPrimitive outputPrimitive inputClipDistances outputClipDistances layerCount a b -> exp+ cvt lyt (H.GeometryShader a b c e1 e2 e3) = geometryShader (toInt a) (convertOutputPrimitive b) c (convertFun1Exp lyt e1)+ (convertFun1Exp lyt e2)+ (convertFun1Geom lyt e3)++-- Common+convertOpenInterpolatedFlatExp :: ExpC exp => forall stage t.+ Layout -- environment+ -> H.InterpolatedFlatExp stage t -- expression to be converted+ -> [exp]+convertOpenInterpolatedFlatExp lyt = cvt+ where+ cvt :: ExpC exp => H.InterpolatedFlatExp stage t' -> [exp]+ cvt (ZT) = []+ cvt (e:.xs) = cvt' e : cvt xs++ cvt' :: ExpC exp => T.Interpolated (H.Exp stage) t' -> exp+ cvt' (T.Flat e) = flat $ convertOpenExp lyt e+ cvt' (T.Smooth e) = smooth $ convertOpenExp lyt e+ cvt' (T.NoPerspective e) = noPerspective $ convertOpenExp lyt e++convertOpenFlatExp :: ExpC exp => forall stage t.+ Layout -- environment+ -> H.FlatExp stage t -- expression to be converted+ -> [exp]+convertOpenFlatExp lyt = cvt+ where+ cvt :: ExpC exp => H.FlatExp stage t' -> [exp]+ cvt (ZT) = []+ cvt (e:.xs) = convertOpenExp lyt e : cvt xs++convertOpenExp :: ExpC exp => forall stage t.+ Layout -- environment+ -> H.Exp stage t -- expression to be converted+ -> exp+convertOpenExp lyt = cvt+ where+ cvt :: ExpC exp => H.Exp stage t' -> exp+ cvt (H.Tag i li :: H.Exp stage t') = var (genTy (undefined :: t')) (prjIdx i lyt) li+ cvt (H.Const v :: H.Exp stage t') = const_ (genTy (undefined :: t')) (T.toValue v)+ cvt (H.PrimVar v :: H.Exp stage t') = primVar (genTy (undefined :: t')) (fst $ T.toInput v)+ cvt (H.Uni v :: H.Exp stage t') = uni (genTy (undefined :: t')) (fst $ T.toInput v)+ cvt (H.Tup tupl :: H.Exp stage t') = tup (genTy (undefined :: t')) $ convertTuple lyt tupl+ cvt (H.Prj idx (e :: H.Exp stage e') :: H.Exp stage' t') = prj (genTy (undefined :: t')) (genTupLen (prjToInt idx) (undefined :: e')) $ cvt e+ cvt (H.Cond e1 e2 e3 :: H.Exp stage t') = cond (genTy (undefined :: t')) (cvt e1) (cvt e2) (cvt e3)+ cvt (H.PrimApp p e :: H.Exp stage t') = primApp (genTy (undefined :: t')) (convertPrimFun p) $ cvt e+ cvt (H.Sampler f em t :: H.Exp stage t') = sampler (genTy (undefined :: t')) f em $ convertTexture t+ cvt (H.Loop e1 e2 e3 s :: H.Exp stage t') = loop (genTy (undefined :: t')) (convertFun1Exp lyt e1) (convertFun1Exp lyt e2) (convertFun1Exp lyt e3) (cvt s)++convertFun1Vert :: ExpC exp => forall a b clipDistances. GPU a+ => Layout+ -> (H.Exp V a -> H.VertexOut clipDistances b) + -> exp+convertFun1Vert = convertFun1 convertOpenVertexOut++convertFun1Geom :: ExpC exp => (GPU a, GPU i, GPU b, GPU clipDistances)+ => Layout+ -> (H.Exp G a -> H.GeometryOut i clipDistances b) + -> exp+convertFun1Geom = convertFun1 convertOpenGeometryOut++convertFun1Frag :: ExpC exp => forall a b. GPU a+ => Layout+ -> (H.Exp F a -> H.FragmentOut b) + -> exp+convertFun1Frag = convertFun1 convertOpenFragmentOut++convertFun1Exp :: ExpC exp => forall stage a b. GPU a+ => Layout+ -> (H.Exp stage a -> H.Exp stage b) + -> exp+convertFun1Exp = convertFun1 convertOpenExp++convertFun1 :: (GPU a, ExpC exp)+ => (Layout -> b -> exp) -> Layout -> (H.Exp stage a -> b) -> exp+convertFun1 cvt lyt (f :: H.Exp stage t' -> b) = lam (genTy (undefined :: t')) $ body $ cvt lyt' (f a)+ where+ lyt' = []:lyt+ a = case f of+ (fv :: H.Exp stage t -> t2) -> H.Tag (length lyt) (show $ genTy (undefined :: t))++convertExp :: ExpC exp+ => Layout -- array environment+ -> H.Exp stage t -- expression to be converted+ -> exp+convertExp lyt = convertOpenExp lyt++convertTuple :: ExpC exp+ => Layout+ -> Tuple (H.Exp stage) t + -> [exp]+convertTuple _lyt NilTup = []+convertTuple lyt (es `SnocTup` e) = convertTuple lyt es ++ [convertOpenExp lyt e]++-- data type conversion++convertTexture :: ExpC exp+ => T.Texture (H.Exp T.Obj) dim arr t ar+ -> exp+convertTexture (T.TextureSlot n t) = textureSlot n (convertTextureType t)+convertTexture (T.Texture t s m d) = texture (convertTextureType t) (T.toValue s) (convertMipMap m) (map convertGP d)++convertTextureDataType :: T.TextureDataType t ar -> TextureDataType+convertTextureDataType (T.Float a) = FloatT (T.toColorArity a)+convertTextureDataType (T.Int a) = IntT (T.toColorArity a)+convertTextureDataType (T.Word a) = WordT (T.toColorArity a)+convertTextureDataType T.Shadow = ShadowT++convertTextureType :: T.TextureType dim mip arr layerCount t ar -> TextureType+convertTextureType (T.Texture1D a b) = Texture1D (convertTextureDataType a) (toInt b)+convertTextureType (T.Texture2D a b) = Texture2D (convertTextureDataType a) (toInt b)+convertTextureType (T.Texture3D a) = Texture3D (convertTextureDataType a)+convertTextureType (T.TextureCube a) = TextureCube (convertTextureDataType a)+convertTextureType (T.TextureRect a) = TextureRect (convertTextureDataType a)+convertTextureType (T.Texture2DMS a b) = Texture2DMS (convertTextureDataType a) (toInt b)+convertTextureType (T.TextureBuffer a) = TextureBuffer (convertTextureDataType a)++convertMipMap :: T.MipMap t -> MipMap+convertMipMap (T.NoMip) = NoMip+convertMipMap (T.Mip a b) = Mip a b+convertMipMap (T.AutoMip a b) = AutoMip a b++convertRasterContext :: T.RasterContext p -> RasterContext+convertRasterContext (T.PointCtx a b c) = PointCtx a b c+convertRasterContext (T.LineCtx a b) = LineCtx a b+convertRasterContext (T.TriangleCtx a b c d) = TriangleCtx a b c d++convertBlending :: T.Blending c -> Blending+convertBlending T.NoBlending = NoBlending+convertBlending (T.BlendLogicOp a) = BlendLogicOp a+convertBlending (T.Blend a b c) = Blend a b c++convertFetchPrimitive :: T.FetchPrimitive a -> FetchPrimitive+convertFetchPrimitive v = case v of+ T.Points -> Points+ T.Lines -> Lines+ T.Triangles -> Triangles+ T.LinesAdjacency -> LinesAdjacency+ T.TrianglesAdjacency -> TrianglesAdjacency++convertOutputPrimitive :: T.OutputPrimitive a -> OutputPrimitive+convertOutputPrimitive v = case v of+ T.TrianglesOutput -> TrianglesOutput+ T.LinesOutput -> LinesOutput+ T.PointsOutput -> PointsOutput++convertAccumulationContext :: T.AccumulationContext b -> AccumulationContext+convertAccumulationContext (T.AccumulationContext n ops) = AccumulationContext n $ cvt ops+ where+ cvt :: FlatTuple T.NoConstraint T.FragmentOperation b -> [FragmentOperation]+ cvt ZT = []+ cvt (T.DepthOp a b:.xs) = DepthOp a b : cvt xs+ cvt (T.StencilOp a b c :. xs) = StencilOp a b c : cvt xs+ cvt (T.ColorOp a b :. xs) = ColorOp (convertBlending a) (T.toValue b) : cvt xs++convertFrameBuffer :: T.FrameBuffer layerCount t -> [Image]+convertFrameBuffer = cvt+ where+ cvt :: T.FrameBuffer layerCount t -> [Image]+ cvt ZT = []+ cvt (T.DepthImage a b:.xs) = DepthImage (toInt a) b : cvt xs+ cvt (T.StencilImage a b:.xs) = StencilImage (toInt a) b : cvt xs+ cvt (T.ColorImage a b:.xs) = ColorImage (toInt a) (T.toValue b) : cvt xs
+ LC_C_PrimFun.hs view
@@ -0,0 +1,167 @@+module LC_C_PrimFun where++import qualified LC_T_PrimFun as T+import LC_U_PrimFun++convertPrimFun :: T.PrimFun a b -> PrimFun+convertPrimFun a = case a of+ -- Vec/Mat (de)construction+ T.PrimTupToV2 -> PrimTupToV2+ T.PrimTupToV3 -> PrimTupToV3+ T.PrimTupToV4 -> PrimTupToV4+ T.PrimV2ToTup -> PrimV2ToTup+ T.PrimV3ToTup -> PrimV3ToTup+ T.PrimV4ToTup -> PrimV4ToTup++ -- Arithmetic Functions (componentwise)+ T.PrimAdd -> PrimAdd + T.PrimAddS -> PrimAddS+ T.PrimSub -> PrimSub + T.PrimSubS -> PrimSubS + T.PrimMul -> PrimMul + T.PrimMulS -> PrimMulS+ T.PrimDiv -> PrimDiv + T.PrimDivS -> PrimDivS+ T.PrimNeg -> PrimNeg + T.PrimMod -> PrimMod + T.PrimModS -> PrimModS++ -- Bit-wise Functions+ T.PrimBAnd -> PrimBAnd + T.PrimBAndS -> PrimBAndS + T.PrimBOr -> PrimBOr + T.PrimBOrS -> PrimBOrS + T.PrimBXor -> PrimBXor + T.PrimBXorS -> PrimBXorS + T.PrimBNot -> PrimBNot + T.PrimBShiftL -> PrimBShiftL + T.PrimBShiftLS -> PrimBShiftLS+ T.PrimBShiftR -> PrimBShiftR + T.PrimBShiftRS -> PrimBShiftRS++ -- Logic Functions+ T.PrimAnd -> PrimAnd+ T.PrimOr -> PrimOr + T.PrimXor -> PrimXor+ T.PrimNot -> PrimNot+ T.PrimAny -> PrimAny+ T.PrimAll -> PrimAll++ -- Angle and Trigonometry Functions+ T.PrimACos -> PrimACos + T.PrimACosH -> PrimACosH + T.PrimASin -> PrimASin + T.PrimASinH -> PrimASinH + T.PrimATan -> PrimATan + T.PrimATan2 -> PrimATan2 + T.PrimATanH -> PrimATanH + T.PrimCos -> PrimCos + T.PrimCosH -> PrimCosH + T.PrimDegrees -> PrimDegrees+ T.PrimRadians -> PrimRadians+ T.PrimSin -> PrimSin + T.PrimSinH -> PrimSinH + T.PrimTan -> PrimTan + T.PrimTanH -> PrimTanH ++ -- Exponential Functions+ T.PrimPow -> PrimPow + T.PrimExp -> PrimExp + T.PrimLog -> PrimLog + T.PrimExp2 -> PrimExp2 + T.PrimLog2 -> PrimLog2 + T.PrimSqrt -> PrimSqrt + T.PrimInvSqrt -> PrimInvSqrt++ -- Common Functions+ T.PrimIsNan -> PrimIsNan + T.PrimIsInf -> PrimIsInf + T.PrimAbs -> PrimAbs + T.PrimSign -> PrimSign + T.PrimFloor -> PrimFloor + T.PrimTrunc -> PrimTrunc + T.PrimRound -> PrimRound + T.PrimRoundEven -> PrimRoundEven + T.PrimCeil -> PrimCeil + T.PrimFract -> PrimFract + T.PrimModF -> PrimModF + T.PrimMin -> PrimMin + T.PrimMinS -> PrimMinS + T.PrimMax -> PrimMax + T.PrimMaxS -> PrimMaxS + T.PrimClamp -> PrimClamp + T.PrimClampS -> PrimClampS + T.PrimMix -> PrimMix + T.PrimMixS -> PrimMixS + T.PrimMixB -> PrimMixB + T.PrimStep -> PrimStep + T.PrimStepS -> PrimStepS + T.PrimSmoothStep -> PrimSmoothStep + T.PrimSmoothStepS -> PrimSmoothStepS++ -- Integer/Float Conversion Functions+ T.PrimFloatBitsToInt -> PrimFloatBitsToInt + T.PrimFloatBitsToUInt -> PrimFloatBitsToUInt + T.PrimIntBitsToFloat -> PrimIntBitsToFloat + T.PrimUIntBitsToFloat -> PrimUIntBitsToFloat ++ -- Geometric Functions+ T.PrimLength -> PrimLength + T.PrimDistance -> PrimDistance + T.PrimDot -> PrimDot + T.PrimCross -> PrimCross + T.PrimNormalize -> PrimNormalize + T.PrimFaceForward -> PrimFaceForward+ T.PrimReflect -> PrimReflect + T.PrimRefract -> PrimRefract ++ -- Matrix Functions+ T.PrimTranspose -> PrimTranspose + T.PrimDeterminant -> PrimDeterminant + T.PrimInverse -> PrimInverse + T.PrimOuterProduct -> PrimOuterProduct+ T.PrimMulMatVec -> PrimMulMatVec + T.PrimMulVecMat -> PrimMulVecMat + T.PrimMulMatMat -> PrimMulMatMat ++ -- Vector and Scalar Relational Functions+ T.PrimLessThan -> PrimLessThan + T.PrimLessThanEqual -> PrimLessThanEqual + T.PrimGreaterThan -> PrimGreaterThan + T.PrimGreaterThanEqual -> PrimGreaterThanEqual+ T.PrimEqualV -> PrimEqualV + T.PrimEqual -> PrimEqual + T.PrimNotEqualV -> PrimNotEqualV + T.PrimNotEqual -> PrimNotEqual ++ -- Fragment Processing Functions+ T.PrimDFdx -> PrimDFdx + T.PrimDFdy -> PrimDFdy + T.PrimFWidth -> PrimFWidth++ -- Noise Functions+ T.PrimNoise1 -> PrimNoise1+ T.PrimNoise2 -> PrimNoise2+ T.PrimNoise3 -> PrimNoise3+ T.PrimNoise4 -> PrimNoise4++ -- Texture Lookup Functions+ T.PrimTextureSize -> PrimTextureSize+ T.PrimTexture -> PrimTexture+ T.PrimTextureB -> PrimTexture+ T.PrimTextureProj -> PrimTextureProj+ T.PrimTextureProjB -> PrimTextureProj+ T.PrimTextureLod -> PrimTextureLod+ T.PrimTextureOffset -> PrimTextureOffset+ T.PrimTextureOffsetB -> PrimTextureOffset+ T.PrimTexelFetch -> PrimTexelFetch+ T.PrimTexelFetchOffset -> PrimTexelFetchOffset+ T.PrimTextureProjOffset -> PrimTextureProjOffset+ T.PrimTextureProjOffsetB -> PrimTextureProjOffset+ T.PrimTextureLodOffset -> PrimTextureLodOffset+ T.PrimTextureProjLod -> PrimTextureProjLod+ T.PrimTextureProjLodOffset -> PrimTextureProjLodOffset+ T.PrimTextureGrad -> PrimTextureGrad+ T.PrimTextureGradOffset -> PrimTextureGradOffset+ T.PrimTextureProjGrad -> PrimTextureProjGrad+ T.PrimTextureProjGradOffset -> PrimTextureProjGradOffset
+ LC_G_APIType.hs view
@@ -0,0 +1,394 @@+module LC_G_APIType where++import Data.Int+import Data.Word+import Foreign.Ptr++import LC_G_Type++import Graphics.Rendering.OpenGL.Raw.Core32 (GLuint)++data TextureData+ = TextureData+ { textureObject :: GLuint+ }++data Primitive+ = TriangleStrip+ | TriangleList+ | TriangleFan+ | LineStrip+ | LineList+ | PointList+ | TriangleStripAdjacency+ | TriangleListAdjacency+ | LineStripAdjacency+ | LineListAdjacency+ deriving (Eq,Ord,Bounded,Enum,Show)++-- GPU type value reification, needed for shader codegen+data Value+ = VBool !Bool+ | VV2B !V2B+ | VV3B !V3B+ | VV4B !V4B+ | VWord !Word32+ | VV2U !V2U+ | VV3U !V3U+ | VV4U !V4U+ | VInt !Int32+ | VV2I !V2I+ | VV3I !V3I+ | VV4I !V4I+ | VFloat !Float+ | VV2F !V2F+ | VV3F !V3F+ | VV4F !V4F+ | VM22F !M22F+ | VM23F !M23F+ | VM24F !M24F+ | VM32F !M32F+ | VM33F !M33F+ | VM34F !M34F+ | VM42F !M42F+ | VM43F !M43F+ | VM44F !M44F+ deriving (Show,Eq,Ord)++type SetterFun a = a -> IO ()++-- user will provide scalar input data via this type+data InputSetter+ = SBool (SetterFun Bool)+ | SV2B (SetterFun V2B)+ | SV3B (SetterFun V3B)+ | SV4B (SetterFun V4B)+ | SWord (SetterFun Word32)+ | SV2U (SetterFun V2U)+ | SV3U (SetterFun V3U)+ | SV4U (SetterFun V4U)+ | SInt (SetterFun Int32)+ | SV2I (SetterFun V2I)+ | SV3I (SetterFun V3I)+ | SV4I (SetterFun V4I)+ | SFloat (SetterFun Float)+ | SV2F (SetterFun V2F)+ | SV3F (SetterFun V3F)+ | SV4F (SetterFun V4F)+ | SM22F (SetterFun M22F)+ | SM23F (SetterFun M23F)+ | SM24F (SetterFun M24F)+ | SM32F (SetterFun M32F)+ | SM33F (SetterFun M33F)+ | SM34F (SetterFun M34F)+ | SM42F (SetterFun M42F)+ | SM43F (SetterFun M43F)+ | SM44F (SetterFun M44F)+ -- shadow textures+ | SSTexture1D+ | SSTexture2D+ | SSTextureCube+ | SSTexture1DArray+ | SSTexture2DArray+ | SSTexture2DRect+ -- float textures+ | SFTexture1D+ | SFTexture2D (SetterFun TextureData)+ | SFTexture3D+ | SFTextureCube+ | SFTexture1DArray+ | SFTexture2DArray+ | SFTexture2DMS+ | SFTexture2DMSArray+ | SFTextureBuffer+ | SFTexture2DRect+ -- int textures+ | SITexture1D+ | SITexture2D+ | SITexture3D+ | SITextureCube+ | SITexture1DArray+ | SITexture2DArray+ | SITexture2DMS+ | SITexture2DMSArray+ | SITextureBuffer+ | SITexture2DRect+ -- uint textures+ | SUTexture1D+ | SUTexture2D+ | SUTexture3D+ | SUTextureCube+ | SUTexture1DArray+ | SUTexture2DArray+ | SUTexture2DMS+ | SUTexture2DMSArray+ | SUTextureBuffer+ | SUTexture2DRect++-- buffer handling+{-+ user can fills a buffer (continuous memory region)+ each buffer have a data descriptor, what describes the+ buffer content. e.g. a buffer can contain more arrays of stream types+-}++-- user will provide stream data using this setup function+type BufferSetter = (Ptr () -> IO ()) -> IO ()++-- specifies array component type (stream type in storage side)+-- this type can be overridden in GPU side, e.g ArrWord8 can be seen as TFloat or TWord also+data ArrayType+ = ArrWord8+ | ArrWord16+ | ArrWord32+ | ArrInt8+ | ArrInt16+ | ArrInt32+ | ArrFloat+ | ArrHalf -- Hint: half float is not supported in haskell+ deriving (Show,Eq,Ord)++sizeOfArrayType :: ArrayType -> Int+sizeOfArrayType ArrWord8 = 1+sizeOfArrayType ArrWord16 = 2+sizeOfArrayType ArrWord32 = 4+sizeOfArrayType ArrInt8 = 1+sizeOfArrayType ArrInt16 = 2+sizeOfArrayType ArrInt32 = 4+sizeOfArrayType ArrFloat = 4+sizeOfArrayType ArrHalf = 2++-- describes an array in a buffer+data Array -- array type, element count (NOT byte size!), setter+ = Array ArrayType Int BufferSetter++-- 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 (Show,Eq,Ord)++data Ty+ = Single !InputType+ | Tuple [Ty]+ | FrameBuffer'+ | Image'+ | PrimitiveStream'+ | VertexStream'+ | FragmentStream'+ | Unknown String+ deriving (Show,Eq,Ord)++tySize :: Ty -> Int+tySize (Tuple a) = sum $ map tySize a+tySize _ = 1++-- describes a stream type (in GPU side)+data InputType+ = Bool+ | V2B+ | V3B+ | V4B+ | Word+ | V2U+ | V3U+ | V4U+ | Int+ | V2I+ | V3I+ | V4I+ | Float+ | V2F+ | V3F+ | V4F+ | M22F+ | M23F+ | M24F+ | M32F+ | M33F+ | M34F+ | M42F+ | M43F+ | M44F+ -- shadow textures+ | STexture1D+ | STexture2D+ | STextureCube+ | STexture1DArray+ | STexture2DArray+ | STexture2DRect+ -- float textures+ | FTexture1D+ | FTexture2D+ | FTexture3D+ | FTextureCube+ | FTexture1DArray+ | FTexture2DArray+ | FTexture2DMS+ | FTexture2DMSArray+ | FTextureBuffer+ | FTexture2DRect+ -- int textures+ | ITexture1D+ | ITexture2D+ | ITexture3D+ | ITextureCube+ | ITexture1DArray+ | ITexture2DArray+ | ITexture2DMS+ | ITexture2DMSArray+ | ITextureBuffer+ | ITexture2DRect+ -- uint textures+ | UTexture1D+ | UTexture2D+ | UTexture3D+ | UTextureCube+ | UTexture1DArray+ | UTexture2DArray+ | UTexture2DMS+ | UTexture2DMSArray+ | UTextureBuffer+ | UTexture2DRect+ deriving (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+ }++data PointSpriteCoordOrigin = LowerLeft | UpperLeft deriving (Show, Eq, Ord)+data PointSize = PointSize Float | ProgramPointSize deriving (Eq,Ord,Show)+data PolygonOffset = NoOffset | Offset Float Float deriving (Eq,Ord,Show)+data FrontFace = CCW | CW deriving (Eq,Ord,Show)+data PolygonMode = PolygonPoint PointSize | PolygonLine Float | PolygonFill deriving (Eq,Ord,Show)+data ProvokingVertex = FirstVertex | LastVertex deriving (Eq,Ord,Bounded,Enum,Show)+data CullMode = CullNone | CullFront FrontFace | CullBack FrontFace deriving (Eq,Ord,Show)+type DepthFunction = ComparisonFunction+data ComparisonFunction = Never | Less | Equal | Lequal | Greater | Notequal | Gequal | Always deriving ( Eq, Ord, Show )+data StencilOperation = OpZero | OpKeep | OpReplace | OpIncr | OpIncrWrap | OpDecr | OpDecrWrap | OpInvert deriving ( Eq, Ord, Show )+data BlendEquation = FuncAdd | FuncSubtract | FuncReverseSubtract | Min | Max deriving ( Eq, Ord, Show )+data BlendingFactor = Zero | One | SrcColor | OneMinusSrcColor | DstColor | OneMinusDstColor | SrcAlpha | OneMinusSrcAlpha | DstAlpha | OneMinusDstAlpha | ConstantColor | OneMinusConstantColor | ConstantAlpha | OneMinusConstantAlpha | SrcAlphaSaturate deriving ( Eq, Ord, Show )+data LogicOperation = Clear | And | AndReverse | Copy | AndInverted | Noop | Xor | Or | Nor | Equiv | Invert | OrReverse | CopyInverted | OrInverted | Nand | Set deriving ( Eq, Ord, Show )++data StencilOps+ = StencilOps+ { frontStencilOp :: StencilOperation -- ^ Used for front faced triangles and other primitives.+ , backStencilOp :: StencilOperation -- ^ Used for back faced triangles.+ } deriving (Eq,Ord,Show)++data StencilTests = StencilTests StencilTest StencilTest deriving (Eq,Ord,Show)+data StencilTest+ = StencilTest+ { stencilComparision :: ComparisonFunction -- ^ The function used to compare the @stencilReference@ and the stencil buffers value with.+ , stencilReference :: Int32 -- ^ The value to compare with the stencil buffer's value.+ , stencilMask :: Word32 -- ^ A bit mask with ones in each position that should be compared and written to the stencil buffer.+ } deriving (Eq,Ord,Show)++-- sampler and texture specification+data Filter = PointFilter | LinearFilter deriving (Show,Eq,Ord)+data EdgeMode = Repeat | MirroredRepeat | ClampToEdge | ClampToBorder deriving (Show,Eq,Ord)
+ LC_G_Type.hs view
@@ -0,0 +1,240 @@+module LC_G_Type where++import GHC.TypeLits++import Data.Int+import Data.Word+import Foreign.Storable+import Foreign.Ptr++data V2 a = V2 !a !a deriving (Eq,Ord,Show)+data V3 a = V3 !a !a !a deriving (Eq,Ord,Show)+data V4 a = V4 !a !a !a !a deriving (Eq,Ord,Show)++-- matrices are stored in column major order+type M22F = V2 V2F+type M23F = V3 V2F+type M24F = V4 V2F+type M32F = V2 V3F+type M33F = V3 V3F+type M34F = V4 V3F+type M42F = V2 V4F+type M43F = V3 V4F+type M44F = V4 V4F++type V2F = V2 Float+type V3F = V3 Float+type V4F = V4 Float+type V2I = V2 Int32+type V3I = V3 Int32+type V4I = V4 Int32+type V2U = V2 Word32+type V3U = V3 Word32+type V4U = V4 Word32+type V2B = V2 Bool+type V3B = V3 Bool+type V4B = V4 Bool++-- vector types: V2, V3, V4+class IsVec (dim :: Nat) vec component | vec -> dim component, dim component -> vec+instance IsVec 2 (V2 Float) Float+instance IsVec 3 (V3 Float) Float+instance IsVec 4 (V4 Float) Float+instance IsVec 2 (V2 Int32) Int32+instance IsVec 3 (V3 Int32) Int32+instance IsVec 4 (V4 Int32) Int32+instance IsVec 2 (V2 Word32) Word32+instance IsVec 3 (V3 Word32) Word32+instance IsVec 4 (V4 Word32) Word32+instance IsVec 2 (V2 Bool) Bool+instance IsVec 3 (V3 Bool) Bool+instance IsVec 4 (V4 Bool) Bool++-- scalar and vector types: scalar, V2, V3, V4+class IsVecScalar (dim :: Nat) vec component | vec -> dim component, dim component -> vec+instance IsVecScalar 1 Float Float+instance IsVecScalar 2 (V2 Float) Float+instance IsVecScalar 3 (V3 Float) Float+instance IsVecScalar 4 (V4 Float) Float+instance IsVecScalar 1 Int32 Int32+instance IsVecScalar 2 (V2 Int32) Int32+instance IsVecScalar 3 (V3 Int32) Int32+instance IsVecScalar 4 (V4 Int32) Int32+instance IsVecScalar 1 Word32 Word32+instance IsVecScalar 2 (V2 Word32) Word32+instance IsVecScalar 3 (V3 Word32) Word32+instance IsVecScalar 4 (V4 Word32) Word32+instance IsVecScalar 1 Bool Bool+instance IsVecScalar 2 (V2 Bool) Bool+instance IsVecScalar 3 (V3 Bool) Bool+instance IsVecScalar 4 (V4 Bool) Bool++-- matrix types of dimension [2..4] x [2..4]+class IsMat mat h w | mat -> h w+instance IsMat M22F V2F V2F+instance IsMat M23F V2F V3F+instance IsMat M24F V2F V4F+instance IsMat M32F V3F V2F+instance IsMat M33F V3F V3F+instance IsMat M34F V3F V4F+instance IsMat M42F V4F V2F+instance IsMat M43F V4F V3F+instance IsMat M44F V4F V4F++-- matrix, vector and scalar types+class IsMatVecScalar a t | a -> t+instance IsMatVecScalar Float Float+instance IsMatVecScalar (V2 Float) Float+instance IsMatVecScalar (V3 Float) Float+instance IsMatVecScalar (V4 Float) Float+instance IsMatVecScalar Int32 Int32+instance IsMatVecScalar (V2 Int32) Int32+instance IsMatVecScalar (V3 Int32) Int32+instance IsMatVecScalar (V4 Int32) Int32+instance IsMatVecScalar Word32 Word32+instance IsMatVecScalar (V2 Word32) Word32+instance IsMatVecScalar (V3 Word32) Word32+instance IsMatVecScalar (V4 Word32) Word32+instance IsMatVecScalar Bool Bool+instance IsMatVecScalar (V2 Bool) Bool+instance IsMatVecScalar (V3 Bool) Bool+instance IsMatVecScalar (V4 Bool) Bool+instance IsMatVecScalar M22F Float+instance IsMatVecScalar M23F Float+instance IsMatVecScalar M24F Float+instance IsMatVecScalar M32F Float+instance IsMatVecScalar M33F Float+instance IsMatVecScalar M34F Float+instance IsMatVecScalar M42F Float+instance IsMatVecScalar M43F Float+instance IsMatVecScalar M44F Float++-- matrix and vector types+class IsMatVec a t | a -> t+instance IsMatVec (V2 Float) Float+instance IsMatVec (V3 Float) Float+instance IsMatVec (V4 Float) Float+instance IsMatVec (V2 Int32) Int32+instance IsMatVec (V3 Int32) Int32+instance IsMatVec (V4 Int32) Int32+instance IsMatVec (V2 Word32) Word32+instance IsMatVec (V3 Word32) Word32+instance IsMatVec (V4 Word32) Word32+instance IsMatVec (V2 Bool) Bool+instance IsMatVec (V3 Bool) Bool+instance IsMatVec (V4 Bool) Bool+instance IsMatVec M22F Float+instance IsMatVec M23F Float+instance IsMatVec M24F Float+instance IsMatVec M32F Float+instance IsMatVec M33F Float+instance IsMatVec M34F Float+instance IsMatVec M42F Float+instance IsMatVec M43F Float+instance IsMatVec M44F Float++-- matrix or vector component type+class IsComponent a+instance IsComponent Float+instance IsComponent Int32+instance IsComponent Word32+instance IsComponent Bool+instance IsComponent V2F+instance IsComponent V3F+instance IsComponent V4F++-- matrix or vector number component type+class IsNumComponent a+instance IsNumComponent Float+instance IsNumComponent Int32+instance IsNumComponent Word32+instance IsNumComponent V2F+instance IsNumComponent V3F+instance IsNumComponent V4F++class IsSigned a+instance IsSigned Float+instance IsSigned Int++class Real a => IsNum a+instance IsNum Float+instance IsNum Int32+instance IsNum Word32++class IsIntegral a+instance IsIntegral Int32+instance IsIntegral Word32++class IsFloating a+instance IsFloating Float+instance IsFloating V2F+instance IsFloating V3F+instance IsFloating V4F+instance IsFloating M22F+instance IsFloating M23F+instance IsFloating M24F+instance IsFloating M32F+instance IsFloating M33F+instance IsFloating M34F+instance IsFloating M42F+instance IsFloating M43F+instance IsFloating M44F+++-- 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
+ LC_Mesh.hs view
@@ -0,0 +1,187 @@+module LC_Mesh (+ loadMesh,+ saveMesh,+ addMesh,+ compileMesh,+ 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 LC_API++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)++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
+ LC_T_APIType.hs view
@@ -0,0 +1,518 @@+{-# LANGUAGE UndecidableInstances #-}+module LC_T_APIType where++import GHC.TypeLits++import Data.ByteString.Char8+import Data.Int+import Data.Word++import LC_G_Type+import LC_G_APIType hiding (InputType(..))+import LC_G_APIType (InputType)+import qualified LC_G_APIType as U+import qualified LC_U_APIType as U+import LC_T_DSLType hiding (Shadow)+import qualified LC_T_DSLType as T++data NatNum :: Nat -> * where+ N0 :: NatNum 0+ N1 :: NatNum 1+ N2 :: NatNum 2+ N3 :: NatNum 3+ N4 :: NatNum 4+ N5 :: NatNum 5+ N6 :: NatNum 6+ N7 :: NatNum 7+ N8 :: NatNum 8+ N9 :: NatNum 9++n0 = N0+n1 = N1+n2 = N2+n3 = N3+n4 = N4+n5 = N5+n6 = N6+n7 = N7+n8 = N8+n9 = N9++-- user can define stream input using InputTuple type class+class InputTuple tup where+ type InputTupleRepr tup+ toInputList :: tup -> [(ByteString,InputType)]++instance InputTuple (Input a) where+ type InputTupleRepr (Input a) = a+ toInputList a = [toInput a]++instance InputTuple (Input a, Input b) where+ type InputTupleRepr (Input a, Input b) = (a, b)+ toInputList (a, b) = [toInput a, toInput b]++instance InputTuple (Input a, Input b, Input c) where+ type InputTupleRepr (Input a, Input b, Input c) = (a, b, c)+ toInputList (a, b, c) = [toInput a, toInput b, toInput c]++instance InputTuple (Input a, Input b, Input c, Input d) where+ type InputTupleRepr (Input a, Input b, Input c, Input d) = (a, b, c, d)+ toInputList (a, b, c, d) = [toInput a, toInput b, toInput c, toInput d]++instance InputTuple (Input a, Input b, Input c, Input d, Input e) where+ type InputTupleRepr (Input a, Input b, Input c, Input d, Input e) = (a, b, c, d, e)+ toInputList (a, b, c, d, e) = [toInput a, toInput b, toInput c, toInput d, toInput e]++instance InputTuple (Input a, Input b, Input c, Input d, Input e, Input f) where+ type InputTupleRepr (Input a, Input b, Input c, Input d, Input e, Input f) = (a, b, c, d, e, f)+ toInputList (a, b, c, d, e, f) = [toInput a, toInput b, toInput c, toInput d, toInput e, toInput f]++instance InputTuple (Input a, Input b, Input c, Input d, Input e, Input f, Input g) where+ type InputTupleRepr (Input a, Input b, Input c, Input d, Input e, Input f, Input g) = (a, b, c, d, e, f, g)+ toInputList (a, b, c, d, e, f, g) = [toInput a, toInput b, toInput c, toInput d, toInput e, toInput f, toInput g]++instance InputTuple (Input a, Input b, Input c, Input d, Input e, Input f, Input g, Input h) where+ type InputTupleRepr (Input a, Input b, Input c, Input d, Input e, Input f, Input g, Input h) = (a, b, c, d, e, f, g, h)+ toInputList (a, b, c, d, e, f, g, h) = [toInput a, toInput b, toInput c, toInput d, toInput e, toInput f, toInput g, toInput h]++instance InputTuple (Input a, Input b, Input c, Input d, Input e, Input f, Input g, Input h, Input i) where+ type InputTupleRepr (Input a, Input b, Input c, Input d, Input e, Input f, Input g, Input h, Input i) = (a, b, c, d, e, f, g, h, i)+ toInputList (a, b, c, d, e, f, g, h, i) = [toInput a, toInput b, toInput c, toInput d, toInput e, toInput f, toInput g, toInput h, toInput i]++-- we should define all of input types+-- supported stream input types (the ByteString argument is the input slot name)+data Input a where+ IBool :: ByteString -> Input Bool+ IV2B :: ByteString -> Input V2B+ IV3B :: ByteString -> Input V3B+ IV4B :: ByteString -> Input V4B+ IWord :: ByteString -> Input Word32+ IV2U :: ByteString -> Input V2U+ IV3U :: ByteString -> Input V3U+ IV4U :: ByteString -> Input V4U+ IInt :: ByteString -> Input Int32+ IV2I :: ByteString -> Input V2I+ IV3I :: ByteString -> Input V3I+ IV4I :: ByteString -> Input V4I+ IFloat :: ByteString -> Input Float+ IV2F :: ByteString -> Input V2F+ IV3F :: ByteString -> Input V3F+ IV4F :: ByteString -> Input V4F+ IM22F :: ByteString -> Input M22F+ IM23F :: ByteString -> Input M23F+ IM24F :: ByteString -> Input M24F+ IM32F :: ByteString -> Input M32F+ IM33F :: ByteString -> Input M33F+ IM34F :: ByteString -> Input M34F+ IM42F :: ByteString -> Input M42F+ IM43F :: ByteString -> Input M43F+ IM44F :: ByteString -> Input M44F++toInput :: Input a -> (ByteString,InputType)+toInput (IBool n) = (n, U.Bool)+toInput (IV2B n) = (n, U.V2B)+toInput (IV3B n) = (n, U.V3B)+toInput (IV4B n) = (n, U.V4B)+toInput (IWord n) = (n, U.Word)+toInput (IV2U n) = (n, U.V2U)+toInput (IV3U n) = (n, U.V3U)+toInput (IV4U n) = (n, U.V4U)+toInput (IInt n) = (n, U.Int)+toInput (IV2I n) = (n, U.V2I)+toInput (IV3I n) = (n, U.V3I)+toInput (IV4I n) = (n, U.V4I)+toInput (IFloat n) = (n, U.Float)+toInput (IV2F n) = (n, U.V2F)+toInput (IV3F n) = (n, U.V3F)+toInput (IV4F n) = (n, U.V4F)+toInput (IM22F n) = (n, U.M22F)+toInput (IM23F n) = (n, U.M23F)+toInput (IM24F n) = (n, U.M24F)+toInput (IM32F n) = (n, U.M32F)+toInput (IM33F n) = (n, U.M33F)+toInput (IM34F n) = (n, U.M34F)+toInput (IM42F n) = (n, U.M42F)+toInput (IM43F n) = (n, U.M43F)+toInput (IM44F n) = (n, U.M44F)++-- primitive types+data PrimitiveType+ = Triangle+ | Line+ | Point+ | TriangleAdjacency+ | LineAdjacency++data FetchPrimitive :: PrimitiveType -> * where+ Points :: FetchPrimitive Point+ Lines :: FetchPrimitive Line+ Triangles :: FetchPrimitive Triangle+ LinesAdjacency :: FetchPrimitive LineAdjacency+ TrianglesAdjacency :: FetchPrimitive TriangleAdjacency++data OutputPrimitive :: PrimitiveType -> * where+ TrianglesOutput :: OutputPrimitive Triangle+ LinesOutput :: OutputPrimitive Line+ PointsOutput :: OutputPrimitive Point++data Blending c where+ NoBlending :: Blending c++ BlendLogicOp :: IsIntegral c+ => LogicOperation+ -> Blending c++ -- FIXME: restrict BlendingFactor at some BlendEquation+ Blend :: (BlendEquation, BlendEquation) + -> ((BlendingFactor, BlendingFactor), (BlendingFactor, BlendingFactor))+ -> V4F+ -> Blending Float++blend = Blend (FuncAdd,FuncAdd) ((SrcAlpha,OneMinusSrcAlpha),(SrcAlpha,OneMinusSrcAlpha)) (V4 1 1 1 1)++-- abstract types, used in language AST+data VertexStream (primitive :: PrimitiveType) t+data PrimitiveStream (primitive :: PrimitiveType) clipDistances (layerCount :: Nat) (freq :: Frequency) t+data FragmentStream (layerCount :: Nat) t+++-- flat tuple, another internal tuple representation++-- means unit+data ZZ = ZZ deriving (Show)++-- used for tuple type description+infixr 1 :+:+data tail :+: head = !tail :+: !head deriving (Show)++-- used for tuple value description+infixr 1 :.+data FlatTuple c a t where+ ZT :: FlatTuple c a ZZ++ (:.) :: c t+ => a t+ -> FlatTuple c a t'+ -> FlatTuple c a (t :+: t')++class IsFloatTuple a+instance IsFloatTuple ZZ+instance IsFloatTuple l => IsFloatTuple (Float :+: l)++-- vertex attribute interpolation+data Interpolated e a where+ Flat :: e a -> Interpolated e a++ Smooth :: IsFloating a+ => e a -> Interpolated e a++ NoPerspective :: IsFloating a+ => e a -> Interpolated e a++-- framebuffer data / fragment output semantic+data Color a+data Depth a+data Stencil a++-- describe geometry shader input +type family PrimitiveVertices (primitive :: PrimitiveType) a+type instance PrimitiveVertices Point a = a+type instance PrimitiveVertices Line a = (a,a)+type instance PrimitiveVertices LineAdjacency a = (a,a,a,a)+type instance PrimitiveVertices Triangle a = (a,a,a)+type instance PrimitiveVertices TriangleAdjacency a = (a,a,a,a,a,a)++-- raster context description+data RasterContext t where+ PointCtx ::+ { ctxPointSize :: PointSize+ , ctxFadeThresholdSize :: Float+ , ctxSpriteCoordOrigin :: PointSpriteCoordOrigin+ } -> RasterContext Point++ LineCtx :: + { ctxLineWidth :: Float+ , ctxProvokingVertex' :: ProvokingVertex+ } -> RasterContext Line++ TriangleCtx ::+ { ctxCullMode :: CullMode+ , ctxPolygonMode :: PolygonMode+ , ctxPolygonOffset :: PolygonOffset+ , ctxProvokingVertex :: ProvokingVertex+ } -> RasterContext Triangle++-- default triangle raster context+triangleCtx :: RasterContext Triangle+triangleCtx = TriangleCtx CullNone PolygonFill NoOffset LastVertex++class NoConstraint a+instance NoConstraint a++type FrameBuffer layerCount t = FlatTuple NoConstraint (Image layerCount) t+data AccumulationContext t+ = AccumulationContext+ { accViewportName :: Maybe ByteString+ , accOperations :: FlatTuple NoConstraint FragmentOperation t+ }++-- Fragment Operation+data FragmentOperation ty where+ DepthOp :: DepthFunction+ -> Bool -- depth write+ -> FragmentOperation (Depth Float)++ StencilOp :: StencilTests+ -> StencilOps+ -> StencilOps+ -> FragmentOperation (Stencil Int32)++ ColorOp :: (IsVecScalar d mask Bool, IsVecScalar d color c, IsNum c, IsScalar mask)+ => Blending c -- blending type+ -> mask -- write mask+ -> FragmentOperation (Color color)++-- specifies an empty image (pixel rectangle)+-- hint: framebuffer is composed from images+data Image (layerCount :: Nat) t where+ DepthImage :: SingI layerCount+ => NatNum layerCount+ -> Float -- initial value+ -> Image layerCount (Depth Float)++ StencilImage :: SingI layerCount+ => NatNum layerCount+ -> Int32 -- initial value+ -> Image layerCount (Stencil Int32)++ ColorImage :: (IsNum t, IsVecScalar d color t, IsScalar color, SingI layerCount)+ => NatNum layerCount+ -> color -- initial value+ -> Image layerCount (Color color)++-- restriction for framebuffer structure according content semantic+-- supported configurations: optional stencil + optional depth + [zero or more color]+class IsColorOutput a+instance IsColorOutput ZZ+instance (IsColorOutput b) => IsColorOutput (Color c :+: b)++class IsValidOutput a+instance (IsColorOutput a) => IsValidOutput (Color c :+: a)+instance (IsColorOutput a) => IsValidOutput (Depth d :+: a)+instance (IsColorOutput a) => IsValidOutput (Stencil s :+: a)+instance (IsColorOutput a) => IsValidOutput (Stencil s :+: Depth d :+: a)++-- helper class (type level function), used in language AST+-- converts FlatTuple type to ordinary tuple type+type family FTRepr a :: *+type instance FTRepr ZZ = ()+type instance FTRepr (a :+: ZZ) = a+type instance FTRepr (a :+: b :+: ZZ) = (a, b)+type instance FTRepr (a :+: b :+: c :+: ZZ) = (a, b, c)+type instance FTRepr (a :+: b :+: c :+: d :+: ZZ) = (a, b, c, d)+type instance FTRepr (a :+: b :+: c :+: d :+: e :+: ZZ) = (a, b, c, d, e)+type instance FTRepr (a :+: b :+: c :+: d :+: e :+: f :+: ZZ) = (a, b, c, d, e, f)+type instance FTRepr (a :+: b :+: c :+: d :+: e :+: f :+: g :+: ZZ) = (a, b, c, d, e, f, g)+type instance FTRepr (a :+: b :+: c :+: d :+: e :+: f :+: g :+: h :+: ZZ) = (a, b, c, d, e, f, g, h)+type instance FTRepr (a :+: b :+: c :+: d :+: e :+: f :+: g :+: h :+: i :+: ZZ) = (a, b, c, d, e, f, g, h, i)++-- helper type level function, used in language AST+type family FTRepr' a :: *+type instance FTRepr' (i1 a :+: ZZ) = a+type instance FTRepr' (i1 a :+: i2 b :+: ZZ) = (a, b)+type instance FTRepr' (i1 a :+: i2 b :+: i3 c :+: ZZ) = (a, b, c)+type instance FTRepr' (i1 a :+: i2 b :+: i3 c :+: i4 d :+: ZZ) = (a, b, c, d)+type instance FTRepr' (i1 a :+: i2 b :+: i3 c :+: i4 d :+: i5 e :+: ZZ) = (a, b, c, d, e)+type instance FTRepr' (i1 a :+: i2 b :+: i3 c :+: i4 d :+: i5 e :+: i6 f :+: ZZ) = (a, b, c, d, e, f)+type instance FTRepr' (i1 a :+: i2 b :+: i3 c :+: i4 d :+: i5 e :+: i6 f :+: i7 g :+: ZZ) = (a, b, c, d, e, f, g)+type instance FTRepr' (i1 a :+: i2 b :+: i3 c :+: i4 d :+: i5 e :+: i6 f :+: i7 g :+: i8 h :+: ZZ) = (a, b, c, d, e, f, g, h)+type instance FTRepr' (i1 a :+: i2 b :+: i3 c :+: i4 d :+: i5 e :+: i6 f :+: i7 g :+: i8 h :+: i9 i :+: ZZ) = (a, b, c, d, e, f, g, h ,i)++-- helper type level function, used in language AST+type family ColorRepr a :: *+type instance ColorRepr ZZ = ZZ+type instance ColorRepr (a :+: b) = Color a :+: (ColorRepr b)++-- helper type level function, used in language AST+type family NoStencilRepr a :: *+type instance NoStencilRepr ZZ = ZZ+type instance NoStencilRepr (Stencil a :+: b) = NoStencilRepr b+type instance NoStencilRepr (Color a :+: b) = Color a :+: (NoStencilRepr b)+type instance NoStencilRepr (Depth a :+: b) = Depth a :+: (NoStencilRepr b)++-- sampler and texture specification+data TextureMipMap+ = TexMip+ | TexNoMip++data MipMap (t :: TextureMipMap) where+ NoMip :: MipMap TexNoMip++ Mip :: Int -- base level+ -> Int -- max level+ -> MipMap TexMip++ AutoMip :: Int -- base level+ -> Int -- max level+ -> MipMap TexMip++-- helper type level function, used in language AST+type family TexDataRepr arity (t :: TextureSemantics *)+type instance TexDataRepr Red (v a) = a+type instance TexDataRepr RG (v a) = V2 a+type instance TexDataRepr RGB (v a) = V3 a+type instance TexDataRepr RGBA (v a) = V4 a++-- describes texel (texture component) type+data TextureDataType (kind :: TextureSemantics *) arity where+ Float :: IsColorArity a+ => a+ -> TextureDataType (Regular Float) a++ Int :: IsColorArity a+ => a+ -> TextureDataType (Regular Int) a++ Word :: IsColorArity a+ => a+ -> TextureDataType (Regular Word) a++ Shadow :: TextureDataType (T.Shadow Float) Red -- TODO: add params required by shadow textures+++-- helper type level function for texture specification+-- tells whether a texture is a single or an array texture+type family TexArrRepr (a :: Nat) :: TextureArray+{-+type instance TexArrRepr 1 = SingleTex+type instance TexArrRepr ((2 <= t) => t) = ArrayTex+-}+-- FIXME: implement properly+type instance TexArrRepr 1 = SingleTex+type instance TexArrRepr 2 = ArrayTex+type instance TexArrRepr 3 = ArrayTex+type instance TexArrRepr 4 = ArrayTex+type instance TexArrRepr 5 = ArrayTex+type instance TexArrRepr 6 = ArrayTex+type instance TexArrRepr 7 = ArrayTex+type instance TexArrRepr 8 = ArrayTex+type instance TexArrRepr 9 = ArrayTex++-- supported texture component arities+class IsColorArity a where+ toColorArity :: a -> U.ColorArity++instance IsColorArity Red where+ toColorArity _ = U.Red+instance IsColorArity RG where+ toColorArity _ = U.RG+instance IsColorArity RGB where+ toColorArity _ = U.RGB+instance IsColorArity RGBA where+ toColorArity _ = U.RGBA++-- component arity specification (Red,RG,RGB,RGBA)+-- hint: there is an interference with Shadow component format+-- alternatives:+-- A: move Shadow from TextureDataType to TextureType, this will introduce some new TextureType constructors (1D,2D,Cube,Rect)+-- B: restrict ColorArity for Shadow+-- C: add color arity definition to TextureDataType, this will solve the problem (best solution)++-- fully describes a texture type+data TextureType :: TextureShape -> TextureMipMap -> TextureArray -> Nat -> TextureSemantics * -> * -> * where -- hint: arr - single or array texture, ar - arity (Red,RG,RGB,..)+ Texture1D :: SingI layerCount+ => TextureDataType t ar+ -> NatNum layerCount+ -> TextureType Tex1D TexMip (TexArrRepr layerCount) layerCount t ar++ Texture2D :: SingI layerCount+ => TextureDataType t ar+ -> NatNum layerCount+ -> TextureType Tex2D TexMip (TexArrRepr layerCount) layerCount t ar++ Texture3D :: TextureDataType (Regular t) ar+ -> TextureType Tex3D TexMip SingleTex 1 (Regular t) ar++ TextureCube :: TextureDataType t ar+ -> TextureType Tex2D TexMip CubeTex 6 t ar++ TextureRect :: TextureDataType t ar+ -> TextureType TexRect TexNoMip SingleTex 1 t ar++ Texture2DMS :: SingI layerCount+ => TextureDataType (Regular t) ar+ -> NatNum layerCount+ -> TextureType Tex2D TexNoMip (TexArrRepr layerCount) layerCount (MultiSample t) ar++ TextureBuffer :: TextureDataType (Regular t) ar+ -> TextureType Tex1D TexNoMip SingleTex 1 (Buffer t) ar+++-- defines a texture+data Texture (gp :: * -> *) (dim :: TextureShape) (arr :: TextureArray) (t :: TextureSemantics *) ar where+ TextureSlot :: (IsValidTextureSlot t)+ => ByteString -- texture slot name+ -> TextureType dim mip arr layerCount t ar+ -> Texture gp dim arr t ar+ -- TODO:+ -- add texture internal format specification+ Texture :: (IsScalar (TexSizeRepr dim), IsMipValid canMip mip)+ => TextureType dim canMip arr layerCount t ar+ -> TexSizeRepr dim+ -> MipMap mip+-- -> TexRepr dim mip gp layerCount (TexDataRepr ar t) -- FIXME: for cube it will give wrong type+ -> [gp (Image layerCount (TexDataRepr ar t))]+ -> Texture gp dim arr t ar+{-+ -- TODO:+ -- swizzling (arity conversion)+ -- integral -> floating casting (floating -> integral casting if possible)+ ConvertTexture :: Texture gp dim arr t ar+ -> Texture gp dim arr t' ar'+-}++-- MipMap validation+class IsMipValid (canMip :: TextureMipMap) (mip :: TextureMipMap)+instance IsMipValid TexMip TexMip+instance IsMipValid TexMip TexNoMip+instance IsMipValid TexNoMip TexNoMip++-- restriction for texture types what can be specified as texture slots, e.g. multisample textures cannot be created im this way+class IsValidTextureSlot (a :: TextureSemantics *)+instance IsValidTextureSlot (Regular a)+instance IsValidTextureSlot (T.Shadow a)+instance IsValidTextureSlot (Buffer a)++-- type level hepler function, used for texture specification+type family TexSizeRepr (a :: TextureShape)+type instance TexSizeRepr (Tex1D) = Word32+type instance TexSizeRepr (Tex2D) = V2U+type instance TexSizeRepr (TexRect) = V2U+type instance TexSizeRepr (Tex3D) = V3U+{-+-- type level hepler function, used for texture specification+type family TexRepr dim mip (gp :: * -> *) layerCount t :: *+type instance TexRepr DIM1 NoMip gp layerCount t = gp (Image layerCount t)+type instance TexRepr DIM1 AutoMip gp layerCount t = gp (Image layerCount t)+type instance TexRepr DIM1 Mip gp layerCount t = [gp (Image layerCount t)]++type instance TexRepr DIM2 NoMip gp layerCount t = gp (Image layerCount t)+type instance TexRepr DIM2 AutoMip gp layerCount t = gp (Image layerCount t)+type instance TexRepr DIM2 Mip gp layerCount t = [gp (Image layerCount t)]++type instance TexRepr DIM3 NoMip gp layerCount t = [gp (Image layerCount t)]+type instance TexRepr DIM3 AutoMip gp layerCount t = [gp (Image layerCount t)]+type instance TexRepr DIM3 Mip gp layerCount t = [[gp (Image layerCount t)]] -- 3D layers contain mipmap+-}++-- shader stage tags: vertex, geometry, fragment+-- used in language AST, for primfun restriction and in shader codegen+data Frequency+ = Obj+ | V+ | G+ | F++data OutputType+ = SingleOutput+ | MultiOutput
+ LC_T_DSLType.hs view
@@ -0,0 +1,622 @@+module LC_T_DSLType where++import Data.Int+import Data.Word++import LC_G_Type+import LC_G_APIType (InputType)+import LC_G_APIType hiding (InputType(..))+import qualified LC_G_APIType as U++data TextureShape+ = Tex1D+ | Tex2D+ | Tex3D+ | TexRect++data Red = Red deriving (Eq,Ord)+data RG = RG deriving (Eq,Ord)+data RGB = RGB deriving (Eq,Ord)+data RGBA = RGBA deriving (Eq,Ord)++data TextureSemantics a+ = Regular a+ | Shadow a+ | MultiSample a+ | Buffer a++data TextureArray+ = SingleTex -- singleton texture+ | ArrayTex -- array texture+ | CubeTex -- cube texture = array with size 6++--data Sampler dim layerCount t ar+data Sampler :: TextureShape -> TextureArray -> TextureSemantics * -> * -> *+ +-- IsScalar means here that the related type is not a tuple, but a GPU primitive type+class GPU a => IsScalar a where+ toValue :: a -> Value+ toType :: a -> InputType+{-+instance Nat sh => IsScalar (Sampler dim sh t ar) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = error "toType Sampler is not implemented yet" -- TODO+-}+-- Float+instance IsScalar (Sampler Tex1D SingleTex (Regular Float) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.FTexture1D+instance IsScalar (Sampler Tex2D SingleTex (Regular Float) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.FTexture2D+instance IsScalar (Sampler Tex3D SingleTex (Regular Float) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.FTexture3D+instance IsScalar (Sampler Tex2D CubeTex (Regular Float) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.FTextureCube+instance IsScalar (Sampler Tex1D ArrayTex (Regular Float) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.FTexture1DArray+instance IsScalar (Sampler Tex2D ArrayTex (Regular Float) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.FTexture2DArray+instance IsScalar (Sampler Tex2D SingleTex (MultiSample Float) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.FTexture2DMS+instance IsScalar (Sampler Tex2D ArrayTex (MultiSample Float) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.FTexture2DMSArray+instance IsScalar (Sampler Tex1D SingleTex (Buffer Float) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.FTextureBuffer+instance IsScalar (Sampler TexRect SingleTex (Regular Float) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.FTexture2DRect++-- Int+instance IsScalar (Sampler Tex1D SingleTex (Regular Int) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.ITexture1D+instance IsScalar (Sampler Tex2D SingleTex (Regular Int) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.ITexture2D+instance IsScalar (Sampler Tex3D SingleTex (Regular Int) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.ITexture3D+instance IsScalar (Sampler Tex2D CubeTex (Regular Int) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.ITextureCube+instance IsScalar (Sampler Tex1D ArrayTex (Regular Int) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.ITexture1DArray+instance IsScalar (Sampler Tex2D ArrayTex (Regular Int) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.ITexture2DArray+instance IsScalar (Sampler Tex2D SingleTex (MultiSample Int) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.ITexture2DMS+instance IsScalar (Sampler Tex2D ArrayTex (MultiSample Int) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.ITexture2DMSArray+instance IsScalar (Sampler Tex1D SingleTex (Buffer Int) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.ITextureBuffer+instance IsScalar (Sampler TexRect SingleTex (Regular Int) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.ITexture2DRect++-- Word+instance IsScalar (Sampler Tex1D SingleTex (Regular Word) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.UTexture1D+instance IsScalar (Sampler Tex2D SingleTex (Regular Word) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.UTexture2D+instance IsScalar (Sampler Tex3D SingleTex (Regular Word) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.UTexture3D+instance IsScalar (Sampler Tex2D CubeTex (Regular Word) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.UTextureCube+instance IsScalar (Sampler Tex1D ArrayTex (Regular Word) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.UTexture1DArray+instance IsScalar (Sampler Tex2D ArrayTex (Regular Word) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.UTexture2DArray+instance IsScalar (Sampler Tex2D SingleTex (MultiSample Word) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.UTexture2DMS+instance IsScalar (Sampler Tex2D ArrayTex (MultiSample Word) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.UTexture2DMSArray+instance IsScalar (Sampler Tex1D SingleTex (Buffer Word) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.UTextureBuffer+instance IsScalar (Sampler TexRect SingleTex (Regular Word) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.UTexture2DRect++-- Shadow+instance IsScalar (Sampler Tex1D SingleTex (Shadow Float) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.STexture1D+instance IsScalar (Sampler Tex2D SingleTex (Shadow Float) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.STexture2D+instance IsScalar (Sampler Tex2D CubeTex (Shadow Float) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.STextureCube+instance IsScalar (Sampler Tex1D ArrayTex (Shadow Float) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.STexture1DArray+instance IsScalar (Sampler Tex2D ArrayTex (Shadow Float) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.STexture2DArray+instance IsScalar (Sampler TexRect SingleTex (Shadow Float) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.STexture2DRect++instance IsScalar Int32 where+ toValue v = VInt v+ toType _ = U.Int+instance IsScalar Word32 where+ toValue v = VWord v+ toType _ = U.Word+instance IsScalar Float where+ toValue v = VFloat v+ toType _ = U.Float+instance IsScalar Bool where+ toValue v = VBool v+ toType _ = U.Bool+instance IsScalar M22F where+ toValue v = VM22F v+ toType _ = U.M22F+instance IsScalar M23F where+ toValue v = VM23F v+ toType _ = U.M23F+instance IsScalar M24F where+ toValue v = VM24F v+ toType _ = U.M24F+instance IsScalar M32F where+ toValue v = VM32F v+ toType _ = U.M32F+instance IsScalar M33F where+ toValue v = VM33F v+ toType _ = U.M33F+instance IsScalar M34F where+ toValue v = VM34F v+ toType _ = U.M34F+instance IsScalar M42F where+ toValue v = VM42F v+ toType _ = U.M42F+instance IsScalar M43F where+ toValue v = VM43F v+ toType _ = U.M43F+instance IsScalar M44F where+ toValue v = VM44F v+ toType _ = U.M44F+instance IsScalar V2F where+ toValue v = VV2F v+ toType _ = U.V2F+instance IsScalar V3F where+ toValue v = VV3F v+ toType _ = U.V3F+instance IsScalar V4F where+ toValue v = VV4F v+ toType _ = U.V4F+instance IsScalar V2I where+ toValue v = VV2I v+ toType _ = U.V2I+instance IsScalar V3I where+ toValue v = VV3I v+ toType _ = U.V3I+instance IsScalar V4I where+ toValue v = VV4I v+ toType _ = U.V4I+instance IsScalar V2U where+ toValue v = VV2U v+ toType _ = U.V2U+instance IsScalar V3U where+ toValue v = VV3U v+ toType _ = U.V3U+instance IsScalar V4U where+ toValue v = VV4U v+ toType _ = U.V4U+instance IsScalar V2B where+ toValue v = VV2B v+ toType _ = U.V2B+instance IsScalar V3B where+ toValue v = VV3B v+ toType _ = U.V3B+instance IsScalar V4B where+ toValue v = VV4B v+ toType _ = U.V4B++instance Show (Sampler dim layerCount t ar) where+ show _ = "Sampler dim layerCount t ar"++-- GPU type restriction, the functions are used in shader codegen+class (Show a) => GPU a where+ tupleType :: a -> Ty++-- Float+instance GPU (Sampler Tex1D SingleTex (Regular Float) a) where+ tupleType v = Single $ toType v+instance GPU (Sampler Tex2D SingleTex (Regular Float) a) where+ tupleType v = Single $ toType v+instance GPU (Sampler Tex3D SingleTex (Regular Float) a) where+ tupleType v = Single $ toType v+instance GPU (Sampler Tex2D CubeTex (Regular Float) a) where+ tupleType v = Single $ toType v+instance GPU (Sampler Tex1D ArrayTex (Regular Float) a) where+ tupleType v = Single $ toType v+instance GPU (Sampler Tex2D ArrayTex (Regular Float) a) where+ tupleType v = Single $ toType v+instance GPU (Sampler Tex2D SingleTex (MultiSample Float) a) where+ tupleType v = Single $ toType v+instance GPU (Sampler Tex2D ArrayTex (MultiSample Float) a) where+ tupleType v = Single $ toType v+instance GPU (Sampler Tex1D SingleTex (Buffer Float) a) where+ tupleType v = Single $ toType v+instance GPU (Sampler TexRect SingleTex (Regular Float) a) where+ tupleType v = Single $ toType v++-- Int+instance GPU (Sampler Tex1D SingleTex (Regular Int) a) where+ tupleType v = Single $ toType v+instance GPU (Sampler Tex2D SingleTex (Regular Int) a) where+ tupleType v = Single $ toType v+instance GPU (Sampler Tex3D SingleTex (Regular Int) a) where+ tupleType v = Single $ toType v+instance GPU (Sampler Tex2D CubeTex (Regular Int) a) where+ tupleType v = Single $ toType v+instance GPU (Sampler Tex1D ArrayTex (Regular Int) a) where+ tupleType v = Single $ toType v+instance GPU (Sampler Tex2D ArrayTex (Regular Int) a) where+ tupleType v = Single $ toType v+instance GPU (Sampler Tex2D SingleTex (MultiSample Int) a) where+ tupleType v = Single $ toType v+instance GPU (Sampler Tex2D ArrayTex (MultiSample Int) a) where+ tupleType v = Single $ toType v+instance GPU (Sampler Tex1D SingleTex (Buffer Int) a) where+ tupleType v = Single $ toType v+instance GPU (Sampler TexRect SingleTex (Regular Int) a) where+ tupleType v = Single $ toType v++-- Word+instance GPU (Sampler Tex1D SingleTex (Regular Word) a) where+ tupleType v = Single $ toType v+instance GPU (Sampler Tex2D SingleTex (Regular Word) a) where+ tupleType v = Single $ toType v+instance GPU (Sampler Tex3D SingleTex (Regular Word) a) where+ tupleType v = Single $ toType v+instance GPU (Sampler Tex2D CubeTex (Regular Word) a) where+ tupleType v = Single $ toType v+instance GPU (Sampler Tex1D ArrayTex (Regular Word) a) where+ tupleType v = Single $ toType v+instance GPU (Sampler Tex2D ArrayTex (Regular Word) a) where+ tupleType v = Single $ toType v+instance GPU (Sampler Tex2D SingleTex (MultiSample Word) a) where+ tupleType v = Single $ toType v+instance GPU (Sampler Tex2D ArrayTex (MultiSample Word) a) where+ tupleType v = Single $ toType v+instance GPU (Sampler Tex1D SingleTex (Buffer Word) a) where+ tupleType v = Single $ toType v+instance GPU (Sampler TexRect SingleTex (Regular Word) a) where+ tupleType v = Single $ toType v++-- Shadow+instance GPU (Sampler Tex1D SingleTex (Shadow Float) a) where+ tupleType v = Single $ toType v+instance GPU (Sampler Tex2D SingleTex (Shadow Float) a) where+ tupleType v = Single $ toType v+instance GPU (Sampler Tex2D CubeTex (Shadow Float) a) where+ tupleType v = Single $ toType v+instance GPU (Sampler Tex1D ArrayTex (Shadow Float) a) where+ tupleType v = Single $ toType v+instance GPU (Sampler Tex2D ArrayTex (Shadow Float) a) where+ tupleType v = Single $ toType v+instance GPU (Sampler TexRect SingleTex (Shadow Float) a) where+ tupleType v = Single $ toType v++instance GPU () where+ tupleType v = Tuple []+instance GPU Bool where+ tupleType v = Single $ toType v+instance GPU Float where+ tupleType v = Single $ toType v+instance GPU Int32 where+ tupleType v = Single $ toType v+instance GPU Word32 where+ tupleType v = Single $ toType v+instance GPU V2B where+ tupleType v = Single $ toType v+instance GPU V2F where+ tupleType v = Single $ toType v+instance GPU V2I where+ tupleType v = Single $ toType v+instance GPU V2U where+ tupleType v = Single $ toType v+instance GPU V3B where+ tupleType v = Single $ toType v+instance GPU V3F where+ tupleType v = Single $ toType v+instance GPU V3I where+ tupleType v = Single $ toType v+instance GPU V3U where+ tupleType v = Single $ toType v+instance GPU V4B where+ tupleType v = Single $ toType v+instance GPU V4F where+ tupleType v = Single $ toType v+instance GPU V4I where+ tupleType v = Single $ toType v+instance GPU V4U where+ tupleType v = Single $ toType v+instance GPU M22F where+ tupleType v = Single $ toType v+instance GPU M23F where+ tupleType v = Single $ toType v+instance GPU M24F where+ tupleType v = Single $ toType v+instance GPU M32F where+ tupleType v = Single $ toType v+instance GPU M33F where+ tupleType v = Single $ toType v+instance GPU M34F where+ tupleType v = Single $ toType v+instance GPU M42F where+ tupleType v = Single $ toType v+instance GPU M43F where+ tupleType v = Single $ toType v+instance GPU M44F where+ tupleType v = Single $ toType v+instance (GPU a, GPU b) => GPU (a, b) where+ tupleType (v :: (a,b)) = Tuple+ [ tupleType (undefined :: a)+ , tupleType (undefined :: b)+ ]+instance (GPU a, GPU b, GPU c) => GPU (a, b, c) where+ tupleType (v :: (a,b,c)) = Tuple+ [ tupleType (undefined :: a)+ , tupleType (undefined :: b)+ , tupleType (undefined :: c)+ ]+instance (GPU a, GPU b, GPU c, GPU d) => GPU (a, b, c, d) where+ tupleType (v :: (a,b,c,d)) = Tuple+ [ tupleType (undefined :: a)+ , tupleType (undefined :: b)+ , tupleType (undefined :: c)+ , tupleType (undefined :: d)+ ]+instance (GPU a, GPU b, GPU c, GPU d, GPU e) => GPU (a, b, c, d, e) where+ tupleType (v :: (a,b,c,d,e)) = Tuple+ [ tupleType (undefined :: a)+ , tupleType (undefined :: b)+ , tupleType (undefined :: c)+ , tupleType (undefined :: d)+ , tupleType (undefined :: e)+ ]+instance (GPU a, GPU b, GPU c, GPU d, GPU e, GPU f) => GPU (a, b, c, d, e, f) where+ tupleType (v :: (a,b,c,d,e,f)) = Tuple+ [ tupleType (undefined :: a)+ , tupleType (undefined :: b)+ , tupleType (undefined :: c)+ , tupleType (undefined :: d)+ , tupleType (undefined :: e)+ , tupleType (undefined :: f)+ ]+instance (GPU a, GPU b, GPU c, GPU d, GPU e, GPU f, GPU g) => GPU (a, b, c, d, e, f, g) where+ tupleType (v :: (a,b,c,d,e,f,g)) = Tuple+ [ tupleType (undefined :: a)+ , tupleType (undefined :: b)+ , tupleType (undefined :: c)+ , tupleType (undefined :: d)+ , tupleType (undefined :: e)+ , tupleType (undefined :: f)+ , tupleType (undefined :: g)+ ]+instance (GPU a, GPU b, GPU c, GPU d, GPU e, GPU f, GPU g, GPU h) => GPU (a, b, c, d, e, f, g, h) where+ tupleType (v :: (a,b,c,d,e,f,g,h)) = Tuple+ [ tupleType (undefined :: a)+ , tupleType (undefined :: b)+ , tupleType (undefined :: c)+ , tupleType (undefined :: d)+ , tupleType (undefined :: e)+ , tupleType (undefined :: f)+ , tupleType (undefined :: g)+ , tupleType (undefined :: h)+ ]+instance (GPU a, GPU b, GPU c, GPU d, GPU e, GPU f, GPU g, GPU h, GPU i) => GPU (a, b, c, d, e, f, g, h, i) where+ tupleType (v :: (a,b,c,d,e,f,g,h,i)) = Tuple+ [ tupleType (undefined :: a)+ , tupleType (undefined :: b)+ , tupleType (undefined :: c)+ , tupleType (undefined :: d)+ , tupleType (undefined :: e)+ , tupleType (undefined :: f)+ , tupleType (undefined :: g)+ , tupleType (undefined :: h)+ , tupleType (undefined :: i)+ ]++-- stream type restriction, these types can be used in vertex shader input+class GPU a => SGPU a+instance SGPU Int32+instance SGPU Word32+instance SGPU Float+instance SGPU M22F+instance SGPU M23F+instance SGPU M24F+instance SGPU M32F+instance SGPU M33F+instance SGPU M34F+instance SGPU M42F+instance SGPU M43F+instance SGPU M44F+instance SGPU V2F+instance SGPU V3F+instance SGPU V4F+instance SGPU V2I+instance SGPU V3I+instance SGPU V4I+instance SGPU V2U+instance SGPU V3U+instance SGPU V4U+instance (SGPU a, SGPU b) => SGPU (a, b)+instance (SGPU a, SGPU b, SGPU c) => SGPU (a, b, c)+instance (SGPU a, SGPU b, SGPU c, SGPU d) => SGPU (a, b, c, d)+instance (SGPU a, SGPU b, SGPU c, SGPU d, SGPU e) => SGPU (a, b, c, d, e)+instance (SGPU a, SGPU b, SGPU c, SGPU d, SGPU e, SGPU f) => SGPU (a, b, c, d, e, f)+instance (SGPU a, SGPU b, SGPU c, SGPU d, SGPU e, SGPU f, SGPU g) => SGPU (a, b, c, d, e, f, g)+instance (SGPU a, SGPU b, SGPU c, SGPU d, SGPU e, SGPU f, SGPU g, SGPU h) => SGPU (a, b, c, d, e, f, g, h)+instance (SGPU a, SGPU b, SGPU c, SGPU d, SGPU e, SGPU f, SGPU g, SGPU h, SGPU i) => SGPU (a, b, c, d, e, f, g, h, i)++-- uniform type restriction+-- hint: EltRepr stands for Elementary Type Representation+type family EltRepr a :: *+type instance EltRepr (Sampler dim sh t ar) = ((), Sampler dim sh t ar)+type instance EltRepr () = ()+type instance EltRepr Int32 = ((), Int32)+type instance EltRepr Word32 = ((), Word32)+type instance EltRepr Float = ((), Float)+type instance EltRepr Bool = ((), Bool)+type instance EltRepr V2F = ((), V2F)+type instance EltRepr V2I = ((), V2I)+type instance EltRepr V2U = ((), V2U)+type instance EltRepr V2B = ((), V2B)+type instance EltRepr M22F = ((), M22F)+type instance EltRepr M23F = ((), M23F)+type instance EltRepr M24F = ((), M24F)+type instance EltRepr V3F = ((), V3F)+type instance EltRepr V3I = ((), V3I)+type instance EltRepr V3U = ((), V3U)+type instance EltRepr V3B = ((), V3B)+type instance EltRepr M32F = ((), M32F)+type instance EltRepr M33F = ((), M33F)+type instance EltRepr M34F = ((), M34F)+type instance EltRepr V4F = ((), V4F)+type instance EltRepr V4I = ((), V4I)+type instance EltRepr V4U = ((), V4U)+type instance EltRepr V4B = ((), V4B)+type instance EltRepr M42F = ((), M42F)+type instance EltRepr M43F = ((), M43F)+type instance EltRepr M44F = ((), M44F)+type instance EltRepr (a, b) = (EltRepr a, EltRepr' b)+type instance EltRepr (a, b, c) = (EltRepr (a, b), EltRepr' c)+type instance EltRepr (a, b, c, d) = (EltRepr (a, b, c), EltRepr' d)+type instance EltRepr (a, b, c, d, e) = (EltRepr (a, b, c, d), EltRepr' e)+type instance EltRepr (a, b, c, d, e, f) = (EltRepr (a, b, c, d, e), EltRepr' f)+type instance EltRepr (a, b, c, d, e, f, g) = (EltRepr (a, b, c, d, e, f), EltRepr' g)+type instance EltRepr (a, b, c, d, e, f, g, h) = (EltRepr (a, b, c, d, e, f, g), EltRepr' h)+type instance EltRepr (a, b, c, d, e, f, g, h, i) = (EltRepr (a, b, c, d, e, f, g, h), EltRepr' i)++type family EltRepr' a :: *+type instance EltRepr' (Sampler dim sh t ar) = Sampler dim sh t ar+type instance EltRepr' () = ()+type instance EltRepr' Int32 = Int32+type instance EltRepr' Word32 = Word32+type instance EltRepr' Float = Float+type instance EltRepr' Bool = Bool+type instance EltRepr' V2F = V2F+type instance EltRepr' V2I = V2I+type instance EltRepr' V2U = V2U+type instance EltRepr' V2B = V2B+type instance EltRepr' M22F = M22F+type instance EltRepr' M23F = M23F+type instance EltRepr' M24F = M24F+type instance EltRepr' V3F = V3F+type instance EltRepr' V3I = V3I+type instance EltRepr' V3U = V3U+type instance EltRepr' V3B = V3B+type instance EltRepr' M32F = M32F+type instance EltRepr' M33F = M33F+type instance EltRepr' M34F = M34F+type instance EltRepr' V4F = V4F+type instance EltRepr' V4I = V4I+type instance EltRepr' V4U = V4U+type instance EltRepr' V4B = V4B+type instance EltRepr' M42F = M42F+type instance EltRepr' M43F = M43F+type instance EltRepr' M44F = M44F+type instance EltRepr' (a, b) = (EltRepr a, EltRepr' b)+type instance EltRepr' (a, b, c) = (EltRepr (a, b), EltRepr' c)+type instance EltRepr' (a, b, c, d) = (EltRepr (a, b, c), EltRepr' d)+type instance EltRepr' (a, b, c, d, e) = (EltRepr (a, b, c, d), EltRepr' e)+type instance EltRepr' (a, b, c, d, e, f) = (EltRepr (a, b, c, d, e), EltRepr' f)+type instance EltRepr' (a, b, c, d, e, f, g) = (EltRepr (a, b, c, d, e, f), EltRepr' g)+type instance EltRepr' (a, b, c, d, e, f, g, h) = (EltRepr (a, b, c, d, e, f, g), EltRepr' h)+type instance EltRepr' (a, b, c, d, e, f, g, h, i) = (EltRepr (a, b, c, d, e, f, g, h), EltRepr' i)++-- |Conversion between surface n-tuples and our tuple representation.+--+-- our language uses nested tuple representation+class IsTuple tup where+ type TupleRepr tup++instance IsTuple () where+ type TupleRepr () = ()+ +instance IsTuple (a, b) where+ type TupleRepr (a, b) = (((), a), b)+ +instance IsTuple (a, b, c) where+ type TupleRepr (a, b, c) = (TupleRepr (a, b), c)++instance IsTuple (a, b, c, d) where+ type TupleRepr (a, b, c, d) = (TupleRepr (a, b, c), d)++instance IsTuple (a, b, c, d, e) where+ type TupleRepr (a, b, c, d, e) = (TupleRepr (a, b, c, d), e)++instance IsTuple (a, b, c, d, e, f) where+ type TupleRepr (a, b, c, d, e, f) = (TupleRepr (a, b, c, d, e), f)++instance IsTuple (a, b, c, d, e, f, g) where+ type TupleRepr (a, b, c, d, e, f, g) = (TupleRepr (a, b, c, d, e, f), g)++instance IsTuple (a, b, c, d, e, f, g, h) where+ type TupleRepr (a, b, c, d, e, f, g, h) = (TupleRepr (a, b, c, d, e, f, g), h)++instance IsTuple (a, b, c, d, e, f, g, h, i) where+ type TupleRepr (a, b, c, d, e, f, g, h, i) = (TupleRepr (a, b, c, d, e, f, g, h), i)++-- Tuple representation+-- --------------------++-- |We represent tuples as heterogenous lists, typed by a type list.+--+data Tuple c t where+ NilTup :: Tuple c ()+ SnocTup :: GPU t => Tuple c s -> c t -> Tuple c (s, t)++-- |Type-safe projection indicies for tuples.+--+-- NB: We index tuples by starting to count from the *right*!+--+data TupleIdx t e where+ ZeroTupIdx :: GPU s => TupleIdx (t, s) s+ SuccTupIdx :: TupleIdx t e -> TupleIdx (t, s) e++-- Auxiliary tuple index constants+--+tix0 :: GPU s => TupleIdx (t, s) s+tix0 = ZeroTupIdx+tix1 :: GPU s => TupleIdx ((t, s), s1) s+tix1 = SuccTupIdx tix0+tix2 :: GPU s => TupleIdx (((t, s), s1), s2) s+tix2 = SuccTupIdx tix1+tix3 :: GPU s => TupleIdx ((((t, s), s1), s2), s3) s+tix3 = SuccTupIdx tix2+tix4 :: GPU s => TupleIdx (((((t, s), s1), s2), s3), s4) s+tix4 = SuccTupIdx tix3+tix5 :: GPU s => TupleIdx ((((((t, s), s1), s2), s3), s4), s5) s+tix5 = SuccTupIdx tix4+tix6 :: GPU s => TupleIdx (((((((t, s), s1), s2), s3), s4), s5), s6) s+tix6 = SuccTupIdx tix5+tix7 :: GPU s => TupleIdx ((((((((t, s), s1), s2), s3), s4), s5), s6), s7) s+tix7 = SuccTupIdx tix6+tix8 :: GPU s => TupleIdx (((((((((t, s), s1), s2), s3), s4), s5), s6), s7), s8) s+tix8 = SuccTupIdx tix7
+ LC_T_HOAS.hs view
@@ -0,0 +1,236 @@+module LC_T_HOAS where++import GHC.TypeLits++import Data.ByteString.Char8+import Data.Int++import LC_G_Type+import LC_G_APIType (Filter(..),EdgeMode(..))+import LC_T_APIType+import LC_T_DSLType+import LC_T_PrimFun++-- Common Exp, describes shader functions+data Exp :: Frequency -> * -> * where+ -- Needed for conversion to de Bruijn form+ Tag :: GPU t+ => Int+ -> String+ -> Exp stage t+ -- environment size at defining occurrence+{-+ -- function support+ Lam :: (GPU a, GPU b)+ => (Exp stage a -> Exp stage b)+ -> Exp stage (a -> b)++ App :: (GPU a, GPU b)+ => Exp stage a+ -> Exp stage (a -> b)+ -> Exp stage b+-}+ -- constant value+ Const :: (GPU t,IsScalar t)+ => t+ -> Exp stage t++ -- builtin variable+ PrimVar :: GPU t+ => Input t+ -> Exp stage t++ -- uniform value+ Uni :: GPU t+ => Input t+ -> Exp stage t++ -- conditional expression+ Cond :: GPU t+ => Exp stage Bool+ -> Exp stage t+ -> Exp stage t+ -> Exp stage t++ PrimApp :: (GPU a, GPU r)+ => PrimFun stage (a -> r)+ -> Exp stage a+ -> Exp stage r++ -- tuple support+ Tup :: (GPU t, IsTuple t)+ => Tuple (Exp stage) (TupleRepr t)+ -> Exp stage t++ Prj :: (GPU e, GPU t, IsTuple t)+ => TupleIdx (TupleRepr t) e+ -> Exp stage t+ -> Exp stage e++ -- sampler support+ Sampler :: GPU (Sampler dim arr t ar)+ => Filter+ -> EdgeMode+ -> Texture (Exp Obj) dim arr t ar+ -> Exp stage (Sampler dim arr t ar)++ -- loop support+ Loop :: (GPU s, GPU a)+ => (Exp stage s -> Exp stage s) -- state transform function+ -> (Exp stage s -> Exp stage Bool) -- loop condition function+ -> (Exp stage s -> Exp stage a) -- state to result transform function+ -> Exp stage s -- initial state+ -> Exp stage a -- result+ -- GP+ -- hint: GP stands for Graphics Pipeline+ Fetch :: (InputTuple a, SGPU (InputTupleRepr a))+ => ByteString+ -> FetchPrimitive primitive+ -> a+ -> Exp Obj (VertexStream primitive (InputTupleRepr a))++ Transform :: (GPU a, GPU b)+ => (Exp V a -> VertexOut clipDistances b) -- vertex shader+ -> Exp Obj (VertexStream primitive a)+ -> Exp Obj (PrimitiveStream primitive clipDistances 1 V b)++ Reassemble :: GeometryShader inputPrimitive outputPrimitive inputClipDistances outputClipDistances layerCount a b+ -> Exp Obj (PrimitiveStream inputPrimitive inputClipDistances 1 V a)+ -> Exp Obj (PrimitiveStream outputPrimitive outputClipDistances layerCount G b)++ Rasterize :: RasterContext primitive+ -> Exp Obj (PrimitiveStream primitive clipDistances layerCount freq a)+ -> Exp Obj (FragmentStream layerCount a)++ FrameBuffer :: FrameBuffer layerCount t+ -> Exp Obj (FrameBuffer layerCount (FTRepr' t))++ Accumulate :: (GPU a, GPU (FTRepr' b), IsValidOutput b) -- restriction: depth and stencil optional, arbitrary color component+ => AccumulationContext b+ -> FragmentFilter a+ -> (Exp F a -> FragmentOut (NoStencilRepr b)) -- fragment shader+ -> Exp Obj (FragmentStream layerCount a)+ -> Exp Obj (FrameBuffer layerCount (FTRepr' b))+ -> Exp Obj (FrameBuffer layerCount (FTRepr' b))++ PrjFrameBuffer :: ByteString -- internal image output (can be allocated on request)+ -> TupleIdx (EltRepr b) t+ -> Exp Obj (FrameBuffer layerCount b)+ -> Exp Obj (Image layerCount t)++ PrjImage :: ((idx + 1) <= layerCount, 2 <= layerCount, SingI idx)+ => ByteString -- internal image output (can be allocated on request)+ -> NatNum idx+ -> Exp Obj (Image layerCount t)+ -> Exp Obj (Image 1 t)+{-+ -- dynamic extension support+ AccumulateSet :: GPU a+ => ByteString+ -> Exp Obj (FrameBuffer layerCount a)+ -> Exp Obj (FrameBuffer layerCount a)+-}++type InterpolatedFlatExp stage a = FlatTuple GPU (Interpolated (Exp stage)) a+type FlatExp stage a = FlatTuple GPU (Exp stage) a++-- Vertex+{-+ Vertex shader builtin output:+ gl_PerVertex {+ vec4 gl_Position+ float gl_PointSize+ float gl_ClipDistance[]+ }+-}+-- result of a vertex or geometry shader function+data VertexOut clipDistances t where+ VertexOut :: IsFloatTuple clipDistances+ => Exp V V4F -- position+ -> Exp V Float -- point size+ -> FlatExp V clipDistances -- clip distance []+ -> InterpolatedFlatExp V a+ -> VertexOut (FTRepr clipDistances) (FTRepr a)++-- Geometry+-- describes a geometry shader+data GeometryShader (inPrimitive :: PrimitiveType) (outPrimitive :: PrimitiveType) inClipDistances outClipDistances (layerCount :: Nat) a b where+ GeometryShader :: (GPU j, GPU i, GPU b, GPU outputClipDistances, GPU input, SingI layerCount+ , inputVertex ~ (V4F,Float,inputClipDistances,a)+ , input ~ PrimitiveVertices inputPrimitive inputVertex+ )+ => NatNum layerCount -- geometry shader:+ -> OutputPrimitive outputPrimitive -- output primitive+ -> Int -- max amount of generated vertices+ -> (Exp G input -> Exp G (i,Int32)) -- how many primitives?+ -> (Exp G i -> Exp G (Int32,Int32,i,j,Int32)) -- how many vertices? primtive loop, out:+ -- gl_PrimitiveID; gl_Layer; loop var; vertex loop seed; vertex loop iteration count)+ -> (Exp G j -> GeometryOut j outputClipDistances b) -- generate vertices+ -> GeometryShader inputPrimitive outputPrimitive inputClipDistances outputClipDistances layerCount a b+{-+ GeometryShader :: (GPU (PrimitiveVertices primIn a), GPU i, GPU j, GPU b, IsPrimitive primIn, IsPrimitive primOut, SingI layerNum)+ => NatNum layerNum -- geometry shader:+ -> primOut -- output primitive+ -> Int -- max amount of generated vertices+ -> (Exp G (PrimitiveVertices primIn a) -> Exp G (i,Int32)) -- how many primitives?+ -> (Exp G i -> Exp G (i,j,Int32)) -- how many vertices?+ -> (Exp G j -> GeometryOut (j,b)) -- generate vertices+ -> GeometryShader primIn primOut layerNum a b+-}++{-+ Geometry shader builtin output:+ gl_PerVertex {+ vec4 gl_Position+ float gl_PointSize+ float gl_ClipDistance[]+ }+ int gl_PrimitiveID+ int gl_Layer+-}+-- result of a geometry shader function+data GeometryOut i clipDistances t where+ GeometryOut :: IsFloatTuple clipDistances+ => Exp G i+ -> Exp G V4F -- position+ -> Exp G Float -- point size+ -> FlatExp G clipDistances -- clip distance []+ -> InterpolatedFlatExp G a+ -> GeometryOut i (FTRepr clipDistances) (FTRepr a)++-- Fragment+{-+ Fragment shader builtin output:+ float gl_FragDepth -- Optional+-}+-- result of a fragment shader function+data FragmentOut t where+ FragmentOut :: FlatExp F a+ -> FragmentOut (ColorRepr a)++ FragmentOutDepth :: Exp F Float+ -> FlatExp F a+ -> FragmentOut (Depth Float :+: ColorRepr a)++ FragmentOutRastDepth :: FlatExp F a+ -> FragmentOut (Depth Float :+: ColorRepr a)++-- fragment filter function, we express discard using a filter function+data FragmentFilter a where+ PassAll :: FragmentFilter a++ Filter :: (Exp F a -> Exp F Bool)+ -> FragmentFilter a+++data GPOutput (o :: OutputType) where+ ImageOut :: ByteString+ -> V2U+ -> Exp Obj (Image 1 t)+ -> GPOutput SingleOutput++ ScreenOut :: Exp Obj (Image 1 t)+ -> GPOutput SingleOutput++ MultiOut :: [GPOutput SingleOutput]+ -> GPOutput MultiOutput
+ LC_T_Language.hs view
@@ -0,0 +1,508 @@+{-# LANGUAGE UndecidableInstances, OverlappingInstances #-}+module LC_T_Language where++import Data.Int+import Data.Word++import LC_G_Type+import LC_T_APIType+import LC_T_DSLType+import LC_T_PrimFun+import LC_T_HOAS+{-+ all operatiors with @<>?,./\';""|:}{+_)0-=§±!@#$%^&*()_++ <+> <+.> <.+> -- good, conflict: <*>+ [+] [+.] [.+] -- good, conflict with lists+ |+| |+.| |.+| -- medium+ @+ @+. @.+ -- bad+ :+: :+.: :.+: -- bad+ [*]+-}+{-+infixl 7 .*., ./., .%.+infixl 6 .+., .-.+infix 4 .==., ./=., .<., .<=., .>=., .>.++infixr 3 .&&.+infixr 2 .||.++infixl 8 .>>., .<<.+infixl 7 .&.+infixl 6 .^.+infixl 5 .|.+-}++infixl 7 @*, @/, @%+infixl 6 @+, @-+infix 4 @==, @/=, @<, @<=, @>=, @>++infixr 3 @&&+infixr 2 @||++infixl 8 @>>, @<<+infixl 7 @&+infixl 6 @^+infixl 5 @|++infix 7 @. -- dot+infix 7 @# -- cross+infixr 7 @*. -- mulmv+infixl 7 @.* -- mulvm+infixl 7 @.*. -- mulmm++-- TODO: we should use template haskell or a preprocessor to generate the instances+class OperatorArithmetic a b where+ (@+) :: a -> b -> a+ (@-) :: a -> b -> a+ (@*) :: a -> b -> a++instance (GPU (V2 t), IsNumComponent t, IsMatVec (V2 t) c, IsNum c) => OperatorArithmetic (Exp stage (V2 t)) (Exp stage (V2 t)) where+ a @+ b = PrimApp PrimAdd $! tup2 (a,b)+ a @- b = PrimApp PrimSub $! tup2 (a,b)+ a @* b = PrimApp PrimMul $! tup2 (a,b)++instance (GPU (V3 t), IsNumComponent t, IsMatVec (V3 t) c, IsNum c) => OperatorArithmetic (Exp stage (V3 t)) (Exp stage (V3 t)) where+ a @+ b = PrimApp PrimAdd $! tup2 (a,b)+ a @- b = PrimApp PrimSub $! tup2 (a,b)+ a @* b = PrimApp PrimMul $! tup2 (a,b)++instance (GPU (V4 t), IsNumComponent t, IsMatVec (V4 t) c, IsNum c) => OperatorArithmetic (Exp stage (V4 t)) (Exp stage (V4 t)) where+ a @+ b = PrimApp PrimAdd $! tup2 (a,b)+ a @- b = PrimApp PrimSub $! tup2 (a,b)+ a @* b = PrimApp PrimMul $! tup2 (a,b)++instance (GPU c, GPU (V2 t), IsNumComponent t, IsMatVecScalar (V2 t) c, IsNum c) => OperatorArithmetic (Exp stage (V2 t)) (Exp stage c) where+ a @+ b = PrimApp PrimAddS $! tup2 (a,b)+ a @- b = PrimApp PrimSubS $! tup2 (a,b)+ a @* b = PrimApp PrimMulS $! tup2 (a,b)++instance (GPU c, GPU (V3 t), IsNumComponent t, IsMatVecScalar (V3 t) c, IsNum c) => OperatorArithmetic (Exp stage (V3 t)) (Exp stage c) where+ a @+ b = PrimApp PrimAddS $! tup2 (a,b)+ a @- b = PrimApp PrimSubS $! tup2 (a,b)+ a @* b = PrimApp PrimMulS $! tup2 (a,b)++instance (GPU c, GPU (V4 t), IsNumComponent t, IsMatVecScalar (V4 t) c, IsNum c) => OperatorArithmetic (Exp stage (V4 t)) (Exp stage c) where+ a @+ b = PrimApp PrimAddS $! tup2 (a,b)+ a @- b = PrimApp PrimSubS $! tup2 (a,b)+ a @* b = PrimApp PrimMulS $! tup2 (a,b)++instance (GPU a, GPU t, IsNum t, IsMatVecScalar a t) => OperatorArithmetic (Exp stage a) (Exp stage t) where+ a @+ b = PrimApp PrimAddS $! tup2 (a,b)+ a @- b = PrimApp PrimSubS $! tup2 (a,b)+ a @* b = PrimApp PrimMulS $! tup2 (a,b)++{-+instance (GPU a, IsNum t, IsMatVec a t) => OperatorArithmetic (Exp stage a) (Exp stage a) (Exp stage a) where+ a @+ b = PrimApp PrimAdd $! tup2 (a,b)+ a @- b = PrimApp PrimSub $! tup2 (a,b)+ a @* b = PrimApp PrimMul $! tup2 (a,b)++instance (GPU a, GPU t, IsNum t, IsMatVecScalar a t) => OperatorArithmetic (Exp stage a) (Exp stage t) (Exp stage a) where+ a @+ b = PrimApp PrimAddS $! tup2 (a,b)+ a @- b = PrimApp PrimSubS $! tup2 (a,b)+ a @* b = PrimApp PrimMulS $! tup2 (a,b)+-}+{-+instance OperatorArithmetic (Exp stage V4F) (Exp stage V4F) (Exp stage V4F) where+ a @+ b = PrimApp PrimAdd $! tup2 (a,b)+ a @- b = PrimApp PrimSub $! tup2 (a,b)+ a @* b = PrimApp PrimMul $! tup2 (a,b)++instance OperatorArithmetic (Exp stage V4F) (Exp stage Float) (Exp stage V4F) where+ a @+ b = PrimApp PrimAddS $! tup2 (a,b)+ a @- b = PrimApp PrimSubS $! tup2 (a,b)+ a @* b = PrimApp PrimMulS $! tup2 (a,b)+-}++-- FIXME: modulus % is defined only for integral types+class OperatorDivide a b where+ (@/) :: a -> b -> a+ (@%) :: a -> b -> a++instance (GPU a, IsNum t, IsVecScalar d a t) => OperatorDivide (Exp stage a) (Exp stage a) where+ a @/ b = PrimApp PrimDiv $! tup2 (a,b)+ a @% b = PrimApp PrimMod $! tup2 (a,b)++instance (GPU a, GPU t, IsNum t, IsVecScalar d a t) => OperatorDivide (Exp stage a) (Exp stage t) where+ a @/ b = PrimApp PrimDivS $! tup2 (a,b)+ a @% b = PrimApp PrimModS $! tup2 (a,b)++class OperatorBit a b where+ (@&) :: a -> b -> a+ (@|) :: a -> b -> a+ (@^) :: a -> b -> a++instance (GPU a, IsIntegral t, IsVecScalar d a t) => OperatorBit (Exp stage a) (Exp stage a) where+ a @& b = PrimApp PrimBAnd $! tup2 (a,b)+ a @| b = PrimApp PrimBOr $! tup2 (a,b)+ a @^ b = PrimApp PrimBXor $! tup2 (a,b)++instance (GPU a, GPU t, IsIntegral t, IsVecScalar d a t) => OperatorBit (Exp stage a) (Exp stage t) where+ a @& b = PrimApp PrimBAndS $! tup2 (a,b)+ a @| b = PrimApp PrimBOrS $! tup2 (a,b)+ a @^ b = PrimApp PrimBXorS $! tup2 (a,b)++class OperatorShift a b where+ (@>>) :: a -> b -> a+ (@<<) :: a -> b -> a++instance (GPU a, GPU b, IsIntegral t, IsVecScalar d a t, IsVecScalar d b Word32) => OperatorShift (Exp stage a) (Exp stage b) where+ a @>> b = PrimApp PrimBShiftR $! tup2 (a,b)+ a @<< b = PrimApp PrimBShiftL $! tup2 (a,b)++instance (GPU a, IsIntegral t, IsVecScalar d a t) => OperatorShift (Exp stage a) (Exp stage Word32) where+ a @>> b = PrimApp PrimBShiftRS $! tup2 (a,b)+ a @<< b = PrimApp PrimBShiftLS $! tup2 (a,b)++class OperatorEq a b where+ (@==) :: a -> a -> b+ (@/=) :: a -> a -> b++instance (GPU a, GPU b, IsNum t, IsVecScalar d a t, IsVecScalar d b Bool) => OperatorEq (Exp stage a) (Exp stage b) where+ a @== b = PrimApp PrimEqualV $! tup2 (a,b)+ a @/= b = PrimApp PrimNotEqualV $! tup2 (a,b)++instance (GPU a, IsMatVecScalar a t) => OperatorEq (Exp stage a) (Exp stage Bool) where+ a @== b = PrimApp PrimEqual $! tup2 (a,b)+ a @/= b = PrimApp PrimNotEqual $! tup2 (a,b)++class OperatorRelational a b where+ (@<=) :: a -> a -> b+ (@>=) :: a -> a -> b+ (@<) :: a -> a -> b+ (@>) :: a -> a -> b++instance (GPU a, GPU b, IsNum t, IsVecScalar d a t, IsVecScalar d b Bool) => OperatorRelational (Exp stage a) (Exp stage b) where+ a @<= b = PrimApp PrimLessThanEqual $! tup2 (a,b)+ a @>= b = PrimApp PrimGreaterThanEqual $! tup2 (a,b)+ a @< b = PrimApp PrimLessThan $! tup2 (a,b)+ a @> b = PrimApp PrimGreaterThan $! tup2 (a,b)++a @&& b = PrimApp PrimAnd $! tup2 (a,b)+a @|| b = PrimApp PrimOr $! tup2 (a,b)++xor' a b = PrimApp PrimXor $! tup2 (a,b)+not' a = PrimApp PrimNot a+any' a = PrimApp PrimAny a+all' a = PrimApp PrimAll a++acos' a = PrimApp PrimACos a+acosh' a = PrimApp PrimACosH a+asin' a = PrimApp PrimASin a+asinh' a = PrimApp PrimASinH a+atan' a = PrimApp PrimATan a+atan2' a b = PrimApp PrimATan2 $! tup2 (a,b)+atanh' a = PrimApp PrimATanH a+cos' a = PrimApp PrimCos a+cosh' a = PrimApp PrimCosH a+degrees' a = PrimApp PrimDegrees a+radians' a = PrimApp PrimRadians a+sin' a = PrimApp PrimSin a+sinh' a = PrimApp PrimSinH a+tan' a = PrimApp PrimTan a+tanh' a = PrimApp PrimTanH a++pow' a b = PrimApp PrimPow $! tup2 (a,b)+exp' a = PrimApp PrimExp a+log' a = PrimApp PrimLog a+exp2' a = PrimApp PrimExp2 a+log2' a = PrimApp PrimLog2 a+sqrt' a = PrimApp PrimSqrt a+invsqrt' a = PrimApp PrimInvSqrt a++isnan' a = PrimApp PrimIsNan a+isinf' a = PrimApp PrimIsInf a+abs' a = PrimApp PrimAbs a+sign' a = PrimApp PrimSign a+floor' a = PrimApp PrimFloor a+trunc' a = PrimApp PrimTrunc a+round' a = PrimApp PrimRound a+roundEven' a = PrimApp PrimRoundEven a+ceil' a = PrimApp PrimCeil a+fract' a = PrimApp PrimFract a++floatBitsToInt' a = PrimApp PrimFloatBitsToInt a+floatBitsToUint' a = PrimApp PrimFloatBitsToUInt a+intBitsToFloat' a = PrimApp PrimIntBitsToFloat a+uintBitsToFloat' a = PrimApp PrimUIntBitsToFloat a++length' a = PrimApp PrimLength a+distance' a b = PrimApp PrimDistance $! tup2 (a,b)+dot' a b = PrimApp PrimDot $! tup2 (a,b)+cross' a b = PrimApp PrimCross $! tup2 (a,b)+normalize' a = PrimApp PrimNormalize a+faceforward' a b c = PrimApp PrimFaceForward $! tup3 (a,b,c)+reflect' a b = PrimApp PrimReflect $! tup2 (a,b)+refract' a b c = PrimApp PrimRefract $! tup3 (a,b,c)++transpose' a = PrimApp PrimTranspose a+determinant' a = PrimApp PrimDeterminant a+inverse' a = PrimApp PrimInverse a+outerProduct' a b = PrimApp PrimOuterProduct $! tup2 (a,b)++dFdx' a = PrimApp PrimDFdx a+dFdy' a = PrimApp PrimDFdy a+fwidth' a = PrimApp PrimFWidth a++noise1' a = PrimApp PrimNoise1 a+noise2' a = PrimApp PrimNoise2 a+noise3' a = PrimApp PrimNoise3 a+noise4' a = PrimApp PrimNoise4 a++textureSize' a b = PrimApp PrimTextureSize $! tup2 (a,b)+texture' a b = PrimApp PrimTexture $! tup2 (a,b)+textureB' a b c = PrimApp PrimTextureB $! tup3 (a,b,c)+textureProj' a b = PrimApp PrimTextureProj $! tup2 (a,b)+textureProjB' a b c = PrimApp PrimTextureProjB $! tup3 (a,b,c)+textureLod' a b c = PrimApp PrimTextureLod $! tup3 (a,b,c)+textureOffset' a b c = PrimApp PrimTextureOffset $! tup3 (a,b,c)+textureOffsetB' a b c d = PrimApp PrimTextureOffsetB $! tup4 (a,b,c,d)+texelFetch' a b c = PrimApp PrimTexelFetch $! tup3 (a,b,c)+texelFetchOffset' a b c d = PrimApp PrimTexelFetchOffset $! tup4 (a,b,c,d)+textureProjOffset' a b c = PrimApp PrimTextureProjOffset $! tup3 (a,b,c)+textureProjOffsetB' a b c d = PrimApp PrimTextureProjOffsetB $! tup4 (a,b,c,d)+textureLodOffset' a b c d = PrimApp PrimTextureLodOffset $! tup4 (a,b,c,d)+textureProjLod' a b c = PrimApp PrimTextureProjLod $! tup3 (a,b,c)+textureProjLodOffset' a b c d = PrimApp PrimTextureProjLodOffset $! tup4 (a,b,c,d)+textureGrad' a b c d = PrimApp PrimTextureGrad $! tup4 (a,b,c,d)+textureGradOffset' a b c d e = PrimApp PrimTextureGradOffset $! tup5 (a,b,c,d,e)+textureProjGrad' a b c d = PrimApp PrimTextureProjGrad $! tup4 (a,b,c,d)+textureProjGradOffset' a b c d e = PrimApp PrimTextureProjGradOffset $! tup5 (a,b,c,d,e)++class BuiltinCommon a b where+ min' :: a -> b -> a+ max' :: a -> b -> a+ clamp' :: a -> b -> b -> a++instance (GPU a, IsNum t, IsVecScalar d a t) => BuiltinCommon (Exp stage a) (Exp stage a) where+ min' a b = PrimApp PrimMin $! tup2 (a,b)+ max' a b = PrimApp PrimMax $! tup2 (a,b)+ clamp' a b c = PrimApp PrimClamp $! tup3 (a,b,c)++instance (GPU a, GPU t, IsNum t, IsVecScalar d a t) => BuiltinCommon (Exp stage a) (Exp stage t) where+ min' a b = PrimApp PrimMinS $! tup2 (a,b)+ max' a b = PrimApp PrimMaxS $! tup2 (a,b)+ clamp' a b c = PrimApp PrimClampS $! tup3 (a,b,c)++class BuiltinMix a b where+ mix' :: a -> a -> b -> a++instance (GPU a, IsVecScalar d a Float) => BuiltinMix (Exp stage a) (Exp stage a) where+ mix' a b c = PrimApp PrimMix $! tup3 (a,b,c)++instance (GPU a, IsVecScalar d a Float) => BuiltinMix (Exp stage a) (Exp stage Float) where+ mix' a b c = PrimApp PrimMixS $! tup3 (a,b,c)++instance (GPU a, GPU b, IsVecScalar d a Float, IsVecScalar d b Bool) => BuiltinMix (Exp stage a) (Exp stage b) where+ mix' a b c = PrimApp PrimMixB $! tup3 (a,b,c)++class BuiltinStep a b where+ step' :: b -> a -> a+ smoothstep' :: b -> b -> a -> a++instance BuiltinStep (Exp stage V2F) (Exp stage V2F) where+ step' a b = PrimApp PrimStep $! tup2 (a,b)+ smoothstep' a b c = PrimApp PrimSmoothStep $! tup3 (a,b,c)++instance BuiltinStep (Exp stage V3F) (Exp stage V3F) where+ step' a b = PrimApp PrimStep $! tup2 (a,b)+ smoothstep' a b c = PrimApp PrimSmoothStep $! tup3 (a,b,c)++instance BuiltinStep (Exp stage V4F) (Exp stage V4F) where+ step' a b = PrimApp PrimStep $! tup2 (a,b)+ smoothstep' a b c = PrimApp PrimSmoothStep $! tup3 (a,b,c)++instance (GPU a, IsVecScalar d a Float) => BuiltinStep (Exp stage a) (Exp stage Float) where+ step' a b = PrimApp PrimStepS $! tup2 (a,b)+ smoothstep' a b c = PrimApp PrimSmoothStepS $! tup3 (a,b,c)++a @. b = dot' a b+a @# b = cross' a b+a @*. b = PrimApp PrimMulMatVec $! tup2 (a,b)+a @.* b = PrimApp PrimMulVecMat $! tup2 (a,b)+a @.*. b = PrimApp PrimMulMatMat $! tup2 (a,b)++complement' a = PrimApp PrimBNot a+neg' a = PrimApp PrimNeg a+modf' a = PrimApp PrimModF a++{-+data PrimFun sig where++ -- Vec/Mat (de)construction+ PrimTupToV2 :: IsComponent a => PrimFun ((a,a) -> V2 a)+ PrimTupToV3 :: IsComponent a => PrimFun ((a,a,a) -> V3 a)+ PrimTupToV4 :: IsComponent a => PrimFun ((a,a,a,a) -> V4 a)+ PrimV2ToTup :: IsComponent a => PrimFun (V2 a -> (a,a))+ PrimV3ToTup :: IsComponent a => PrimFun (V3 a -> (a,a,a))+ PrimV4ToTup :: IsComponent a => PrimFun (V4 a -> (a,a,a,a))+-}+--mkV2 a b = +--mkV3 +--mkV4++class SpecialConstant a where+ zero' :: a+ one' :: a++instance SpecialConstant Bool where+ zero' = False+ one' = True++instance SpecialConstant Int32 where+ zero' = 0+ one' = 1++instance SpecialConstant Word32 where+ zero' = 0+ one' = 1++instance SpecialConstant Float where+ zero' = 0+ one' = 1++instance (SpecialConstant a) => SpecialConstant (V2 a) where+ zero' = V2 zero' zero'+ one' = V2 one' one'++instance (SpecialConstant a) => SpecialConstant (V3 a) where+ zero' = V3 zero' zero' zero'+ one' = V3 one' one' one'++instance (SpecialConstant a) => SpecialConstant (V4 a) where+ zero' = V4 zero' zero' zero' zero'+ one' = V4 one' one' one' one'++class IdentityMatrix a where+ idmtx' :: a++instance IdentityMatrix M22F where+ idmtx' = V2 (V2 1 0) (V2 0 1)++instance IdentityMatrix M33F where+ idmtx' = V3 (V3 1 0 0) (V3 0 1 0) (V3 0 0 1)++instance IdentityMatrix M44F where+ idmtx' = V4 (V4 1 0 0 0) (V4 0 1 0 0) (V4 0 0 1 0) (V4 0 0 0 1)+{-+ TODO: + extendZero+ extendWith+ trim+-}++class PkgVec v where+ unpack' :: (GPU a, GPU (v a), IsComponent a)+ => Exp stage (v a) -> v (Exp stage a)++ pack' :: (GPU a, GPU (v a), IsComponent a)+ => v (Exp stage a) -> Exp stage (v a)++instance PkgVec V2 where+ unpack' v = let (x,y) = untup2 $! PrimApp PrimV2ToTup v in V2 x y+ pack' (V2 x y) = PrimApp PrimTupToV2 $! tup2 (x,y)++instance PkgVec V3 where+ unpack' v = let (x,y,z) = untup3 $! PrimApp PrimV3ToTup v in V3 x y z+ pack' (V3 x y z) = PrimApp PrimTupToV3 $! tup3 (x,y,z)++instance PkgVec V4 where+ unpack' v = let (x,y,z,w) = untup4 $! PrimApp PrimV4ToTup v in V4 x y z w+ pack' (V4 x y z w) = PrimApp PrimTupToV4 $! tup4 (x,y,z,w)++-- Smart constructor and destructors for tuples+--+tup0 :: Exp freq ()+tup0 = Tup NilTup++tup2 :: (GPU a, GPU b)+ => (Exp stage a, Exp stage b) -> Exp stage (a, b)+tup2 (x1, x2) = Tup (NilTup `SnocTup` x1 `SnocTup` x2)++tup3 :: (GPU a, GPU b, GPU c)+ => (Exp stage a, Exp stage b, Exp stage c) -> Exp stage (a, b, c)+tup3 (x1, x2, x3) = Tup (NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3)++tup4 :: (GPU a, GPU b, GPU c, GPU d)+ => (Exp stage a, Exp stage b, Exp stage c, Exp stage d) -> Exp stage (a, b, c, d)+tup4 (x1, x2, x3, x4) = Tup (NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3 `SnocTup` x4)++tup5 :: (GPU a, GPU b, GPU c, GPU d, GPU e)+ => (Exp stage a, Exp stage b, Exp stage c, Exp stage d, Exp stage e) -> Exp stage (a, b, c, d, e)+tup5 (x1, x2, x3, x4, x5) = Tup $! NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3 `SnocTup` x4 `SnocTup` x5++tup6 :: (GPU a, GPU b, GPU c, GPU d, GPU e, GPU f)+ => (Exp stage a, Exp stage b, Exp stage c, Exp stage d, Exp stage e, Exp stage f) -> Exp stage (a, b, c, d, e, f)+tup6 (x1, x2, x3, x4, x5, x6) = Tup $! NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3 `SnocTup` x4 `SnocTup` x5 `SnocTup` x6++tup7 :: (GPU a, GPU b, GPU c, GPU d, GPU e, GPU f, GPU g)+ => (Exp stage a, Exp stage b, Exp stage c, Exp stage d, Exp stage e, Exp stage f, Exp stage g) -> Exp stage (a, b, c, d, e, f, g)+tup7 (x1, x2, x3, x4, x5, x6, x7)+ = Tup $! NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3 `SnocTup` x4 `SnocTup` x5 `SnocTup` x6 `SnocTup` x7++tup8 :: (GPU a, GPU b, GPU c, GPU d, GPU e, GPU f, GPU g, GPU h)+ => (Exp stage a, Exp stage b, Exp stage c, Exp stage d, Exp stage e, Exp stage f, Exp stage g, Exp stage h) -> Exp stage (a, b, c, d, e, f, g, h)+tup8 (x1, x2, x3, x4, x5, x6, x7, x8)+ = Tup $! NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3 `SnocTup` x4 `SnocTup` x5 `SnocTup` x6 `SnocTup` x7 `SnocTup` x8++tup9 :: (GPU a, GPU b, GPU c, GPU d, GPU e, GPU f, GPU g, GPU h, GPU i)+ => (Exp stage a, Exp stage b, Exp stage c, Exp stage d, Exp stage e, Exp stage f, Exp stage g, Exp stage h, Exp stage i) -> Exp stage (a, b, c, d, e, f, g, h, i)+tup9 (x1, x2, x3, x4, x5, x6, x7, x8, x9)+ = Tup $! NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3 `SnocTup` x4 `SnocTup` x5 `SnocTup` x6 `SnocTup` x7 `SnocTup` x8 `SnocTup` x9++untup2 :: (GPU a, GPU b)+ => Exp stage (a, b) -> (Exp stage a, Exp stage b)+untup2 e = (tix1 `Prj` e, tix0 `Prj` e)++untup3 :: (GPU a, GPU b, GPU c)+ => Exp stage (a, b, c) -> (Exp stage a, Exp stage b, Exp stage c)+untup3 e = (tix2 `Prj` e, tix1 `Prj` e, tix0 `Prj` e)++untup4 :: (GPU a, GPU b, GPU c, GPU d)+ => Exp stage (a, b, c, d) -> (Exp stage a, Exp stage b, Exp stage c, Exp stage d)+untup4 e = (tix3 `Prj` e, tix2 `Prj` e, tix1 `Prj` e, tix0 `Prj` e)++untup5 :: (GPU a, GPU b, GPU c, GPU d, GPU e)+ => Exp stage (a, b, c, d, e) -> (Exp stage a, Exp stage b, Exp stage c, Exp stage d, Exp stage e)+untup5 e = (tix4 `Prj` e, tix3 `Prj` e, tix2 `Prj` e, tix1 `Prj` e, tix0 `Prj` e)++untup6 :: (GPU a, GPU b, GPU c, GPU d, GPU e, GPU f)+ => Exp stage (a, b, c, d, e, f) -> (Exp stage a, Exp stage b, Exp stage c, Exp stage d, Exp stage e, Exp stage f)+untup6 e = (tix5 `Prj` e, tix4 `Prj` e, tix3 `Prj` e, tix2 `Prj` e, tix1 `Prj` e, tix0 `Prj` e)++untup7 :: (GPU a, GPU b, GPU c, GPU d, GPU e, GPU f, GPU g)+ => Exp stage (a, b, c, d, e, f, g) -> (Exp stage a, Exp stage b, Exp stage c, Exp stage d, Exp stage e, Exp stage f, Exp stage g)+untup7 e = (tix6 `Prj` e, tix5 `Prj` e, tix4 `Prj` e, tix3 `Prj` e, tix2 `Prj` e, tix1 `Prj` e, tix0 `Prj` e)++untup8 :: (GPU a, GPU b, GPU c, GPU d, GPU e, GPU f, GPU g, GPU h)+ => Exp stage (a, b, c, d, e, f, g, h) -> (Exp stage a, Exp stage b, Exp stage c, Exp stage d, Exp stage e, Exp stage f, Exp stage g, Exp stage h)+untup8 e = (tix7 `Prj` e, tix6 `Prj` e, tix5 `Prj` e, tix4 `Prj` e, tix3 `Prj` e, tix2 `Prj` e, tix1 `Prj` e, tix0 `Prj` e)++untup9 :: (GPU a, GPU b, GPU c, GPU d, GPU e, GPU f, GPU g, GPU h, GPU i)+ => Exp stage (a, b, c, d, e, f, g, h, i) -> (Exp stage a, Exp stage b, Exp stage c, Exp stage d, Exp stage e, Exp stage f, Exp stage g, Exp stage h, Exp stage i)+untup9 e = (tix8 `Prj` e, tix7 `Prj` e, tix6 `Prj` e, tix5 `Prj` e, tix4 `Prj` e, tix3 `Prj` e, tix2 `Prj` e, tix1 `Prj` e, tix0 `Prj` e)++-- builtin variables+-- vertex shader+vertexID' :: Exp V Int32+vertexID' = PrimVar $ IInt "gl_VertexID"++instanceID' :: Exp V Int32+instanceID' = PrimVar $ IInt "gl_InstanceID"++-- geometry shader+primitiveIDIn' :: Exp G Int32+primitiveIDIn' = PrimVar $ IInt "gl_PrimitiveIDIn"++-- fragment shader+fragCoord' :: Exp F V4F+fragCoord' = PrimVar $ IV4F "gl_FragCoord"++frontFacing' :: Exp F Bool+frontFacing' = PrimVar $ IBool "gl_FrontFacing"++pointCoord' :: Exp F V2F+pointCoord' = PrimVar $ IV2F "gl_PointCoord"++primitiveID' :: Exp F Int32+primitiveID' = PrimVar $ IInt "gl_PrimitiveID"
+ LC_T_PrimFun.hs view
@@ -0,0 +1,172 @@+module LC_T_PrimFun where++import Data.Int+import Data.Word++import LC_G_Type+import LC_T_Sampler+import LC_T_APIType++data PrimFun stage sig where++ -- Vec/Mat (de)construction+ PrimTupToV2 :: IsComponent a => PrimFun stage ((a,a) -> V2 a)+ PrimTupToV3 :: IsComponent a => PrimFun stage ((a,a,a) -> V3 a)+ PrimTupToV4 :: IsComponent a => PrimFun stage ((a,a,a,a) -> V4 a)+ PrimV2ToTup :: IsComponent a => PrimFun stage (V2 a -> (a,a))+ PrimV3ToTup :: IsComponent a => PrimFun stage (V3 a -> (a,a,a))+ PrimV4ToTup :: IsComponent a => PrimFun stage (V4 a -> (a,a,a,a))++ -- Arithmetic Functions (componentwise)+ PrimAdd :: (IsNum t, IsMatVec a t) => PrimFun stage ((a,a) -> a)+ PrimAddS :: (IsNum t, IsMatVecScalar a t) => PrimFun stage ((a,t) -> a)+ PrimSub :: (IsNum t, IsMatVec a t) => PrimFun stage ((a,a) -> a)+ PrimSubS :: (IsNum t, IsMatVecScalar a t) => PrimFun stage ((a,t) -> a)+ PrimMul :: (IsNum t, IsMatVec a t) => PrimFun stage ((a,a) -> a)+ PrimMulS :: (IsNum t, IsMatVecScalar a t) => PrimFun stage ((a,t) -> a)+ PrimDiv :: (IsNum t, IsVecScalar d a t) => PrimFun stage ((a,a) -> a)+ PrimDivS :: (IsNum t, IsVecScalar d a t) => PrimFun stage ((a,t) -> a)+ PrimNeg :: (IsSigned t, IsMatVecScalar a t) => PrimFun stage (a -> a)+ PrimMod :: (IsNum t, IsVecScalar d a t) => PrimFun stage ((a,a) -> a)+ PrimModS :: (IsNum t, IsVecScalar d a t) => PrimFun stage ((a,t) -> a)++ -- Bit-wise Functions+ PrimBAnd :: (IsIntegral t, IsVecScalar d a t) => PrimFun stage ((a,a) -> a)+ PrimBAndS :: (IsIntegral t, IsVecScalar d a t) => PrimFun stage ((a,t) -> a)+ PrimBOr :: (IsIntegral t, IsVecScalar d a t) => PrimFun stage ((a,a) -> a)+ PrimBOrS :: (IsIntegral t, IsVecScalar d a t) => PrimFun stage ((a,t) -> a)+ PrimBXor :: (IsIntegral t, IsVecScalar d a t) => PrimFun stage ((a,a) -> a)+ PrimBXorS :: (IsIntegral t, IsVecScalar d a t) => PrimFun stage ((a,t) -> a)+ PrimBNot :: (IsIntegral t, IsVecScalar d a t) => PrimFun stage (a -> a)+ PrimBShiftL :: (IsIntegral t, IsVecScalar d a t, IsVecScalar d b Word32) => PrimFun stage ((a, b) -> a)+ PrimBShiftLS :: (IsIntegral t, IsVecScalar d a t) => PrimFun stage ((a, Word32) -> a)+ PrimBShiftR :: (IsIntegral t, IsVecScalar d a t, IsVecScalar d b Word32) => PrimFun stage ((a, b) -> a)+ PrimBShiftRS :: (IsIntegral t, IsVecScalar d a t) => PrimFun stage ((a, Word32) -> a)++ -- Logic Functions+ PrimAnd :: PrimFun stage ((Bool,Bool) -> Bool)+ PrimOr :: PrimFun stage ((Bool,Bool) -> Bool)+ PrimXor :: PrimFun stage ((Bool,Bool) -> Bool)+ PrimNot :: IsVecScalar d a Bool => PrimFun stage (a -> a)+ PrimAny :: IsVecScalar d a Bool => PrimFun stage (a -> Bool)+ PrimAll :: IsVecScalar d a Bool => PrimFun stage (a -> Bool)++ -- Angle and Trigonometry Functions+ PrimACos :: IsVecScalar d a Float => PrimFun stage (a -> a)+ PrimACosH :: IsVecScalar d a Float => PrimFun stage (a -> a)+ PrimASin :: IsVecScalar d a Float => PrimFun stage (a -> a)+ PrimASinH :: IsVecScalar d a Float => PrimFun stage (a -> a)+ PrimATan :: IsVecScalar d a Float => PrimFun stage (a -> a)+ PrimATan2 :: IsVecScalar d a Float => PrimFun stage ((a,a) -> a)+ PrimATanH :: IsVecScalar d a Float => PrimFun stage (a -> a)+ PrimCos :: IsVecScalar d a Float => PrimFun stage (a -> a)+ PrimCosH :: IsVecScalar d a Float => PrimFun stage (a -> a)+ PrimDegrees :: IsVecScalar d a Float => PrimFun stage (a -> a)+ PrimRadians :: IsVecScalar d a Float => PrimFun stage (a -> a)+ PrimSin :: IsVecScalar d a Float => PrimFun stage (a -> a)+ PrimSinH :: IsVecScalar d a Float => PrimFun stage (a -> a)+ PrimTan :: IsVecScalar d a Float => PrimFun stage (a -> a)+ PrimTanH :: IsVecScalar d a Float => PrimFun stage (a -> a)++ -- Exponential Functions+ PrimPow :: IsVecScalar d a Float => PrimFun stage ((a,a) -> a)+ PrimExp :: IsVecScalar d a Float => PrimFun stage (a -> a)+ PrimLog :: IsVecScalar d a Float => PrimFun stage (a -> a)+ PrimExp2 :: IsVecScalar d a Float => PrimFun stage (a -> a)+ PrimLog2 :: IsVecScalar d a Float => PrimFun stage (a -> a)+ PrimSqrt :: IsVecScalar d a Float => PrimFun stage (a -> a)+ PrimInvSqrt :: IsVecScalar d a Float => PrimFun stage (a -> a)++ -- Common Functions+ PrimIsNan :: (IsVecScalar d a Float, IsVecScalar d b Bool) => PrimFun stage (a -> b)+ PrimIsInf :: (IsVecScalar d a Float, IsVecScalar d b Bool) => PrimFun stage (a -> b)+ PrimAbs :: (IsSigned t, IsVecScalar d a t) => PrimFun stage (a -> a)+ PrimSign :: (IsSigned t, IsVecScalar d a t) => PrimFun stage (a -> a)+ PrimFloor :: IsVecScalar d a Float => PrimFun stage (a -> a)+ PrimTrunc :: IsVecScalar d a Float => PrimFun stage (a -> a)+ PrimRound :: IsVecScalar d a Float => PrimFun stage (a -> a)+ PrimRoundEven :: IsVecScalar d a Float => PrimFun stage (a -> a)+ PrimCeil :: IsVecScalar d a Float => PrimFun stage (a -> a)+ PrimFract :: IsVecScalar d a Float => PrimFun stage (a -> a)+ PrimModF :: IsVecScalar d a Float => PrimFun stage (a -> (a,a))+ PrimMin :: (IsNum t, IsVecScalar d a t) => PrimFun stage ((a,a) -> a)+ PrimMinS :: (IsNum t, IsVecScalar d a t) => PrimFun stage ((a,t) -> a)+ PrimMax :: (IsNum t, IsVecScalar d a t) => PrimFun stage ((a,a) -> a)+ PrimMaxS :: (IsNum t, IsVecScalar d a t) => PrimFun stage ((a,t) -> a)+ PrimClamp :: (IsNum t, IsVecScalar d a t) => PrimFun stage ((a,a,a) -> a)+ PrimClampS :: (IsNum t, IsVecScalar d a t) => PrimFun stage ((a,t,t) -> a)+ PrimMix :: IsVecScalar d a Float => PrimFun stage ((a,a,a) -> a)+ PrimMixS :: IsVecScalar d a Float => PrimFun stage ((a,a,Float) -> a)+ PrimMixB :: (IsVecScalar d a Float, IsVecScalar d b Bool) => PrimFun stage ((a,a,b) -> a)+ PrimStep :: IsVec d a Float => PrimFun stage ((a,a) -> a)+ PrimStepS :: IsVecScalar d a Float => PrimFun stage ((Float,a) -> a)+ PrimSmoothStep :: IsVec d a Float => PrimFun stage ((a,a,a) -> a)+ PrimSmoothStepS :: IsVecScalar d a Float => PrimFun stage ((Float,Float,a) -> a)++ -- Integer/Float Conversion Functions+ PrimFloatBitsToInt :: (IsVecScalar d fv Float, IsVecScalar d iv Int32) => PrimFun stage (fv -> iv)+ PrimFloatBitsToUInt :: (IsVecScalar d fv Float, IsVecScalar d uv Word32) => PrimFun stage (fv -> uv)+ PrimIntBitsToFloat :: (IsVecScalar d fv Float, IsVecScalar d iv Int32) => PrimFun stage (iv -> fv)+ PrimUIntBitsToFloat :: (IsVecScalar d fv Float, IsVecScalar d uv Word32) => PrimFun stage (uv -> fv)++ -- Geometric Functions+ PrimLength :: IsVecScalar d a Float => PrimFun stage (a -> Float)+ PrimDistance :: IsVecScalar d a Float => PrimFun stage ((a,a) -> Float)+ PrimDot :: IsVecScalar d a Float => PrimFun stage ((a,a) -> Float)+ PrimCross :: IsVecScalar 3 a Float => PrimFun stage ((a,a) -> a)+ PrimNormalize :: IsVecScalar d a Float => PrimFun stage (a -> a)+ PrimFaceForward :: IsVecScalar d a Float => PrimFun stage ((a,a,a) -> a)+ PrimReflect :: IsVecScalar d a Float => PrimFun stage ((a,a) -> a)+ PrimRefract :: IsVecScalar d a Float => PrimFun stage ((a,a,a) -> a)++ -- Matrix Functions+ PrimTranspose :: (IsMat a h w, IsMat b w h) => PrimFun stage (a -> b)+ PrimDeterminant :: IsMat m s s => PrimFun stage (m -> Float)+ PrimInverse :: IsMat m h w => PrimFun stage (m -> m)+ PrimOuterProduct :: IsMat m h w => PrimFun stage ((w,h) -> m)+ PrimMulMatVec :: IsMat m h w => PrimFun stage ((m,w) -> h)+ PrimMulVecMat :: IsMat m h w => PrimFun stage ((h,m) -> w)+ PrimMulMatMat :: (IsMat a i j, IsMat b j k, IsMat c i k) => PrimFun stage ((a,b) -> c)++ -- Vector and Scalar Relational Functions+ PrimLessThan :: (IsNum t, IsVecScalar d a t, IsVecScalar d b Bool) => PrimFun stage ((a,a) -> b)+ PrimLessThanEqual :: (IsNum t, IsVecScalar d a t, IsVecScalar d b Bool) => PrimFun stage ((a,a) -> b)+ PrimGreaterThan :: (IsNum t, IsVecScalar d a t, IsVecScalar d b Bool) => PrimFun stage ((a,a) -> b)+ PrimGreaterThanEqual :: (IsNum t, IsVecScalar d a t, IsVecScalar d b Bool) => PrimFun stage ((a,a) -> b)+ PrimEqualV :: (IsNum t, IsVecScalar d a t, IsVecScalar d b Bool) => PrimFun stage ((a,a) -> b)+ PrimEqual :: IsMatVecScalar a t => PrimFun stage ((a,a) -> Bool)+ PrimNotEqualV :: (IsNum t, IsVecScalar d a t, IsVecScalar d b Bool) => PrimFun stage ((a,a) -> b)+ PrimNotEqual :: IsMatVecScalar a t => PrimFun stage ((a,a) -> Bool)++ -- Fragment Processing Functions+ PrimDFdx :: IsVecScalar d a Float => PrimFun F (a -> a)+ PrimDFdy :: IsVecScalar d a Float => PrimFun F (a -> a)+ PrimFWidth :: IsVecScalar d a Float => PrimFun F (a -> a)++ -- Noise Functions+ PrimNoise1 :: IsVecScalar d a Float => PrimFun stage (a -> Float)+ PrimNoise2 :: (IsVecScalar d a Float, IsVecScalar 2 b Float) => PrimFun stage (a -> b)+ PrimNoise3 :: (IsVecScalar d a Float, IsVecScalar 3 b Float) => PrimFun stage (a -> b)+ PrimNoise4 :: (IsVecScalar d a Float, IsVecScalar 4 b Float) => PrimFun stage (a -> b)++ -- Texture Lookup Functions+ PrimTextureSize :: IsTextureSize sampler lod size => PrimFun stage ((sampler,lod) -> size)+ PrimTexture :: IsTexture sampler coord bias => PrimFun stage ((sampler,coord) -> TexelRepr sampler)+ PrimTextureB :: IsTexture sampler coord bias => PrimFun F ((sampler,coord,bias) -> TexelRepr sampler)+ PrimTextureProj :: IsTextureProj sampler coord bias => PrimFun stage ((sampler,coord) -> TexelRepr sampler)+ PrimTextureProjB :: IsTextureProj sampler coord bias => PrimFun F ((sampler,coord,bias) -> TexelRepr sampler)+ PrimTextureLod :: IsTextureLod sampler coord lod => PrimFun stage ((sampler,coord,lod) -> TexelRepr sampler)+ PrimTextureOffset :: IsTextureOffset sampler coord offset bias => PrimFun stage ((sampler,coord,offset) -> TexelRepr sampler)+ PrimTextureOffsetB :: IsTextureOffset sampler coord offset bias => PrimFun F ((sampler,coord,offset,bias) -> TexelRepr sampler)+ PrimTexelFetch :: IsTexelFetch sampler coord lod => PrimFun stage ((sampler,coord,lod) -> TexelRepr sampler)+ PrimTexelFetchOffset :: IsTexelFetchOffset sampler coord lod offset => PrimFun stage ((sampler,coord,lod,offset) -> TexelRepr sampler)+ PrimTextureProjOffset :: IsTextureProjOffset sampler coord offset bias => PrimFun stage ((sampler,coord,offset) -> TexelRepr sampler)+ PrimTextureProjOffsetB :: IsTextureProjOffset sampler coord offset bias => PrimFun F ((sampler,coord,offset,bias) -> TexelRepr sampler)+ PrimTextureLodOffset :: IsTextureLodOffset sampler coord lod offset => PrimFun stage ((sampler,coord,lod,offset) -> TexelRepr sampler)+ PrimTextureProjLod :: IsTextureProjLod sampler coord lod => PrimFun stage ((sampler,coord,lod) -> TexelRepr sampler)+ PrimTextureProjLodOffset :: IsTextureProjLodOffset sampler coord lod offset => PrimFun stage ((sampler,coord,lod,offset) -> TexelRepr sampler)+ PrimTextureGrad :: IsTextureGrad sampler coord dx dy => PrimFun stage ((sampler,coord,dx,dy) -> TexelRepr sampler)+ PrimTextureGradOffset :: IsTextureGradOffset sampler coord dx dy offset => PrimFun stage ((sampler,coord,dx,dy,offset) -> TexelRepr sampler)+ PrimTextureProjGrad :: IsTextureProjGrad sampler coord dx dy => PrimFun stage ((sampler,coord,dx,dy) -> TexelRepr sampler)+ PrimTextureProjGradOffset :: IsTextureProjGradOffset sampler coord dx dy offset => PrimFun stage ((sampler,coord,dx,dy,offset) -> TexelRepr sampler)+
+ LC_T_Sampler.hs view
@@ -0,0 +1,263 @@+module LC_T_Sampler where++import Data.Int++import LC_G_Type+import LC_T_DSLType++{-+-- shadow samplers+type Sampler1DShadow = Sampler DIM1 Z Depth Mip Shadow+type Sampler2DShadow = Sampler DIM2 Z Depth Mip Shadow+type SamplerCubeShadow = Sampler DIM2 C Depth Mip Array Shadow+type Sampler1DArrayShadow = Sampler DIM1 A Depth Mip Array Shadow+type Sampler2DArrayShadow = Sampler DIM2 A Depth Mip Array Shadow+type Sampler2DRectShadow = Sampler Rect Z Depth NoMip Shadow++-- float,int,word samplers+type Sampler1D = Sampler DIM1 Z Float Mip Regular+type Sampler2D = Sampler DIM2 Z Float Mip Regular+type Sampler3D = Sampler DIM3 Z Float Mip Regular+type SamplerCube = Sampler DIM2 C Float Mip Regular Array+type Sampler1DArray = Sampler DIM1 A Float Mip Regular Array+type Sampler2DArray = Sampler DIM2 A Float Mip Regular Array+type Sampler2DRect = Sampler Rect Z Float NoMip Regular++type Sampler2DMS = Sampler DIM2 Z FloatMS NoMip -- from previous render pass only+type Sampler2DMSArray = Sampler DIM2 A FloatMS NoMip Array -- from previous render pass only+type SamplerBuffer = Sampler DIM1 Z BufferFloat NoMip+-}++type GSampler1D t ar = Sampler Tex1D SingleTex t ar+type GSampler2D t ar = Sampler Tex2D SingleTex t ar+type GSampler3D t ar = Sampler Tex3D SingleTex t ar+type GSamplerCube t ar = Sampler Tex2D CubeTex t ar+type GSampler1DArray t ar = Sampler Tex1D ArrayTex t ar+type GSampler2DArray t ar = Sampler Tex2D ArrayTex t ar+type GSampler2DRect t ar = Sampler TexRect SingleTex t ar++type family TexelRepr sampler+type instance TexelRepr (Sampler dim arr (v t) Red) = t+type instance TexelRepr (Sampler dim arr (v t) RG) = V2 t+type instance TexelRepr (Sampler dim arr (v t) RGB) = V3 t+type instance TexelRepr (Sampler dim arr (v t) RGBA) = V4 t++-- shadow samplers+type Sampler1DShadow = GSampler1D (Shadow Float) Red+type Sampler2DShadow = GSampler2D (Shadow Float) Red+type SamplerCubeShadow = GSamplerCube (Shadow Float) Red+type Sampler1DArrayShadow = GSampler1DArray (Shadow Float) Red+type Sampler2DArrayShadow = GSampler2DArray (Shadow Float) Red+type Sampler2DRectShadow = GSampler2DRect (Shadow Float) Red++-- float samplers+type Sampler1D t ar = GSampler1D (Regular t) ar+type Sampler2D t ar = GSampler2D (Regular t) ar+type Sampler3D t ar = GSampler3D (Regular t) ar+type SamplerCube t ar = GSamplerCube (Regular t) ar+type Sampler1DArray t ar = GSampler1DArray (Regular t) ar+type Sampler2DArray t ar = GSampler2DArray (Regular t) ar+type Sampler2DRect t ar = GSampler2DRect (Regular t) ar+type Sampler2DMS t ar = GSampler2D (MultiSample t) ar+type Sampler2DMSArray t ar = GSampler2DArray (MultiSample t) ar+type SamplerBuffer t ar = GSampler1D (Buffer t) ar++-- brute force+-- arity problem: lod+-- restriction: NONE+class IsTextureSize sampler lod size | sampler -> lod size+instance IsTextureSize (Sampler1D t ar) Int32 Int32+instance IsTextureSize (Sampler1DArray t ar) Int32 V2I+instance IsTextureSize (Sampler2D t ar) Int32 V2I+instance IsTextureSize (Sampler2DArray t ar) Int32 V3I+instance IsTextureSize (Sampler2DMS t ar) () V2I+instance IsTextureSize (Sampler2DMSArray t ar) () V3I+instance IsTextureSize (Sampler2DRect t ar) () V2I+instance IsTextureSize (Sampler3D t ar) Int32 V3I+instance IsTextureSize (SamplerCube t ar) Int32 V2I+instance IsTextureSize (SamplerBuffer t ar) () Int32+instance IsTextureSize Sampler1DArrayShadow Int32 V2I+instance IsTextureSize Sampler1DShadow Int32 Int32+instance IsTextureSize Sampler2DArrayShadow Int32 V3I+instance IsTextureSize Sampler2DRectShadow () V2I+instance IsTextureSize Sampler2DShadow Int32 V2I+instance IsTextureSize SamplerCubeShadow Int32 V2I++-- arity problem: bias+-- restriction: Regular union Shadow+class IsTexture sampler coord bias | sampler -> coord bias+instance IsTexture (Sampler1D t ar) Float Float+instance IsTexture (Sampler1DArray t ar) V2F Float+instance IsTexture (Sampler2D t ar) V2F Float+instance IsTexture (Sampler2DArray t ar) V3F Float+instance IsTexture (Sampler2DRect t ar) V2F () +instance IsTexture (Sampler3D t ar) V3F Float+instance IsTexture (SamplerCube t ar) V3F Float+instance IsTexture Sampler1DShadow V3F Float+instance IsTexture Sampler1DArrayShadow V3F Float+instance IsTexture Sampler2DShadow V3F Float+instance IsTexture Sampler2DArrayShadow V4F () +instance IsTexture Sampler2DRectShadow V3F () +instance IsTexture SamplerCubeShadow V4F Float++-- arity problem: bias+-- restriction: (Regular union Shadow) exclude Array+class IsTextureProj sampler coord bias | sampler coord -> bias+instance IsTextureProj (Sampler1D t ar) V2F Float+instance IsTextureProj (Sampler1D t ar) V4F Float+instance IsTextureProj (Sampler2D t ar) V3F Float+instance IsTextureProj (Sampler2D t ar) V4F Float+instance IsTextureProj (Sampler2DRect t ar) V3F () +instance IsTextureProj (Sampler2DRect t ar) V4F () +instance IsTextureProj (Sampler3D t ar) V4F Float+instance IsTextureProj Sampler1DShadow V4F Float+instance IsTextureProj Sampler2DRectShadow V4F () +instance IsTextureProj Sampler2DShadow V4F Float++-- arity ok+-- restriction: ((Regular union Shadow) intersection Mip) exclude (2D Shadow Array)+class IsTextureLod sampler coord lod | sampler -> coord lod+instance IsTextureLod (Sampler1D t ar) Float Float+instance IsTextureLod (Sampler1DArray t ar) V2F Float+instance IsTextureLod (Sampler2D t ar) V2F Float+instance IsTextureLod (Sampler2DArray t ar) V3F Float+instance IsTextureLod (Sampler3D t ar) V3F Float+instance IsTextureLod (SamplerCube t ar) V3F Float+instance IsTextureLod Sampler1DShadow V3F Float+instance IsTextureLod Sampler1DArrayShadow V3F Float+instance IsTextureLod Sampler2DShadow V3F Float++-- arity problem: bias+-- restriction: (Regular union Shadow) excluding (Cube, 2D Shadow Array)+class IsTextureOffset sampler coord offset bias | sampler -> coord offset bias+instance IsTextureOffset (Sampler1D t ar) Float Int32 Float+instance IsTextureOffset (Sampler1DArray t ar) V2F Int32 Float+instance IsTextureOffset (Sampler2D t ar) V2F V2I Float+instance IsTextureOffset (Sampler2DArray t ar) V3F V2I Float+instance IsTextureOffset (Sampler2DRect t ar) V2F V2I () +instance IsTextureOffset (Sampler3D t ar) V3F V3I Float+instance IsTextureOffset Sampler1DShadow V3F Int32 Float+instance IsTextureOffset Sampler1DArrayShadow V3F Int32 Float+instance IsTextureOffset Sampler2DShadow V3F V2I Float+instance IsTextureOffset Sampler2DRectShadow V3F V2I () ++-- arity problem: lod, sample+class IsTexelFetch sampler coord lod | sampler -> coord lod+instance IsTexelFetch (Sampler1D t ar) Int32 Int32+instance IsTexelFetch (Sampler1DArray t ar) V2I Int32+instance IsTexelFetch (Sampler2D t ar) V2I Int32+instance IsTexelFetch (Sampler2DArray t ar) V3I Int32+instance IsTexelFetch (Sampler2DMS t ar) V2I Int32+instance IsTexelFetch (Sampler2DMSArray t ar) V3I Int32+instance IsTexelFetch (Sampler2DRect t ar) V2I () +instance IsTexelFetch (Sampler3D t ar) V3I Int32+instance IsTexelFetch (SamplerBuffer t ar) Int32 () ++-- arity problem: lod+class IsTexelFetchOffset sampler coord lod offset | sampler -> coord lod offset+instance IsTexelFetchOffset (Sampler1D t ar) Int32 Int32 Int32+instance IsTexelFetchOffset (Sampler1DArray t ar) V2I Int32 Int32+instance IsTexelFetchOffset (Sampler2D t ar) V2I Int32 V2I +instance IsTexelFetchOffset (Sampler2DArray t ar) V3I Int32 V2I +instance IsTexelFetchOffset (Sampler2DRect t ar) V2I () V2I +instance IsTexelFetchOffset (Sampler3D t ar) V3I Int32 V3I ++-- arity problem: bias+class IsTextureProjOffset sampler coord offset bias | sampler coord -> offset bias+instance IsTextureProjOffset (Sampler1D t ar) V2F Int32 Float+instance IsTextureProjOffset (Sampler1D t ar) V4F Int32 Float+instance IsTextureProjOffset (Sampler2D t ar) V3F V2I Float+instance IsTextureProjOffset (Sampler2D t ar) V4F V2I Float+instance IsTextureProjOffset (Sampler3D t ar) V4F V3I Float+instance IsTextureProjOffset (Sampler2DRect t ar) V3F V2I () +instance IsTextureProjOffset (Sampler2DRect t ar) V4F V2I () +instance IsTextureProjOffset Sampler1DShadow V4F Int32 Float+instance IsTextureProjOffset Sampler2DShadow V4F V2I Float+instance IsTextureProjOffset Sampler2DRectShadow V4F V2I Float++-- arity ok+class IsTextureLodOffset sampler coord lod offset | sampler -> coord lod offset+instance IsTextureLodOffset (Sampler1D t ar) Float Float Int32+instance IsTextureLodOffset (Sampler1DArray t ar) V2F Float Int32+instance IsTextureLodOffset (Sampler2D t ar) V2F Float V2I +instance IsTextureLodOffset (Sampler2DArray t ar) V3F Float V2I +instance IsTextureLodOffset (Sampler3D t ar) V3F Float V3I +instance IsTextureLodOffset Sampler1DShadow V3F Float Int32+instance IsTextureLodOffset Sampler1DArrayShadow V3F Float Int32+instance IsTextureLodOffset Sampler2DShadow V3F Float V2I ++-- arity ok+class IsTextureProjLod sampler coord lod | sampler coord -> lod+instance IsTextureProjLod (Sampler1D t ar) V2F Float+instance IsTextureProjLod (Sampler1D t ar) V4F Float+instance IsTextureProjLod (Sampler2D t ar) V3F Float+instance IsTextureProjLod (Sampler2D t ar) V4F Float+instance IsTextureProjLod (Sampler3D t ar) V4F Float+instance IsTextureProjLod Sampler1DShadow V4F Float+instance IsTextureProjLod Sampler2DShadow V4F Float++-- arity ok+class IsTextureProjLodOffset sampler coord lod offset | sampler coord -> lod offset+instance IsTextureProjLodOffset (Sampler1D t ar) V2F Float Int32+instance IsTextureProjLodOffset (Sampler1D t ar) V4F Float Int32+instance IsTextureProjLodOffset (Sampler2D t ar) V3F Float V2I +instance IsTextureProjLodOffset (Sampler2D t ar) V4F Float V2I +instance IsTextureProjLodOffset (Sampler3D t ar) V4F Float V3I +instance IsTextureProjLodOffset Sampler1DShadow V4F Float Int32+instance IsTextureProjLodOffset Sampler2DShadow V4F Float V2F ++-- arity ok+class IsTextureGrad sampler coord dx dy | sampler -> coord dx dy+instance IsTextureGrad (Sampler1D t ar) Float Float Float+instance IsTextureGrad (Sampler1DArray t ar) V2F Float Float+instance IsTextureGrad (Sampler2D t ar) V2F V2F V2F +instance IsTextureGrad (Sampler2DArray t ar) V3F V2F V2F +instance IsTextureGrad (Sampler2DRect t ar) V2F V2F V2F +instance IsTextureGrad (Sampler3D t ar) V3F V3F V3F +instance IsTextureGrad (SamplerCube t ar) V3F V3F V3F +instance IsTextureGrad Sampler1DArrayShadow V3F Float Float+instance IsTextureGrad Sampler1DShadow V3F Float Float+instance IsTextureGrad Sampler2DArrayShadow V4F V2F V2F +instance IsTextureGrad Sampler2DRectShadow V3F V2F V2F +instance IsTextureGrad Sampler2DShadow V3F V2F V2F +instance IsTextureGrad SamplerCubeShadow V4F V3F V3F ++-- arity ok+class IsTextureGradOffset sampler coord dx dy offset | sampler -> coord dx dy offset+instance IsTextureGradOffset (Sampler1D t ar) Float Float Float Int32+instance IsTextureGradOffset (Sampler1DArray t ar) V2F Float Float Int32+instance IsTextureGradOffset (Sampler2D t ar) V2F V2F V2F V2I +instance IsTextureGradOffset (Sampler2DArray t ar) V3F V2F V2F V2I +instance IsTextureGradOffset (Sampler2DRect t ar) V2F V2F V2F V2I +instance IsTextureGradOffset (Sampler3D t ar) V3F V3F V3F V3I +instance IsTextureGradOffset Sampler1DArrayShadow V3F Float Float Int32+instance IsTextureGradOffset Sampler1DShadow V3F Float Float Int32+instance IsTextureGradOffset Sampler2DArrayShadow V4F V2F V2F V2I +instance IsTextureGradOffset Sampler2DRectShadow V3F V2F V2F V2I +instance IsTextureGradOffset Sampler2DShadow V3F V2F V2F V2I ++-- arity ok+class IsTextureProjGrad sampler coord dx dy | sampler coord -> dx dy+instance IsTextureProjGrad (Sampler1D t ar) V2F Float Float+instance IsTextureProjGrad (Sampler1D t ar) V4F Float Float+instance IsTextureProjGrad (Sampler2D t ar) V3F V2F V2F +instance IsTextureProjGrad (Sampler2D t ar) V4F V2F V2F +instance IsTextureProjGrad (Sampler2DRect t ar) V3F V2F V2F +instance IsTextureProjGrad (Sampler2DRect t ar) V4F V2F V2F +instance IsTextureProjGrad (Sampler3D t ar) V4F V3F V3F +instance IsTextureProjGrad Sampler1DShadow V4F Float Float+instance IsTextureProjGrad Sampler2DRectShadow V4F V2F V2F +instance IsTextureProjGrad Sampler2DShadow V4F V2F V2F ++-- arity ok+class IsTextureProjGradOffset sampler coord dx dy offset | sampler coord -> dx dy offset+instance IsTextureProjGradOffset (Sampler1D t ar) V2F Float Float Int32+instance IsTextureProjGradOffset (Sampler1D t ar) V4F Float Float Int32+instance IsTextureProjGradOffset (Sampler2D t ar) V3F V2F V2F V2I +instance IsTextureProjGradOffset (Sampler2D t ar) V4F V2F V2F V2I +instance IsTextureProjGradOffset (Sampler2DRect t ar) V3F V2F V2F V2I +instance IsTextureProjGradOffset (Sampler2DRect t ar) V4F V2F V2F V2I +instance IsTextureProjGradOffset (Sampler3D t ar) V4F V3F V3F V3I +instance IsTextureProjGradOffset Sampler1DShadow V4F Float Float Int32+instance IsTextureProjGradOffset Sampler2DRectShadow V4F V2F V2F V2I +instance IsTextureProjGradOffset Sampler2DShadow V4F V2F V2F V2I
+ LC_U_APIType.hs view
@@ -0,0 +1,81 @@+module LC_U_APIType where++import Data.ByteString.Char8+import Data.Int++import LC_G_Type++import LC_G_APIType++-- primitive types+data FetchPrimitive+ = Points+ | Lines+ | Triangles+ | LinesAdjacency+ | TrianglesAdjacency+ deriving (Show,Eq,Ord)++data OutputPrimitive+ = TrianglesOutput+ | LinesOutput+ | PointsOutput+ deriving (Show,Eq,Ord)++data ColorArity = Red | RG | RGB | RGBA deriving (Show,Eq,Ord)++data Blending+ = NoBlending+ | BlendLogicOp LogicOperation+ | Blend (BlendEquation, BlendEquation) + ((BlendingFactor, BlendingFactor), (BlendingFactor, BlendingFactor))+ V4F+ deriving (Show,Eq,Ord)++data RasterContext+ = PointCtx PointSize Float PointSpriteCoordOrigin+ | LineCtx Float ProvokingVertex+ | TriangleCtx CullMode PolygonMode PolygonOffset ProvokingVertex+ deriving (Show, Eq, Ord)++data FragmentOperation+ = DepthOp DepthFunction Bool+ | StencilOp StencilTests StencilOps StencilOps+ | ColorOp Blending Value+ deriving (Show, Eq, Ord)++data AccumulationContext+ = AccumulationContext+ { accViewportName :: Maybe ByteString+ , accOperations :: [FragmentOperation]+ }+ deriving (Show, Eq, Ord)++data Image+ = DepthImage Int Float+ | StencilImage Int Int32+ | ColorImage Int Value+ deriving (Show, Eq, Ord)++data TextureDataType+ = FloatT ColorArity+ | IntT ColorArity+ | WordT ColorArity+ | ShadowT+ deriving (Show, Eq, Ord)++data TextureType+ = Texture1D TextureDataType Int+ | Texture2D TextureDataType Int+ | Texture3D TextureDataType+ | TextureCube TextureDataType+ | TextureRect TextureDataType+ | Texture2DMS TextureDataType Int+ | TextureBuffer TextureDataType+ deriving (Show, Eq, Ord)++data MipMap+ = Mip Int Int -- Base level, Max level+ | NoMip + | AutoMip Int Int -- Base level, Max level+ deriving (Show,Eq,Ord)
+ LC_U_DeBruijn.hs view
@@ -0,0 +1,308 @@+module LC_U_DeBruijn where++import Debug.Trace+import Control.Monad.State+import Data.ByteString.Char8 (ByteString)++import LC_G_Type+import LC_G_APIType+import LC_U_APIType+import LC_U_PrimFun++import BiMap+import qualified Data.IntMap as IM++type ExpId = Int++--newtype DAG = DAG (BiMap Exp) deriving Show+data DAG+ = DAG + { dagExp :: BiMap Exp+ , dagTy :: IM.IntMap Ty+ , dagCount :: IM.IntMap Int+ } deriving Show++emptyDAG :: DAG+emptyDAG = DAG empty IM.empty IM.empty++hashcons :: Ty -> Exp -> State DAG ExpId+hashcons !t !e = do+ DAG !m !tm !cm <- get+ case lookup_key e m of+ Nothing -> let (!k,!m') = insert e m+ !tm' = IM.insert k t tm+ !cm' = IM.insert k 1 cm+ in put (DAG m' tm' cm') >> return k+ Just !k -> do+ {-trace ("sharing : " ++ show k ++ " :: " ++ show (tm IM.! k)) $ -}+ let !cm' = IM.adjust (1+) k cm+ put (DAG m tm cm')+ return k+{-+--hashcons = dontShare+dontShare :: Ty -> Exp -> State DAG ExpId+dontShare t e = do+ DAG m tm <- get+ let (k,m') = insert e m+ tm' = IM.insert k t tm+ put (DAG m' tm') >> return k+-}++-- Utility functions for CodeGen+toExp :: DAG -> ExpId -> Exp+toExp (DAG !m _ _) !k = lookup_val k m++toExpId :: DAG -> Exp -> ExpId+toExpId (DAG !m _ _) !v = let Just k = lookup_key v m in k++expIdType :: DAG -> ExpId -> Ty+expIdType (DAG _ !tm _) !k = tm IM.! k++expType :: DAG -> Exp -> Ty+expType dag@(DAG !m !tm _) !e = case lookup_key e m of+ Nothing -> error $ "unknown Exp node: " ++ show e+ Just !k -> expIdType dag k++expIdCount :: DAG -> ExpId -> Int+expIdCount (DAG _ _ !cm) !k = cm IM.! k++expCount :: DAG -> Exp -> Int+expCount dag@(DAG !m !tm !cm) !e = case lookup_key e m of+ Nothing -> error $ "unknown Exp node: " ++ show e+ Just !k -> expIdCount dag k++{-+ TODO:+ represent these as tuples from specific types: VertexOut, GeometryOut, FragmentOut, FragmentOutDepth, FragmentOutRastDepth+-}+data Exp+ -- Fun+ = Lam !ExpId+ | Body !ExpId+ | Var Int String -- index, layout counter+ | Apply !ExpId !ExpId++ -- Exp+ | Const !Value+ | PrimVar !ByteString+ | Uni !ByteString+ | Tup [ExpId]+ | Prj Int !ExpId+ | Cond !ExpId !ExpId !ExpId+ | PrimApp !PrimFun !ExpId+ | Sampler !Filter !EdgeMode !ExpId+ | Loop !ExpId !ExpId !ExpId !ExpId+ -- special tuple expressions+ | VertexOut !ExpId !ExpId [ExpId] [ExpId]+ | GeometryOut !ExpId !ExpId !ExpId [ExpId] [ExpId]+ | FragmentOut [ExpId]+ | FragmentOutDepth !ExpId [ExpId]+ | FragmentOutRastDepth [ExpId]++ -- GP+ | Fetch ByteString FetchPrimitive [(ByteString,InputType)]+ | Transform !ExpId !ExpId+ | Reassemble !ExpId !ExpId+ | Rasterize RasterContext !ExpId+ | FrameBuffer [Image]+ | Accumulate AccumulationContext !ExpId !ExpId !ExpId !ExpId+ | PrjFrameBuffer ByteString Int !ExpId+ | PrjImage ByteString Int !ExpId++ -- Texture+ | TextureSlot ByteString TextureType+ | Texture TextureType Value MipMap [ExpId] -- hint: type, size, mip, data++ -- Interpolated+ | Flat !ExpId+ | Smooth !ExpId+ | NoPerspective !ExpId++ | GeometryShader Int OutputPrimitive Int !ExpId !ExpId !ExpId++ -- FragmentFilter+ | PassAll+ | Filter !ExpId++ -- GPOutput+ | ImageOut ByteString V2U !ExpId+ | ScreenOut !ExpId+ | MultiOut [ExpId]+ deriving (Eq, Ord, Show)++class ExpC exp where+ -- exp constructors+ lam :: Ty -> exp -> exp+ body :: exp -> exp+ var :: Ty -> Int -> String -> exp -- type, index, layout counter (this needed for proper sharing)+ apply :: Ty -> exp -> exp -> exp+ const_ :: Ty -> Value -> exp+ primVar :: Ty -> ByteString -> exp+ uni :: Ty -> ByteString -> exp+ tup :: Ty -> [exp] -> exp+ prj :: Ty -> Int -> exp -> exp+ cond :: Ty -> exp -> exp -> exp -> exp+ primApp :: Ty -> PrimFun -> exp -> exp+ sampler :: Ty -> Filter -> EdgeMode -> exp -> exp+ loop :: Ty -> exp -> exp -> exp -> exp -> exp+ -- special tuple expressions+ vertexOut :: exp -> exp -> [exp] -> [exp] -> exp+ geometryOut :: exp -> exp -> exp -> [exp] -> [exp] -> exp+ fragmentOut :: [exp] -> exp+ fragmentOutDepth :: exp -> [exp] -> exp+ fragmentOutRastDepth :: [exp] -> exp+ -- gp constructors+ fetch :: ByteString -> FetchPrimitive -> [(ByteString,InputType)] -> exp+ transform :: exp -> exp -> exp+ reassemble :: exp -> exp -> exp+ rasterize :: RasterContext -> exp -> exp+ frameBuffer :: [Image] -> exp+ accumulate :: AccumulationContext -> exp -> exp -> exp -> exp -> exp+ prjFrameBuffer :: ByteString -> Int -> exp -> exp+ prjImage :: ByteString -> Int -> exp -> exp+ -- texture constructors+ textureSlot :: ByteString -> TextureType -> exp+ texture :: TextureType -> Value -> MipMap -> [exp] -> exp -- hint: type, size, mip, data+ -- Interpolated constructors+ flat :: exp -> exp+ smooth :: exp -> exp+ noPerspective :: exp -> exp+ -- GeometryShader constructors+ geometryShader :: Int -> OutputPrimitive -> Int -> exp -> exp -> exp -> exp+ -- FragmentFilter constructors+ passAll :: exp+ filter_ :: exp -> exp+ -- GPOutput constructors+ imageOut :: ByteString -> V2U -> exp -> exp+ screenOut :: exp -> exp+ multiOut :: [exp] -> exp++newtype N = N {unN :: State DAG ExpId}++instance ExpC N where+ lam !t !a = N $ do+ !h1 <- unN a+ hashcons t $ Lam h1+ body !a = N $ do+ !h1 <- unN a+ hashcons (Unknown "Body") $ Body h1+ var !t !a !b = N $ hashcons t $ Var a b+ apply !t !a !b = N $ do+ !h1 <- unN a+ !h2 <- unN b+ hashcons t $ Apply h1 h2+ const_ !t !a = N $ hashcons t $ Const a+ primVar !t !a = N $ hashcons t $ PrimVar a+ uni !t !a = N $ hashcons t $ Uni a+ tup !t !a = N $ do+ !h <- mapM unN a+ hashcons t $ Tup h+ prj !t !a !b = N $ do+ !h1 <- unN b+ hashcons t $ Prj a h1+ cond !t !a !b !c = N $ do+ !h1 <- unN a+ !h2 <- unN b+ !h3 <- unN c+ hashcons t $ Cond h1 h2 h3+ primApp !t !a !b = N $ do+ !h1 <- unN b+ hashcons t $ PrimApp a h1+ sampler !t !a !b !c = N $ do+ !h1 <- unN c+ hashcons t $ Sampler a b h1+ loop !t !a !b !c !d = N $ do+ !h1 <- unN a+ !h2 <- unN b+ !h3 <- unN c+ !h4 <- unN d+ hashcons t $ Loop h1 h2 h3 h4++ -- special tuple expressions+ vertexOut !a !b !c !d = N $ do+ !h1 <- unN a+ !h2 <- unN b+ !h3 <- mapM unN c+ !h4 <- mapM unN d+ hashcons (Unknown "VertexOut") $ VertexOut h1 h2 h3 h4+ geometryOut !a !b !c !d !e = N $ do+ !h1 <- unN a+ !h2 <- unN b+ !h3 <- unN c+ !h4 <- mapM unN d+ !h5 <- mapM unN e+ hashcons (Unknown "GeometryOut") $ GeometryOut h1 h2 h3 h4 h5+ fragmentOut !a = N $ do+ !h <- mapM unN a+ hashcons (Unknown "FragmentOut") $ FragmentOut h+ fragmentOutDepth !a !b = N $ do+ !h1 <- unN a+ !h2 <- mapM unN b+ hashcons (Unknown "FragmentOutDepth") $ FragmentOutDepth h1 h2+ fragmentOutRastDepth !a = N $ do+ !h <- mapM unN a+ hashcons (Unknown "FragmentOutRastDepth") $ FragmentOutRastDepth h+ -- gp constructors+ fetch !a !b !c = N $ do+ hashcons VertexStream' $ Fetch a b c+ transform !a !b = N $ do+ !h1 <- unN a+ !h2 <- unN b+ hashcons PrimitiveStream' $ Transform h1 h2+ reassemble !a !b = N $ do+ !h1 <- unN a+ !h2 <- unN b+ hashcons PrimitiveStream' $ Reassemble h1 h2+ rasterize !a !b = N $ do+ !h1 <- unN b+ hashcons FragmentStream' $ Rasterize a h1+ frameBuffer !a = N $ do+ hashcons FrameBuffer' $ FrameBuffer a+ accumulate !a !b !c !d !e = N $ do+ !h1 <- unN b+ !h2 <- unN c+ !h3 <- unN d+ !h4 <- unN e+ hashcons FrameBuffer' $ Accumulate a h1 h2 h3 h4+ prjFrameBuffer !a !b !c = N $ do+ !h1 <- unN c+ hashcons Image' $ PrjFrameBuffer a b h1+ prjImage !a !b !c = N $ do+ !h1 <- unN c+ hashcons Image' $ PrjImage a b h1+ -- texture constructors+ textureSlot !a !b = N $ hashcons (Unknown "TextureSlot") $ TextureSlot a b+ texture !a !b !c !d = N $ do+ !h1 <- mapM unN d+ hashcons (Unknown "Texture") $ Texture a b c h1+ -- Interpolated constructors+ flat !a = N $ do+ !h1 <- unN a+ hashcons (Unknown "Flat") $ Flat h1+ smooth !a = N $ do+ !h1 <- unN a+ hashcons (Unknown "Smooth") $ Smooth h1+ noPerspective !a = N $ do+ !h1 <- unN a+ hashcons (Unknown "NoPerspective") $ NoPerspective h1+ -- GeometryShader constructors+ geometryShader !a !b !c !d !e !f = N $ do+ !h1 <- unN d+ !h2 <- unN e+ !h3 <- unN f+ hashcons (Unknown "GeometryShader") $ GeometryShader a b c h1 h2 h3+ -- FragmentFilter constructors+ passAll = N $ hashcons (Unknown "PassAll") PassAll+ filter_ !a = N $ do+ !h1 <- unN a+ hashcons (Unknown "Filter") $ Filter h1+ -- GPOutput constructors+ imageOut !a !b !c = N $ do+ !h1 <- unN c+ hashcons (Unknown "ImageOut") $ ImageOut a b h1+ screenOut !a = N $ do+ !h1 <- unN a+ hashcons (Unknown "ScreenOut") $ ScreenOut h1+ multiOut !a = N $ do+ !h1 <- mapM unN a+ hashcons (Unknown "MultiOut") $ MultiOut h1
+ LC_U_PrimFun.hs view
@@ -0,0 +1,160 @@+module LC_U_PrimFun where++data PrimFun+ -- Vec/Mat (de)construction+ = PrimTupToV2+ | PrimTupToV3+ | PrimTupToV4+ | PrimV2ToTup+ | PrimV3ToTup+ | PrimV4ToTup++ -- Arithmetic Functions (componentwise)+ | PrimAdd+ | PrimAddS+ | PrimSub+ | PrimSubS+ | PrimMul+ | PrimMulS+ | PrimDiv+ | PrimDivS+ | PrimNeg+ | PrimMod+ | PrimModS++ -- Bit-wise Functions+ | PrimBAnd+ | PrimBAndS+ | PrimBOr+ | PrimBOrS+ | PrimBXor+ | PrimBXorS+ | PrimBNot+ | PrimBShiftL+ | PrimBShiftLS+ | PrimBShiftR+ | PrimBShiftRS++ -- Logic Functions+ | PrimAnd+ | PrimOr+ | PrimXor+ | PrimNot+ | PrimAny+ | PrimAll++ -- Angle and Trigonometry Functions+ | PrimACos+ | PrimACosH+ | PrimASin+ | PrimASinH+ | PrimATan+ | PrimATan2+ | PrimATanH+ | PrimCos+ | PrimCosH+ | PrimDegrees+ | PrimRadians+ | PrimSin+ | PrimSinH+ | PrimTan+ | PrimTanH++ -- Exponential Functions+ | PrimPow+ | PrimExp+ | PrimLog+ | PrimExp2+ | PrimLog2+ | PrimSqrt+ | PrimInvSqrt++ -- Common Functions+ | PrimIsNan+ | PrimIsInf+ | PrimAbs+ | PrimSign+ | PrimFloor+ | PrimTrunc+ | PrimRound+ | PrimRoundEven+ | PrimCeil+ | PrimFract+ | PrimModF+ | PrimMin+ | PrimMinS+ | PrimMax+ | PrimMaxS+ | PrimClamp+ | PrimClampS+ | PrimMix+ | PrimMixS+ | PrimMixB+ | PrimStep+ | PrimStepS+ | PrimSmoothStep+ | PrimSmoothStepS++ -- Integer/Float Conversion Functions+ | PrimFloatBitsToInt+ | PrimFloatBitsToUInt+ | PrimIntBitsToFloat+ | PrimUIntBitsToFloat++ -- Geometric Functions+ | PrimLength+ | PrimDistance+ | PrimDot+ | PrimCross+ | PrimNormalize+ | PrimFaceForward+ | PrimReflect+ | PrimRefract++ -- Matrix Functions+ | PrimTranspose+ | PrimDeterminant+ | PrimInverse+ | PrimOuterProduct+ | PrimMulMatVec+ | PrimMulVecMat+ | PrimMulMatMat++ -- Vector and Scalar Relational Functions+ | PrimLessThan+ | PrimLessThanEqual+ | PrimGreaterThan+ | PrimGreaterThanEqual+ | PrimEqualV+ | PrimEqual+ | PrimNotEqualV+ | PrimNotEqual++ -- Fragment Processing Functions+ | PrimDFdx+ | PrimDFdy+ | PrimFWidth++ -- Noise Functions+ | PrimNoise1+ | PrimNoise2+ | PrimNoise3+ | PrimNoise4++ -- Texture Lookup Functions+ | PrimTextureSize+ | PrimTexture+ | PrimTextureProj+ | PrimTextureLod+ | PrimTextureOffset+ | PrimTexelFetch+ | PrimTexelFetchOffset+ | PrimTextureProjOffset+ | PrimTextureLodOffset+ | PrimTextureProjLod+ | PrimTextureProjLodOffset+ | PrimTextureGrad+ | PrimTextureGradOffset+ | PrimTextureProjGrad+ | PrimTextureProjGradOffset+ deriving (Eq, Ord, Show)
+ LICENSE view
@@ -0,0 +1,28 @@+Copyright (c) 2009-2012, Csaba Hruska+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice,+ this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of its contributors may be+ used to endorse or promote products derived from this software without+ specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE+LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR+CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF+SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS+INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN+CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)+ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ lambdacube-core.cabal view
@@ -0,0 +1,93 @@+Name: lambdacube-core+Version: 0.1.0+Cabal-Version: >= 1.6 && < 2+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://lambdacube3d.wordpress.com/+Bug-Reports: https://github.com/csabahruska/lc-dsl/issues+Category: Graphics+Tested-With: GHC == 7.6.3+Synopsis: LambdaCube 3D is a domain specific language and library that makes it possible to program GPUs in a purely functional style.+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 "LC_API" and+ "LC_Mesh" modules. You should check out the pointers at <http://lambdacube3d.wordpress.com/getting-started/>+ to understand the principle behind the library, and also have a good look+ at the @lambdacube-samples@ package.++Library+ Build-Depends:+ base >=4.6 && <4.7, containers >=0.5 && <0.6, mtl >=2.1 && <2.2, bytestring >=0.10 && <0.11, bytestring-trie >=0.2 && <0.3, vector >=0.10 && <0.11, OpenGLRaw >=1.4 && <1.5, bitmap >=0.0 && <0.1, prettyclass >=1.0 && <1.1, language-glsl >=0.0 && <0.1, binary >=0.7 && <0.8+ Exposed-modules:+ BiMap+ LC_API+ LC_B_GL+ LC_B_GLCompile+ LC_B_GLData+ LC_B_GLSLCodeGen+ LC_B_GLType+ LC_B_GLUtil+ LC_B_Traversals+ LC_C_Convert+ LC_C_PrimFun+ LC_G_APIType+ LC_G_Type+ LC_Mesh+ LC_T_APIType+ LC_T_DSLType+ LC_T_HOAS+ LC_T_Language+ LC_T_PrimFun+ LC_T_Sampler+ LC_U_APIType+ LC_U_DeBruijn+ LC_U_PrimFun+ + 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++ Extensions:+ BangPatterns+ ConstraintKinds+ DataKinds+ DeriveDataTypeable+ EmptyDataDecls+ FlexibleContexts+ FlexibleInstances+ FunctionalDependencies+ GADTs+ ImpredicativeTypes+ KindSignatures+ MultiParamTypeClasses+ OverloadedStrings+ ParallelListComp+ Rank2Types+ ScopedTypeVariables+ StandaloneDeriving+ TupleSections+ TypeFamilies+ TypeOperators+ TypeSynonymInstances