lambdacube-core 0.1.0 → 0.2.0
raw patch · 29 files changed
+939/−7832 lines, 29 filesdep −OpenGLRawdep −binarydep −bitmapdep ~basedep ~mtl
Dependencies removed: OpenGLRaw, binary, bitmap, language-glsl, prettyclass
Dependency ranges changed: base, mtl
Files
- BiMap.hs +0/−54
- LC_API.hs +0/−240
- LC_B_GL.hs +0/−385
- LC_B_GLCompile.hs +0/−540
- LC_B_GLData.hs +0/−312
- LC_B_GLSLCodeGen.hs +0/−869
- LC_B_GLType.hs +0/−168
- LC_B_GLUtil.hs +0/−972
- LC_B_Traversals.hs +0/−94
- LC_C_Convert.hs +0/−279
- LC_C_PrimFun.hs +0/−167
- LC_G_APIType.hs +0/−394
- LC_G_Type.hs +0/−240
- LC_Mesh.hs +0/−187
- LC_T_APIType.hs +0/−518
- LC_T_DSLType.hs +0/−622
- LC_T_HOAS.hs +0/−236
- LC_T_Language.hs +0/−508
- LC_T_PrimFun.hs +0/−172
- LC_T_Sampler.hs +0/−263
- LC_U_APIType.hs +0/−81
- LC_U_DeBruijn.hs +0/−308
- LC_U_PrimFun.hs +0/−160
- lambdacube-core.cabal +24/−63
- src/lib/LambdaCube/Core/DeBruijn.hs +411/−0
- src/lib/LambdaCube/Core/PrimFun.hs +160/−0
- src/lib/LambdaCube/Core/Traversals.hs +52/−0
- src/lib/LambdaCube/Core/Type.hs +241/−0
- src/lib/LambdaCube/Core/Util/BiMap.hs +51/−0
− BiMap.hs
@@ -1,54 +0,0 @@--- 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
@@ -1,240 +0,0 @@-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
@@ -1,385 +0,0 @@-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
@@ -1,540 +0,0 @@-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
@@ -1,312 +0,0 @@-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
@@ -1,869 +0,0 @@-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
@@ -1,168 +0,0 @@-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
@@ -1,972 +0,0 @@-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
@@ -1,94 +0,0 @@-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
@@ -1,279 +0,0 @@-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
@@ -1,167 +0,0 @@-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
@@ -1,394 +0,0 @@-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
@@ -1,240 +0,0 @@-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
@@ -1,187 +0,0 @@-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
@@ -1,518 +0,0 @@-{-# 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
@@ -1,622 +0,0 @@-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
@@ -1,236 +0,0 @@-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
@@ -1,508 +0,0 @@-{-# 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
@@ -1,172 +0,0 @@-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
@@ -1,263 +0,0 @@-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
@@ -1,81 +0,0 @@-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
@@ -1,308 +0,0 @@-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
@@ -1,160 +0,0 @@-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)
lambdacube-core.cabal view
@@ -1,6 +1,6 @@ Name: lambdacube-core-Version: 0.1.0-Cabal-Version: >= 1.6 && < 2+Version: 0.2.0+Cabal-Version: >= 1.10 Build-Type: Simple License: BSD3 License-File: LICENSE@@ -10,50 +10,29 @@ 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.+Tested-With: GHC == 7.8.2+Synopsis: LambdaCube 3D IR 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+ base >=4.6 && <5,+ containers >=0.5 && <0.6,+ mtl >=2.2 && <2.3,+ bytestring >=0.10 && <0.11,+ bytestring-trie >=0.2 && <0.3,+ vector >=0.10 && <0.11++ default-language: Haskell2010+ hs-source-dirs: src/lib+ 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- + LambdaCube.Core.Util.BiMap+ LambdaCube.Core.Traversals+ LambdaCube.Core.PrimFun+ LambdaCube.Core.Type+ LambdaCube.Core.DeBruijn+-- LambdaCube.Core.DeBruijnRec+ GHC-options: -- -Werror -Wall@@ -64,30 +43,12 @@ -fno-warn-unused-do-bind -fspec-constr-count=10 -funbox-strict-fields- -O2+ -O0 -- for profiling -- -auto-all -- -caf-all - Extensions:- BangPatterns- ConstraintKinds- DataKinds+ default-extensions: DeriveDataTypeable- EmptyDataDecls- FlexibleContexts- FlexibleInstances- FunctionalDependencies- GADTs- ImpredicativeTypes- KindSignatures- MultiParamTypeClasses- OverloadedStrings- ParallelListComp- Rank2Types- ScopedTypeVariables- StandaloneDeriving- TupleSections- TypeFamilies- TypeOperators+ BangPatterns TypeSynonymInstances
+ src/lib/LambdaCube/Core/DeBruijn.hs view
@@ -0,0 +1,411 @@+module LambdaCube.Core.DeBruijn where++import Debug.Trace+import Control.Monad.State+import Data.ByteString.Char8 (ByteString)++import LambdaCube.Core.Type+import LambdaCube.Core.PrimFun++import LambdaCube.Core.Util.BiMap+import qualified Data.IntMap as IM++import Data.Vector ((!),Vector,(//))+import qualified Data.IntSet as IS+import qualified Data.Vector as V+import Data.List (foldl')+import Data.Maybe (maybeToList)++type ExpId = Int++--newtype DAG = DAG (BiMap Exp) deriving Show+data DAG+ = DAG + { dagExp :: BiMap Exp+ , dagTy :: IM.IntMap Ty+ , dagCount :: IM.IntMap Int+ , expUniverseV :: V.Vector [Exp]+ , gpUniverseV :: V.Vector [Exp]+ } deriving (Show,Read)+++-- HINT: traveres over one accumulation's sub expressions including samplers covering multiple passes, but does not include the whole accumulation chain+expUniverse :: Int -> Exp -> V.Vector IS.IntSet -> IS.IntSet+expUniverse expId exp v = (\l -> IS.unions $ IS.singleton expId : (map (v !) l)) $ case exp of+ Lam a -> [a]+ Body a -> [a]+ Apply a b -> [a, b]+ Tup a -> a+ Prj _ a -> [a]+ Cond a b c -> [a, b, c]+ PrimApp _ a -> [a]+ Loop a b c d -> [a, b, c, d]+ VertexOut a b c d -> [a, b] ++ c ++ d+ GeometryOut a b c d e -> [a, b, c] ++ d ++ e+ FragmentOut a -> a+ FragmentOutDepth a b -> a : b+ FragmentOutRastDepth a -> a+ Transform a b -> [a, b]+ Reassemble a b -> [a, b]+ Rasterize _ a -> [a]+ Accumulate a b c d _ -> [a, b, c, d]+ PrjFrameBuffer _ _ a -> [a]+ PrjImage _ _ a -> [a]+ Filter a -> [a]+ Flat a -> [a]+ Smooth a -> [a]+ NoPerspective a -> [a]+ GeometryShader _ _ _ a b c -> [a, b, c]+ Sampler _ _ a -> [a]+ AccumulationContext a _ -> maybeToList a+ ScreenOut a -> [a]+ SamplerOut _ a -> [a]+ _ -> []++mkExpUni :: DAG -> V.Vector [Exp]+mkExpUni dag = V.map (\is -> [exps ! i | i <- IS.elems is]) $ foldl' (\v i -> V.snoc v $ expUniverse i (toExp dag i) v) V.empty [0..s-1]+ where+ s = IM.size im+ exps = V.generate s (im IM.!)+ BiMap _ im = dagExp dag++gpUniverse :: Int -> Exp -> V.Vector IS.IntSet -> IS.IntSet+gpUniverse expId exp v = (\l -> IS.unions $ IS.singleton expId : (map (v !) l)) $ case exp of+ Transform _ a -> [a]+ Reassemble _ a -> [a]+ Rasterize _ a -> [a]+ Accumulate _ _ _ a b -> [a, b]+ PrjFrameBuffer _ _ a -> [a]+ PrjImage _ _ a -> [a]+ _ -> []++mkGPUni :: DAG -> V.Vector [Exp]+mkGPUni dag = V.map (\is -> reverse [exps ! i | i <- IS.elems is]) $ foldl' (\v i -> V.snoc v $ gpUniverse i (toExp dag i) v) V.empty [0..s-1]+ where+ s = IM.size im+ exps = V.generate s (im IM.!)+ BiMap _ im = dagExp dag++{-+myNub l = go IS.empty l+ where+ go s [] = []+ go s (x:xs)+ | IS.member x s = go s xs+ | otherwise = x : go (IS.insert x s) xs++gpUniverse :: Int -> Exp -> V.Vector [ExpId] -> [ExpId]+gpUniverse expId exp v = (\l -> myNub $ concat $ [expId] : (map (v !) l)) $ case exp of+ Transform _ a -> [a]+ Reassemble _ a -> [a]+ Rasterize _ a -> [a]+ Accumulate _ _ _ a b -> [a, b]+ PrjFrameBuffer _ _ a -> [a]+ PrjImage _ _ a -> [a]+ _ -> []++mkGPUni :: DAG -> V.Vector [Exp]+mkGPUni dag = V.map (\is -> [exps ! i | i <- is]) $ foldl' (\v i -> V.snoc v $ gpUniverse i (toExp dag i) v) V.empty [0..s-1]+ where+ s = IM.size im+ exps = V.generate s (im IM.!)+ BiMap _ im = dagExp dag+-}+emptyDAG :: DAG+emptyDAG = DAG empty IM.empty IM.empty V.empty V.empty++hashcons :: Ty -> Exp -> State DAG ExpId+hashcons !t !e = do+ DAG !m !tm !cm !uv !gv <- 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' uv gv) >> 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' uv gv)+ 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 !ExpId !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+ | SamplerOut ByteString !ExpId+ | ScreenOut !ExpId+ | MultiOut [ExpId]++ -- Contexts+ | AccumulationContext !(Maybe ExpId) [FragmentOperation]+ deriving (Eq, Ord, Show, Read)++class ExpC exp where+ -- exp constructors+ let_ :: exp -> (exp -> exp) -> exp+ 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+ accumulationContext :: Maybe exp -> [FragmentOperation] -> exp+ accumulate :: exp -> 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+ samplerOut :: ByteString -> exp -> exp+ screenOut :: exp -> exp+ multiOut :: [exp] -> exp++newtype N = N {unN :: State DAG ExpId}++instance ExpC N where+ let_ !e !f = N(do+ x <- unN e+ unN $ f (N (return x)))+ 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 (Unknown "VertexStream") $ Fetch a b c+ transform !a !b = N $ do+ !h1 <- unN a+ !h2 <- unN b+ hashcons (Unknown "PrimitiveStream") $ Transform h1 h2+ reassemble !a !b = N $ do+ !h1 <- unN a+ !h2 <- unN b+ hashcons (Unknown "PrimitiveStream") $ Reassemble h1 h2+ rasterize !a !b = N $ do+ !h1 <- unN b+ hashcons (Unknown "FragmentStream") $ Rasterize a h1+ frameBuffer !a = N $ do+ hashcons (Unknown "FrameBuffer") $ FrameBuffer a+ accumulationContext !a !b = N $ do+ !h1 <- case a of+ Nothing -> return Nothing+ Just v -> fmap Just $ unN v+ hashcons (Unknown "AccumulationContext") $ AccumulationContext h1 b+ accumulate !a !b !c !d !e = N $ do+ !h0 <- unN a+ !h1 <- unN b+ !h2 <- unN c+ !h3 <- unN d+ !h4 <- unN e+ hashcons (Unknown "FrameBuffer") $ Accumulate h0 h1 h2 h3 h4+ prjFrameBuffer !a !b !c = N $ do+ !h1 <- unN c+ hashcons (Unknown "Image") $ PrjFrameBuffer a b h1+ prjImage !a !b !c = N $ do+ !h1 <- unN c+ hashcons (Unknown "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+ samplerOut !a !b = N $ do+ !h1 <- unN b+ hashcons (Unknown "SamplerOut") $ SamplerOut a 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
+ src/lib/LambdaCube/Core/PrimFun.hs view
@@ -0,0 +1,160 @@+module LambdaCube.Core.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, Read)
+ src/lib/LambdaCube/Core/Traversals.hs view
@@ -0,0 +1,52 @@+module LambdaCube.Core.Traversals where++import Data.List+import Data.IntSet (IntSet)+import qualified Data.IntSet as IntSet++import LambdaCube.Core.Type+import LambdaCube.Core.DeBruijn hiding (expUniverse, gpUniverse)+import Data.Vector ((!),Vector,(//))++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 = expUniverseV dag ! toExpId dag exp+ expUniverse' dag exp = exp : expUniverse dag exp++gpUniverse :: DAG -> Exp -> [Exp]+gpUniverse dag gp = gp : gpUniverseV dag ! toExpId dag gp++-- includes the origin+gpUniverse' :: DAG -> Exp -> [Exp]+gpUniverse' dag gp = gp : gpUniverse dag gp++findFrameBuffer :: DAG -> Exp -> Exp+findFrameBuffer dag a = case dropWhile notFrameBuffer $ gpUniverse' dag a of+ e:_ -> e+ _ -> error "findFrameBuffer: nil"+ 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 _ _ = []
+ src/lib/LambdaCube/Core/Type.hs view
@@ -0,0 +1,241 @@+module LambdaCube.Core.Type where++import Data.Typeable++import Data.Int+import Data.Word++data V2 a = V2 !a !a deriving (Read,Eq,Ord,Show,Typeable)+data V3 a = V3 !a !a !a deriving (Read,Eq,Ord,Show,Typeable)+data V4 a = V4 !a !a !a !a deriving (Read,Eq,Ord,Show,Typeable)++-- 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++-- 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 (Read,Typeable,Show,Eq,Ord)++data Ty+ = Single !InputType+ | Tuple [Ty]+ | Unknown String+ deriving (Read,Typeable,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 (Read,Typeable,Show,Eq,Ord)++data PointSpriteCoordOrigin = LowerLeft | UpperLeft deriving (Read,Typeable,Show, Eq, Ord)+data PointSize = PointSize Float | ProgramPointSize deriving (Read,Typeable,Eq,Ord,Show)+data PolygonOffset = NoOffset | Offset Float Float deriving (Read,Typeable,Eq,Ord,Show)+data FrontFace = CCW | CW deriving (Read,Typeable,Eq,Ord,Show)+data PolygonMode = PolygonPoint PointSize | PolygonLine Float | PolygonFill deriving (Read,Typeable,Eq,Ord,Show)+data ProvokingVertex = FirstVertex | LastVertex deriving (Read,Typeable,Eq,Ord,Bounded,Enum,Show)+data CullMode = CullNone | CullFront FrontFace | CullBack FrontFace deriving (Read,Typeable,Eq,Ord,Show)+type DepthFunction = ComparisonFunction+data ComparisonFunction = Never | Less | Equal | Lequal | Greater | Notequal | Gequal | Always deriving (Read,Typeable, Eq, Ord, Show )+data StencilOperation = OpZero | OpKeep | OpReplace | OpIncr | OpIncrWrap | OpDecr | OpDecrWrap | OpInvert deriving (Read,Typeable, Eq, Ord, Show )+data BlendEquation = FuncAdd | FuncSubtract | FuncReverseSubtract | Min | Max deriving (Read,Typeable, Eq, Ord, Show )+data BlendingFactor = Zero | One | SrcColor | OneMinusSrcColor | DstColor | OneMinusDstColor | SrcAlpha | OneMinusSrcAlpha | DstAlpha | OneMinusDstAlpha | ConstantColor | OneMinusConstantColor | ConstantAlpha | OneMinusConstantAlpha | SrcAlphaSaturate deriving (Read,Typeable, Eq, Ord, Show )+data LogicOperation = Clear | And | AndReverse | Copy | AndInverted | Noop | Xor | Or | Nor | Equiv | Invert | OrReverse | CopyInverted | OrInverted | Nand | Set deriving (Read,Typeable, Eq, Ord, Show )++data StencilOps+ = StencilOps+ { frontStencilOp :: StencilOperation -- ^ Used for front faced triangles and other primitives.+ , backStencilOp :: StencilOperation -- ^ Used for back faced triangles.+ } deriving (Read,Typeable,Eq,Ord,Show)++data StencilTests = StencilTests StencilTest StencilTest deriving (Read,Typeable,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 (Read,Typeable,Eq,Ord,Show)++-- sampler and texture specification+data Filter = PointFilter | LinearFilter deriving (Read,Typeable,Show,Eq,Ord)+data EdgeMode = Repeat | MirroredRepeat | ClampToEdge | ClampToBorder deriving (Read,Typeable,Show,Eq,Ord)++-- primitive types+data FetchPrimitive+ = Points+ | Lines+ | Triangles+ | LinesAdjacency+ | TrianglesAdjacency+ deriving (Read,Show,Eq,Ord)++data OutputPrimitive+ = TrianglesOutput+ | LinesOutput+ | PointsOutput+ deriving (Read,Show,Eq,Ord)++data ColorArity = Red | RG | RGB | RGBA deriving (Read,Show,Eq,Ord)++data Blending+ = NoBlending+ | BlendLogicOp LogicOperation+ | Blend (BlendEquation, BlendEquation) + ((BlendingFactor, BlendingFactor), (BlendingFactor, BlendingFactor))+ V4F+ deriving (Read,Show,Eq,Ord)++data RasterContext+ = PointCtx PointSize Float PointSpriteCoordOrigin+ | LineCtx Float ProvokingVertex+ | TriangleCtx CullMode PolygonMode PolygonOffset ProvokingVertex+ deriving (Read,Show, Eq, Ord)++data FragmentOperation+ = DepthOp DepthFunction Bool+ | StencilOp StencilTests StencilOps StencilOps+ | ColorOp Blending Value+ deriving (Read,Show, Eq, Ord)++data Image+ = DepthImage Int Float+ | StencilImage Int Int32+ | ColorImage Int Value+ | UnclearedImage Int+ deriving (Read,Show, Eq, Ord)++data TextureDataType+ = FloatT ColorArity+ | IntT ColorArity+ | WordT ColorArity+ | ShadowT+ deriving (Read,Show, Eq, Ord)++data TextureType+ = Texture1D TextureDataType Int+ | Texture2D TextureDataType Int+ | Texture3D TextureDataType+ | TextureCube TextureDataType+ | TextureRect TextureDataType+ | Texture2DMS TextureDataType Int+ | TextureBuffer TextureDataType+ deriving (Read,Show, Eq, Ord)++data MipMap+ = Mip Int Int -- Base level, Max level+ | NoMip + | AutoMip Int Int -- Base level, Max level+ deriving (Read,Show,Eq,Ord)
+ src/lib/LambdaCube/Core/Util/BiMap.hs view
@@ -0,0 +1,51 @@+-- 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 LambdaCube.Core.Util.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) deriving (Show,Read)++-- 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)++size :: BiMap a -> Int+size (BiMap _ m) = IM.size m