diff --git a/BiMap.hs b/BiMap.hs deleted file mode 100644 --- a/BiMap.hs +++ /dev/null @@ -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 diff --git a/LC_API.hs b/LC_API.hs deleted file mode 100644 --- a/LC_API.hs +++ /dev/null @@ -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" diff --git a/LC_B_GL.hs b/LC_B_GL.hs deleted file mode 100644 --- a/LC_B_GL.hs +++ /dev/null @@ -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 - } diff --git a/LC_B_GLCompile.hs b/LC_B_GLCompile.hs deleted file mode 100644 --- a/LC_B_GLCompile.hs +++ /dev/null @@ -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) diff --git a/LC_B_GLData.hs b/LC_B_GLData.hs deleted file mode 100644 --- a/LC_B_GLData.hs +++ /dev/null @@ -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 diff --git a/LC_B_GLSLCodeGen.hs b/LC_B_GLSLCodeGen.hs deleted file mode 100644 --- a/LC_B_GLSLCodeGen.hs +++ /dev/null @@ -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 diff --git a/LC_B_GLType.hs b/LC_B_GLType.hs deleted file mode 100644 --- a/LC_B_GLType.hs +++ /dev/null @@ -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) diff --git a/LC_B_GLUtil.hs b/LC_B_GLUtil.hs deleted file mode 100644 --- a/LC_B_GLUtil.hs +++ /dev/null @@ -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 diff --git a/LC_B_Traversals.hs b/LC_B_Traversals.hs deleted file mode 100644 --- a/LC_B_Traversals.hs +++ /dev/null @@ -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 _ _ = [] diff --git a/LC_C_Convert.hs b/LC_C_Convert.hs deleted file mode 100644 --- a/LC_C_Convert.hs +++ /dev/null @@ -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 diff --git a/LC_C_PrimFun.hs b/LC_C_PrimFun.hs deleted file mode 100644 --- a/LC_C_PrimFun.hs +++ /dev/null @@ -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 diff --git a/LC_G_APIType.hs b/LC_G_APIType.hs deleted file mode 100644 --- a/LC_G_APIType.hs +++ /dev/null @@ -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) diff --git a/LC_G_Type.hs b/LC_G_Type.hs deleted file mode 100644 --- a/LC_G_Type.hs +++ /dev/null @@ -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 diff --git a/LC_Mesh.hs b/LC_Mesh.hs deleted file mode 100644 --- a/LC_Mesh.hs +++ /dev/null @@ -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 diff --git a/LC_T_APIType.hs b/LC_T_APIType.hs deleted file mode 100644 --- a/LC_T_APIType.hs +++ /dev/null @@ -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 diff --git a/LC_T_DSLType.hs b/LC_T_DSLType.hs deleted file mode 100644 --- a/LC_T_DSLType.hs +++ /dev/null @@ -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 diff --git a/LC_T_HOAS.hs b/LC_T_HOAS.hs deleted file mode 100644 --- a/LC_T_HOAS.hs +++ /dev/null @@ -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 diff --git a/LC_T_Language.hs b/LC_T_Language.hs deleted file mode 100644 --- a/LC_T_Language.hs +++ /dev/null @@ -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" diff --git a/LC_T_PrimFun.hs b/LC_T_PrimFun.hs deleted file mode 100644 --- a/LC_T_PrimFun.hs +++ /dev/null @@ -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) - diff --git a/LC_T_Sampler.hs b/LC_T_Sampler.hs deleted file mode 100644 --- a/LC_T_Sampler.hs +++ /dev/null @@ -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 diff --git a/LC_U_APIType.hs b/LC_U_APIType.hs deleted file mode 100644 --- a/LC_U_APIType.hs +++ /dev/null @@ -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) diff --git a/LC_U_DeBruijn.hs b/LC_U_DeBruijn.hs deleted file mode 100644 --- a/LC_U_DeBruijn.hs +++ /dev/null @@ -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 diff --git a/LC_U_PrimFun.hs b/LC_U_PrimFun.hs deleted file mode 100644 --- a/LC_U_PrimFun.hs +++ /dev/null @@ -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) diff --git a/lambdacube-core.cabal b/lambdacube-core.cabal --- a/lambdacube-core.cabal +++ b/lambdacube-core.cabal @@ -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 - 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 diff --git a/src/lib/LambdaCube/Core/DeBruijn.hs b/src/lib/LambdaCube/Core/DeBruijn.hs new file mode 100644 --- /dev/null +++ b/src/lib/LambdaCube/Core/DeBruijn.hs @@ -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 diff --git a/src/lib/LambdaCube/Core/PrimFun.hs b/src/lib/LambdaCube/Core/PrimFun.hs new file mode 100644 --- /dev/null +++ b/src/lib/LambdaCube/Core/PrimFun.hs @@ -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) diff --git a/src/lib/LambdaCube/Core/Traversals.hs b/src/lib/LambdaCube/Core/Traversals.hs new file mode 100644 --- /dev/null +++ b/src/lib/LambdaCube/Core/Traversals.hs @@ -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 _ _ = [] diff --git a/src/lib/LambdaCube/Core/Type.hs b/src/lib/LambdaCube/Core/Type.hs new file mode 100644 --- /dev/null +++ b/src/lib/LambdaCube/Core/Type.hs @@ -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) diff --git a/src/lib/LambdaCube/Core/Util/BiMap.hs b/src/lib/LambdaCube/Core/Util/BiMap.hs new file mode 100644 --- /dev/null +++ b/src/lib/LambdaCube/Core/Util/BiMap.hs @@ -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