GPipe (empty) → 1.0.0
raw patch · 17 files changed
+2815/−0 lines, 17 filesdep +Booleandep +GLUTdep +OpenGLsetup-changed
Dependencies added: Boolean, GLUT, OpenGL, Vec, base, containers, mtl
Files
- GPipe.cabal +59/−0
- Setup.lhs +6/−0
- src/Formats.hs +274/−0
- src/GPUStream.hs +175/−0
- src/Graphics/GPipe.hs +36/−0
- src/Graphics/GPipe/Format.hs +39/−0
- src/Graphics/GPipe/FrameBuffer.hs +72/−0
- src/Graphics/GPipe/Stream.hs +33/−0
- src/Graphics/GPipe/Stream/Fragment.hs +63/−0
- src/Graphics/GPipe/Stream/Primitive.hs +60/−0
- src/Graphics/GPipe/Texture.hs +46/−0
- src/InputAssembler.hs +104/−0
- src/OutputMerger.hs +444/−0
- src/Rasterizer.hs +130/−0
- src/Resources.hs +411/−0
- src/Shader.hs +525/−0
- src/Textures.hs +338/−0
+ GPipe.cabal view
@@ -0,0 +1,59 @@+name: GPipe+version: 1.0.0+cabal-version: >= 1.2.3+build-type: Simple+license: BSD3+license-file: ""+copyright: Tobias Bexelius+maintainer: Tobias Bexelius+build-depends: Boolean -any, GLUT >=2.2.2.0, OpenGL >=2.4.0.1,+ Vec -any, base == 4.1.0.0, containers -any, mtl -any+stability: Experimental+homepage:+package-url:+bug-reports: mailto:tobias_bexelius@hotmail.com+synopsis: A functional graphics API for programmable GPUs+description: GPipe models the entire graphics pipeline in a purely functional, immutable and typesafe way. It is built on top of the programmable pipeline (i.e. non-fixed function) of+ OpenGL 2.1 and uses features such as vertex buffer objects (VBO's), texture objects and GLSL shader code synthetisation to create fast graphics programs. Buffers,+ textures and shaders are cached internally to ensure fast framerate, and GPipe is also capable of managing multiple windows and contexts. By creating your own+ instances of GPipes classes, it's possible to use additional datatypes on the GPU.+ .+ You'll need full OpenGL 2.1 support, including GLSL 1.20 to use GPipe. Thanks to OpenGLRaw, you may still build GPipe programs on machines lacking this support.+category: Graphics+author: Tobias Bexelius+tested-with: GHC ==6.10.3+data-files:+data-dir: ""+extra-source-files:+extra-tmp-files:+exposed-modules: Graphics.GPipe Graphics.GPipe.Format+ Graphics.GPipe.FrameBuffer Graphics.GPipe.Stream+ Graphics.GPipe.Texture Graphics.GPipe.Stream.Fragment+ Graphics.GPipe.Stream.Primitive+exposed: True+buildable: True+build-tools:+cpp-options:+cc-options:+ld-options:+pkgconfig-depends:+frameworks:+c-sources:+extensions: ParallelListComp MultiParamTypeClasses+ NoMonomorphismRestriction ScopedTypeVariables FlexibleContexts+ FlexibleInstances EmptyDataDecls GeneralizedNewtypeDeriving+ TypeFamilies TypeOperators+extra-libraries:+extra-lib-dirs:+includes:+install-includes:+include-dirs:+hs-source-dirs: src+other-modules: Formats GPUStream InputAssembler OutputMerger+ Rasterizer Resources Shader Textures+ghc-prof-options:+ghc-shared-options:+ghc-options:+hugs-options:+nhc98-options:+jhc-options:
+ Setup.lhs view
@@ -0,0 +1,6 @@+#!/usr/bin/runhaskell +> module Main where +> import Distribution.Simple +> main :: IO () +> main = defaultMain +
+ src/Formats.hs view
@@ -0,0 +1,274 @@+----------------------------------------------------------------------------- +-- +-- Module : Formats +-- Copyright : Tobias Bexelius +-- License : BSD3 +-- +-- Maintainer : Tobias Bexelius +-- Stability : Experimental +-- Portability : Portable +-- +-- | +-- +----------------------------------------------------------------------------- + +module Formats +( + AlphaFormat(..), + DepthFormat(..), + StencilFormat(..), + LuminanceFormat(..), + LuminanceAlphaFormat(..), + RGBFormat(..), + RGBAFormat(..), + CPUFormat4Comp(..), + CPUFormat3Comp(..), + CPUFormat2Comp(..), + CPUFormat1Comp(..), + StorableCPUFormat(toGLDataType), + formatRowByteSize, + GPUFormat(..), + ColorFormat(fromColor,toColor), -- (..) will give a warning that Color is exported twice, even though we need to export it explicitly to get its constructors + Color(..), + Depth, + Stencil +) +where +import qualified Graphics.Rendering.OpenGL as GL +import Data.Vec ((:.)(..), Vec3, Vec4) + +-- | A GPU format with only an alpha value.+-- These are the associated types in 'GPUFormat' and 'ColorFormat':+--+-- [@CPUFormat AlphaFormat@] 'CPUFormat1Comp'+--+-- [@Color AlphaFormat a@] @Alpha a@+data AlphaFormat = Alpha4 | Alpha8 | Alpha12 | Alpha16 deriving (Eq,Ord,Bounded,Enum,Show) +-- | A GPU format with a single color component. +-- These are the associated types in 'GPUFormat' and 'ColorFormat':+--+-- [@CPUFormat AlphaFormat@] 'CPUFormat1Comp'+--+-- [@Color AlphaFormat a@] @Luminance a@+data LuminanceFormat = Luminance4 | Luminance8 | Luminance12 | Luminance16 | SLuminance8 deriving (Eq,Ord,Bounded,Enum,Show) +-- | A GPU format with a single color component and an alpha value. +-- These are the associated types in 'GPUFormat' and 'ColorFormat':+--+-- [@CPUFormat AlphaFormat@] 'CPUFormat2Comp'+--+-- [@Color AlphaFormat a@] @LuminanceAlpha a a@+data LuminanceAlphaFormat = Luminance4Alpha4 | Luminance6Alpha2 | Luminance8Alpha8 | Luminance12Alpha4 | Luminance12Alpha12 | Luminance16Alpha16 | SLuminance8Alpha8 deriving (Eq,Ord,Bounded,Enum,Show) +-- | A GPU format with color components for red, green and blue. +-- These are the associated types in 'GPUFormat' and 'ColorFormat':+--+-- [@CPUFormat AlphaFormat@] 'CPUFormat3Comp'+--+-- [@Color AlphaFormat a@] @RGB (@'Vec3'@ a)@+data RGBFormat = R3G3B2 | RGB4 | RGB5 | RGB8 | RGB10 | RGB12 | RGB16 | SRGB8 deriving (Eq,Ord,Bounded,Enum,Show) +-- | A GPU format with color components for red, green and blue, and an alpha value. +-- These are the associated types in 'GPUFormat' and 'ColorFormat':+--+-- [@CPUFormat AlphaFormat@] 'CPUFormat4Comp'+--+-- [@Color AlphaFormat a@] @RGBA (@'Vec3'@ a) a@+data RGBAFormat = RGBA2 | RGBA4 | RGB5A1 | RGBA8 | RGB10A2 | RGBA12 | RGBA16 | SRGBA8 deriving (Eq,Ord,Bounded,Enum,Show) +-- | A GPU format for a depth buffer value. +-- This is the associated type in 'GPUFormat':+--+-- [@CPUFormat AlphaFormat@] 'CPUFormat1Comp'+data DepthFormat = Depth16 | Depth24 | Depth32 deriving (Eq,Ord,Bounded,Enum,Show) +-- | A GPU format for a stencil buffer value. +-- This is the associated type in 'GPUFormat':+--+-- [@CPUFormat AlphaFormat@] 'CPUFormat1Comp'+data StencilFormat = StencilFormat deriving (Eq,Ord,Bounded,Enum,Show) ++-- | A CPU format for 4 components (i.e. a RGBA color). +data CPUFormat4Comp = PerComp4 CPUFormat1Comp + | UnsignedShort4_4_4_4 + | UnsignedShort4_4_4_4_Rev + | UnsignedShort5_5_5_1 + | UnsignedShort1_5_5_5_Rev + | UnsignedInt8_8_8_8 + | UnsignedInt8_8_8_8_Rev + | UnsignedInt10_10_10_2 + | UnsignedInt2_10_10_10_Rev + deriving (Eq,Ord,Show) + +-- | A CPU format for 3 components (i.e. a RGB color). +data CPUFormat3Comp = PerComp3 CPUFormat1Comp + | UnsignedByte3_3_2 + | UnsignedByte2_3_3_Rev + | UnsignedShort5_6_5 + | UnsignedShort5_6_5_Rev + deriving (Eq,Ord,Show) + +-- | A CPU format for 2 components (i.e. a LuminanceAlpha color). +data CPUFormat2Comp = PerComp2 CPUFormat1Comp + deriving (Eq,Ord,Show) + +-- | A CPU format for 1 component +data CPUFormat1Comp = UnsignedByteFormat + | BitmapFormat + | ByteFormat + | UnsignedShortFormat + | ShortFormat + | UnsignedIntFormat + | IntFormat + | FloatFormat + deriving (Eq,Ord,Show) ++class StorableCPUFormat a where + sizeOfFormat :: a -> Int + toGLDataType :: a -> GL.DataType + +formatRowByteSize :: StorableCPUFormat a => a -> Int -> Int +formatRowByteSize f x = ((x*sizeOfFormat f-1) `div` 8 + 1) ++instance StorableCPUFormat CPUFormat4Comp where + sizeOfFormat (PerComp4 a) = 4 * sizeOfFormat a + sizeOfFormat UnsignedShort4_4_4_4 = 16 + sizeOfFormat UnsignedShort4_4_4_4_Rev = 16 + sizeOfFormat UnsignedShort5_5_5_1 = 16 + sizeOfFormat UnsignedShort1_5_5_5_Rev = 16 + sizeOfFormat UnsignedInt8_8_8_8 = 32 + sizeOfFormat UnsignedInt8_8_8_8_Rev = 32 + sizeOfFormat UnsignedInt10_10_10_2 = 32 + sizeOfFormat UnsignedInt2_10_10_10_Rev = 32 + toGLDataType (PerComp4 a) = toGLDataType a + toGLDataType UnsignedShort4_4_4_4 = GL.UnsignedShort4444 + toGLDataType UnsignedShort4_4_4_4_Rev = GL.UnsignedShort4444Rev + toGLDataType UnsignedShort5_5_5_1 = GL.UnsignedShort5551 + toGLDataType UnsignedShort1_5_5_5_Rev = GL.UnsignedShort1555Rev + toGLDataType UnsignedInt8_8_8_8 = GL.UnsignedInt8888 + toGLDataType UnsignedInt8_8_8_8_Rev = GL.UnsignedInt8888Rev + toGLDataType UnsignedInt10_10_10_2 = GL.UnsignedInt1010102 + toGLDataType UnsignedInt2_10_10_10_Rev = GL.UnsignedInt2101010Rev +instance StorableCPUFormat CPUFormat3Comp where + sizeOfFormat (PerComp3 a) = 3 * sizeOfFormat a + sizeOfFormat UnsignedByte3_3_2 = 8 + sizeOfFormat UnsignedByte2_3_3_Rev = 8 + sizeOfFormat UnsignedShort5_6_5 = 16 + sizeOfFormat UnsignedShort5_6_5_Rev = 16 + toGLDataType (PerComp3 a) = toGLDataType a + toGLDataType UnsignedByte3_3_2 = GL.UnsignedByte332 + toGLDataType UnsignedByte2_3_3_Rev = GL.UnsignedByte233Rev + toGLDataType UnsignedShort5_6_5 = GL.UnsignedShort565 + toGLDataType UnsignedShort5_6_5_Rev = GL.UnsignedShort565Rev + +instance StorableCPUFormat CPUFormat2Comp where + sizeOfFormat (PerComp2 a) = 2 * sizeOfFormat a + toGLDataType (PerComp2 a) = toGLDataType a + +instance StorableCPUFormat CPUFormat1Comp where + sizeOfFormat UnsignedByteFormat = 8 + sizeOfFormat BitmapFormat = 1 + sizeOfFormat ByteFormat = 8 + sizeOfFormat UnsignedShortFormat = 16 + sizeOfFormat ShortFormat = 16 + sizeOfFormat UnsignedIntFormat = 32 + sizeOfFormat IntFormat = 32 + sizeOfFormat FloatFormat = 32 + toGLDataType UnsignedByteFormat = GL.UnsignedByte + toGLDataType BitmapFormat = GL.Bitmap + toGLDataType ByteFormat = GL.Byte + toGLDataType UnsignedShortFormat = GL.UnsignedShort + toGLDataType ShortFormat = GL.Short + toGLDataType UnsignedIntFormat = GL.UnsignedInt + toGLDataType IntFormat = GL.Int + toGLDataType FloatFormat = GL.Float + +class (StorableCPUFormat (CPUFormat f), Eq (CPUFormat f))=> GPUFormat f where + type CPUFormat f + toGLInternalFormat :: f -> GL.PixelInternalFormat + toGLPixelFormat :: f -> GL.PixelFormat ++-- | This context is used to select which types can be used in a frame buffers color buffer, and also+-- to restrict the type of a texture. +class GPUFormat f => ColorFormat f where + data Color f :: * -> * + fromColor :: a -> a -> Color f a -> Vec4 a + toColor :: Vec4 a -> Color f a + +type Depth = Float +type Stencil = Int + +instance GPUFormat AlphaFormat where + type CPUFormat AlphaFormat = CPUFormat1Comp + toGLInternalFormat Alpha4 = GL.Alpha4 + toGLInternalFormat Alpha8 = GL.Alpha8 + toGLInternalFormat Alpha12 = GL.Alpha12 + toGLInternalFormat Alpha16 = GL.Alpha16 + toGLPixelFormat _ = GL.Alpha +instance GPUFormat DepthFormat where + type CPUFormat DepthFormat = CPUFormat1Comp + toGLInternalFormat Depth16 = GL.DepthComponent16 + toGLInternalFormat Depth24 = GL.DepthComponent24 + toGLInternalFormat Depth32 = GL.DepthComponent32 + toGLPixelFormat _ = GL.DepthComponent +instance GPUFormat StencilFormat where + type CPUFormat StencilFormat = CPUFormat1Comp + toGLInternalFormat = error "Stencil has no GLFormat" + toGLPixelFormat _ = GL.StencilIndex +instance GPUFormat LuminanceFormat where + type CPUFormat LuminanceFormat = CPUFormat1Comp + toGLInternalFormat Luminance4 = GL.Luminance4 + toGLInternalFormat Luminance8 = GL.Luminance8 + toGLInternalFormat Luminance12 = GL.Luminance12 + toGLInternalFormat Luminance16 = GL.Luminance16 + toGLInternalFormat SLuminance8 = GL.SLuminance8 + toGLPixelFormat _ = GL.Luminance +instance GPUFormat LuminanceAlphaFormat where + type CPUFormat LuminanceAlphaFormat = CPUFormat2Comp + toGLInternalFormat Luminance4Alpha4 = GL.Luminance4Alpha4 + toGLInternalFormat Luminance6Alpha2 = GL.Luminance6Alpha2 + toGLInternalFormat Luminance8Alpha8 = GL.Luminance8Alpha8 + toGLInternalFormat Luminance12Alpha4 = GL.Luminance12Alpha4 + toGLInternalFormat Luminance12Alpha12 = GL.Luminance12Alpha12 + toGLInternalFormat Luminance16Alpha16 = GL.Luminance16Alpha16 + toGLInternalFormat SLuminance8Alpha8 = GL.SLuminance8Alpha8 + toGLPixelFormat _ = GL.LuminanceAlpha +instance GPUFormat RGBFormat where + type CPUFormat RGBFormat = CPUFormat3Comp + toGLInternalFormat R3G3B2 = GL.R3G3B2 + toGLInternalFormat RGB4 = GL.RGB4 + toGLInternalFormat RGB5 = GL.RGB5 + toGLInternalFormat RGB8 = GL.RGB8 + toGLInternalFormat RGB10 = GL.RGB10 + toGLInternalFormat RGB12 = GL.RGB12 + toGLInternalFormat RGB16 = GL.RGB16 + toGLInternalFormat SRGB8 = GL.SRGB8 + toGLPixelFormat _ = GL.RGB +instance GPUFormat RGBAFormat where + type CPUFormat RGBAFormat = CPUFormat4Comp + toGLInternalFormat RGBA2 = GL.RGBA2 + toGLInternalFormat RGBA4 = GL.RGBA4 + toGLInternalFormat RGB5A1 = GL.RGB5A1 + toGLInternalFormat RGBA8 = GL.RGBA8 + toGLInternalFormat RGB10A2 = GL.RGB10A2 + toGLInternalFormat RGBA12 = GL.RGBA12 + toGLInternalFormat RGBA16 = GL.RGBA16 + toGLInternalFormat SRGBA8 = GL.SRGB8Alpha8 + toGLPixelFormat _ = GL.RGBA + +instance ColorFormat AlphaFormat where + data Color AlphaFormat a = Alpha a deriving (Eq,Ord,Show) + fromColor x _ (Alpha a) = x:.x:.x:.a:.() + toColor (_:._:._:.d:.()) = Alpha d +instance ColorFormat LuminanceFormat where + data Color LuminanceFormat a = Luminance a deriving (Eq,Ord,Show) + fromColor x w (Luminance a) = a:.x:.x:.w:.() + toColor (a:._:._:._:.()) = Luminance a +instance ColorFormat LuminanceAlphaFormat where + data Color LuminanceAlphaFormat a = LuminanceAlpha a a deriving (Eq,Ord,Show) + fromColor x _ (LuminanceAlpha a b) = a:.x:.x:.b:.() + toColor (a:._:._:.d:.()) = LuminanceAlpha a d +instance ColorFormat RGBFormat where + data Color RGBFormat a = RGB (Vec3 a) deriving (Eq,Ord,Show) + fromColor _ w (RGB (a:.b:.c:.())) = a:.b:.c:.w:.() + toColor (a:.b:.c:._:.()) = RGB $ a:.b:.c:.() +instance ColorFormat RGBAFormat where + data Color RGBAFormat a = RGBA (Vec3 a) a deriving (Eq,Ord,Show) + fromColor _ _ (RGBA (a:.b:.c:.()) d) = a:.b:.c:.d:.() + toColor (a:.b:.c:.d:.()) = RGBA (a:.b:.c:.()) d +
+ src/GPUStream.hs view
@@ -0,0 +1,175 @@+----------------------------------------------------------------------------- +-- +-- Module : GPUStream +-- Copyright : Tobias Bexelius +-- License : BSD3 +-- +-- Maintainer : Tobias Bexelius +-- Stability : Experimental +-- Portability : Portable +--+-- | +----------------------------------------------------------------------------- + +module GPUStream ( + PrimitiveStream(..), + FragmentStream(..), + VertexPosition, + CullMode(..), + Primitive(..), + Triangle(..), + Line(..), + Point(..), + VertexSetup(..), + FragmentSetup, + PrimitiveStreamDesc, + FragmentStreamDesc, + filterFragments, + loadFragmentColorStream, + loadFragmentDepthStream, + loadFragmentColorDepthStream, + loadFragmentAnyStream +) where + +import Shader +import Formats +import Data.Monoid +import Data.Vec (Vec4) +import Resources +import qualified Graphics.Rendering.OpenGL as GL (PrimitiveMode(..)) +import Graphics.Rendering.OpenGL (cullFace, ($=), Face(..)) +import Control.Arrow (first, second) ++-- | A stream of primitives built by vertices on the GPU. The first parameter is the primitive type (currently 'Triangle', 'Line' or 'Point') and the second the+-- the type of each primitives' vertices' type (built up of atoms of type 'Vertex'). +newtype PrimitiveStream p a = PrimitiveStream [(PrimitiveStreamDesc, a)] +-- | A stream of fragments on the GPU, parameterized on the fragments type+-- (built up of atoms of type 'Fragment'). +newtype FragmentStream a = FragmentStream [(FragmentStreamDesc, Fragment Bool, a)] + +type VertexPosition = Vec4 (Vertex Float) +data CullMode = CullNone | CullFront | CullBack deriving (Eq,Ord,Bounded,Enum,Show) +data VertexSetup = VertexSetup [[Float]] | IndexedVertexSetup [[Float]] [Int] deriving (Eq,Ord,Show) +type FragmentSetup = [Shader String] +type PrimitiveStreamDesc = (GL.PrimitiveMode, VertexSetup) +type FragmentStreamDesc = (PrimitiveStreamDesc, CullMode, FragmentSetup, Shader String) + +instance Functor (PrimitiveStream p) where + fmap f (PrimitiveStream a) = PrimitiveStream $ map (second f) a +instance Functor FragmentStream where + fmap f (FragmentStream a) = FragmentStream $ map (\(x,y,z) -> (x, y, f z)) a + +instance Monoid (PrimitiveStream p a) where + mempty = PrimitiveStream [] + PrimitiveStream a `mappend` PrimitiveStream b = PrimitiveStream (a ++ b) +instance Monoid (FragmentStream a) where + mempty = FragmentStream [] + FragmentStream a `mappend` FragmentStream b = FragmentStream (a ++ b) + +-- | Filters out fragments in a stream where the provided function returns 'true'. +filterFragments :: (a -> Fragment Bool) -> FragmentStream a -> FragmentStream a +filterFragments f (FragmentStream xs) = FragmentStream $ map filterOne xs + where filterOne (fdesc, b, a) = (fdesc, b &&* f a, a) + + +----------------------------------------- + +class Primitive p where + getPrimitiveMode :: p -> GL.PrimitiveMode ++data Triangle = TriangleStrip | TriangleList | TriangleFan deriving (Eq,Ord,Bounded,Enum,Show) +data Line = LineStrip | LineList deriving (Eq,Ord,Bounded,Enum,Show) +data Point = PointList deriving (Eq,Ord,Bounded,Enum,Show) + +instance Primitive Triangle where + getPrimitiveMode TriangleStrip = GL.TriangleStrip + getPrimitiveMode TriangleList = GL.Triangles + getPrimitiveMode TriangleFan = GL.TriangleFan +instance Primitive Line where + getPrimitiveMode LineStrip = GL.LineStrip + getPrimitiveMode LineList = GL.Lines +instance Primitive Point where + getPrimitiveMode PointList = GL.Points + +----------------------------------------- +loadFragmentColorStream :: ColorFormat f => FragmentStream (Color f (Fragment Float)) -> ContextCacheIO () -> ContextCacheIO ()+loadFragmentColorStream = loadFragmentColorStream' . fmap (fromColor 0 1) + where loadFragmentColorStream' (FragmentStream xs) = layerMapM_ drawCallColor xs +loadFragmentDepthStream :: FragmentStream (Fragment Float) -> ContextCacheIO () -> ContextCacheIO ()+loadFragmentDepthStream (FragmentStream xs) = layerMapM_ (drawCallColorDepth . setDefaultColor) xs + where + setDefaultColor (desc, notDisc, d) = (desc, notDisc, (0,d)) + +loadFragmentColorDepthStream :: ColorFormat f => FragmentStream (Color f (Fragment Float), Fragment Float) -> ContextCacheIO () -> ContextCacheIO ()+loadFragmentColorDepthStream = loadFragmentColorDepthStream' . fmap (first (fromColor 0 1)) + where loadFragmentColorDepthStream' (FragmentStream xs) = layerMapM_ drawCallColorDepth xs +loadFragmentAnyStream :: FragmentStream a -> ContextCacheIO () -> ContextCacheIO ()+loadFragmentAnyStream (FragmentStream xs) = layerMapM_ (drawCallColor . setDefaultColor) xs + where + setDefaultColor (desc, notDisc, _) = (desc, notDisc, 0) + +layerMapM_ f (x:xs) io = layerMapM_ f xs (f x io) +layerMapM_ _ [] io = io + +drawCallColor (((p, vs), cull, rast, vPos), nd, c) io = + let (fp, funs, fins) = fragmentProgram $ colorFragmentShader nd c + (vp, vuns, vins) = vertexProgram vPos rast fins + in drawCall p cull vins vs vp fp vuns funs io + +drawCallColorDepth (((p, vs), cull, rast, vPos), nd, cd) io = + let (fp, funs, fins) = fragmentProgram $ colorDepthFragmentShader nd cd + (vp, vuns, vins) = vertexProgram vPos rast fins + in drawCall p cull vins vs vp fp vuns funs io + + +mapSelect = map . select + where select (x:xs) ys = let (a:b) = drop x ys + in a: select (map (\t-> t-x-1) xs) b + select [] _ = [] + + +drawCall p cull ins (VertexSetup v) vp fp vuns funs io = do + xs <- ioEvaluate (mapSelect ins v) + ins' <- ioEvaluate ins + vp' <- ioEvaluate vp + fp' <- ioEvaluate fp + s <- ioEvaluate (length ins) + vs <- ioEvaluate (length v) + vuns'<-ioEvaluate vuns + funs'<-ioEvaluate funs + cull'<-ioEvaluate cull + p'<-ioEvaluate p + io + (pr, (vu, fu)) <- createProgramResource vp' fp' s + vb <- createVertexBuffer xs ins' v + useProgramResource pr + useUniforms vu vuns' + useUniforms fu funs' + liftIO $ do useCull cull' + drawVertexBuffer p' vb vs + +drawCall p cull ins (IndexedVertexSetup v i) vp fp vuns funs io = do + i' <- ioEvaluate i + xs <- ioEvaluate (mapSelect ins v) + ins' <- ioEvaluate ins + vp' <- ioEvaluate vp + fp' <- ioEvaluate fp + s <- ioEvaluate (length ins) + vs <- ioEvaluate (length v) + vuns'<-ioEvaluate vuns + funs'<-ioEvaluate funs + cull'<-ioEvaluate cull + p'<-ioEvaluate p + io + (pr, (vu, fu)) <- createProgramResource vp' fp' s + ib <- createIndexBuffer i' vs + vb <- createVertexBuffer xs ins' v + useProgramResource pr + useUniforms vu vuns' + useUniforms fu funs' + liftIO $ do useCull cull' + drawIndexVertexBuffer p' vb ib + +useCull CullNone = cullFace $= Nothing +useCull CullFront = cullFace $= Just Front +useCull CullBack = cullFace $= Just Back
+ src/Graphics/GPipe.hs view
@@ -0,0 +1,36 @@+----------------------------------------------------------------------------- +-- +-- Module : GPipe +-- Copyright : Tobias Bexelius +-- License : BSD3 +-- +-- Maintainer : Tobias Bexelius +-- Stability : Experimental +-- Portability : Portable +-- +-- |+-- GPipe models the entire graphics pipeline in a purely functional, immutable and typesafe way. It is built on top of the programmable pipeline (i.e. non-fixed function) of+-- OpenGL 2.1 and uses features such as vertex buffer objects (VBO's), texture objects and GLSL shader code synthetisation to create fast graphics programs. Buffers,+-- textures and shaders are cached internally to ensure fast framerate, and GPipe is also capable of managing multiple windows and contexts. By creating your own+-- instances of GPipes classes, it's possible to use additional datatypes on the GPU.+--+-- You'll need full OpenGL 2.1 support, including GLSL 1.20 to use GPipe. Thanks to OpenGLRaw, you may still build GPipe programs on machines lacking this support.+--+-- This is a conveniance module, combining GPipes all other modules. +----------------------------------------------------------------------------- + +module Graphics.GPipe (+ module Graphics.GPipe.Stream, + module Graphics.GPipe.Stream.Primitive, + module Graphics.GPipe.Stream.Fragment, + module Graphics.GPipe.FrameBuffer, + module Graphics.GPipe.Texture, + module Graphics.GPipe.Format,+) where + +import Graphics.GPipe.Stream +import Graphics.GPipe.Stream.Primitive +import Graphics.GPipe.Stream.Fragment +import Graphics.GPipe.FrameBuffer +import Graphics.GPipe.Texture +import Graphics.GPipe.Format
+ src/Graphics/GPipe/Format.hs view
@@ -0,0 +1,39 @@+-----------------------------------------------------------------------------+--+-- Module : Graphics.GPipe.Format+-- Copyright : Tobias Bexelius+-- License : BSD3+--+-- Maintainer : Tobias Bexelius+-- Stability : Experimental+-- Portability : Portable+--+-- | This module defines the various formats that are used by 'FrameBuffer's and textures, both+-- in the GPU and the CPU.+-----------------------------------------------------------------------------++module Graphics.GPipe.Format (+ -- * GPU formats+ AlphaFormat(..), + LuminanceFormat(..), + LuminanceAlphaFormat(..), + RGBFormat(..), + RGBAFormat(..), + DepthFormat(..), + StencilFormat(..), + GPUFormat(type CPUFormat), + ColorFormat(), + Color(..), + Depth, + Stencil, + -- * CPU formats+ CPUFormat4Comp(..), + CPUFormat3Comp(..), + CPUFormat2Comp(..), + CPUFormat1Comp(..), + StorableCPUFormat(),++) where+ +import Formats +
+ src/Graphics/GPipe/FrameBuffer.hs view
@@ -0,0 +1,72 @@+-----------------------------------------------------------------------------+--+-- Module : Graphics.GPipe.FrameBuffer+-- Copyright : Tobias Bexelius+-- License : BSD3+--+-- Maintainer : Tobias Bexelius+-- Stability : Experimental+-- Portability : Portable+--+-- | 'FrameBuffer's are 2D images in which fragments from 'FragmentStream's are painted. A 'FrameBuffer'+-- may contain any combination of a color buffer, a depth buffer and a stencil buffer.+-- 'FrameBuffer's may be shown in windows, saved to memory or converted to textures.+-- 'FrameBuffer's have no size, but takes the size of the window when shown, or are given a size when+-- saved to memory or converted to a texture.+-----------------------------------------------------------------------------++module Graphics.GPipe.FrameBuffer (+ -- * The data type+ FrameBuffer(), + -- * Displaying framebuffers+ newWindow,+ -- * Creation + -- | These functions create new 'FrameBuffer's with initial color, depth values and\/or stencil values.+ newFrameBufferColor, + newFrameBufferColorDepth, + newFrameBufferColorStencil, + newFrameBufferColorDepthStencil, + newFrameBufferDepth, + newFrameBufferStencil, + newFrameBufferDepthStencil, + -- * Data retrieval+ -- | These functions provides the means for saving a 'FrameBuffer' to main memory without the need to+ -- show it in a window.+ getFrameBufferColor, + getFrameBufferDepth, + getFrameBufferStencil, + getFrameBufferCPUFormatByteSize, + -- * Paint operations+ -- | These functions paint 'FragmentStream's on 'FrameBuffer's. A lot of different functions are+ -- provided for different types of 'FrameBuffer's and 'FragmentStream's, all which takes more or less+ -- state values. The preffered way of using those is to curry them into the specific functions you need+ -- in your GPipe program, e.g.+ --+ -- @paintSolid =@ 'paintColorRastDepth' 'Lequal' 'True' 'NoBlending' @(RGB (vec@ 'True'@))@+ --+ -- The @RastDepth@-functions uses the rasterized depth for the fragments.+ --+ -- Functions with two 'StencilOps' arguments use them in this order: First if stencil test fail, second if stencil test pass.+ -- Functions with three 'StencilOps' arguments use them in this order: First if stencil test fail, second if depth test fail, third if depth test pass.+ paintColor, + paintDepth, + paintColorDepth, + paintStencil, + paintDepthStencil, + paintColorStencil, + paintColorDepthStencil, + paintRastDepth, + paintColorRastDepth, + paintRastDepthStencil, + paintColorRastDepthStencil, + ColorMask, Blending(..), BlendEquation(..), BlendingFactor(..), LogicOp(..),+ ComparisonFunction(..), DepthFunction, DepthMask,+ StencilOps(..), StencilOp(..), StencilTest(..), StencilTests(..), + FragmentDepth, +) where++import OutputMerger + +++
+ src/Graphics/GPipe/Stream.hs view
@@ -0,0 +1,33 @@+-----------------------------------------------------------------------------+--+-- Module : Graphics.GPipe.Stream+-- Copyright : Tobias Bexelius+-- License : BSD3+--+-- Maintainer : Tobias Bexelius+-- Stability : Experimental+-- Portability : Portable+--+-- | A GPipe program mainly consits of creating and manipulating streams of primitives and fragments.+-- The modules "Graphics.GPipe.Stream.Primitive" and "Graphics.GPipe.Stream.Fragment" defines those streams.+--+-- All atomic values except textures in streams uses the 'Vertex' or 'Fragment' type constructors.+-- Composite types are created by composing the atomic 'Vertex' or 'Fragment' types, rather than wrapping the+-- composite type in any of those type constructors. This module provides the common classes for those atomic types,+-- as well as reexports of imported common types and modules.+-----------------------------------------------------------------------------++module Graphics.GPipe.Stream (+ -- * Common classes+ GPU(..),+ Real'(..),+ -- * Reexports+ (:.)(..),Vec2,Vec3,Vec4,+ module Data.Vec.LinAlg, + module Data.Boolean, +) where++import Shader+import Data.Boolean +import Data.Vec+import Data.Vec.LinAlg
+ src/Graphics/GPipe/Stream/Fragment.hs view
@@ -0,0 +1,63 @@+-----------------------------------------------------------------------------+--+-- Module : Graphics.GPipe.Stream.Fragment+-- Copyright : Tobias Bexelius+-- License : BSD3+--+-- Maintainer : Tobias Bexelius+-- Stability : Experimental+-- Portability : Portable+--+-- | 'FragmentStream's implement the 'Functor' class, which provides the+-- 'fmap' method that you can use to manipulate those streams. This corresponds to writing and using+-- fragment shaders, but in a much more modular way. You may for instance apply 'fmap'+-- several times in a sequence, effectively creating complex shaders.+--+-- Instances are also provided for the 'Monoid' class, so several streams (of the same type) can be+-- concatenated. The order is preserved, meaning that the fragments in stream @a@ in @a `mappend` b@ will be+-- drawn before the fragments in @b@.+--+-- All atomic values except textures in fragment streams uses the 'Fragment' type constructor.+-- Composite types are created by composing the atomic 'Fragment' types, rather than wrapping the+-- composite type in the 'Fragment' type constructors.+--+-- 'Fragment' instances for are provided for most of Prelude's numerical classes. Since 'Eq', 'Ord'+-- and 'Show' are prerequisites for these classes, instances are provided for them too, even though+-- their methods all will generate errors if used (except 'min' and 'max'). Use the instances of+-- 'EqB', 'OrdB' and 'IfB' from the Boolean package if you want to compare 'Fragment' values.+-- Hyperbolic trigonometrical functions aren't provided either.+--+-- Rewrite rule specializations are provided for the Vec package functions 'norm', 'normalize',+-- 'dot' and 'cross' on vectors of 'Fragment' 'Float', so the use of these functions (and others+-- from that package that is defined in terms of them) are highly encouraged.++-----------------------------------------------------------------------------++module Graphics.GPipe.Stream.Fragment (+ -- * Data types+ FragmentStream(), + Fragment(), ++ -- * Various fragment functions+ dFdx,+ dFdy,+ fwidth,+ filterFragments, ++ -- * Creating fragment streams+ VertexOutput(..), + Rasterizer(), + VertexPosition,+ -- | When using the @rasterize@ functions, give the vertices positions in canonical view space, i.e. where @x@, @y@ and @z@+ -- is in the interval @[-1, 1]@. These aren't interpolated back to the fragments by default, so you+ -- must duplicate these positions into the vertices interpolated values if you need them in the fragments (which is very unusual). + rasterize, + rasterizeBack, + rasterizeFrontAndBack, + rasterizeFront,+) where++import Shader +import GPUStream +import Rasterizer +
+ src/Graphics/GPipe/Stream/Primitive.hs view
@@ -0,0 +1,60 @@+-----------------------------------------------------------------------------+--+-- Module : Graphics.GPipe.Stream.Primitive+-- Copyright : Tobias Bexelius+-- License : BSD3+--+-- Maintainer : Tobias Bexelius+-- Stability : Experimental+-- Portability : Portable+--+-- | 'PrimitiveStream's implement the 'Functor' class, which provides the+-- 'fmap' method that you can use to manipulate those streams. This corresponds to writing and using+-- vertex shaders, but in a much more modular way. You may for instance apply 'fmap'+-- several times in a sequence, effectively creating complex shaders.+--+-- Instances are also provided for the 'Monoid' class, so several streams (of the same type) can be+-- concatenated. The order is preserved, meaning that the primitives in stream @a@ in @a `mappend` b@ will be+-- drawn before the primitives in @b@.+--+-- All atomic values except textures in vertex streams uses the 'Vertex' type constructor.+-- Composite types are created by composing the atomic 'Vertex' types, rather than wrapping the+-- composite type in the 'Vertex' type constructors.+--+-- 'Vertex' instances for are provided for most of Prelude's numerical classes. Since 'Eq', 'Ord'+-- and 'Show' are prerequisites for these classes, instances are provided for them too, even though+-- their methods all will generate errors if used (except 'min' and 'max'). Use the instances of+-- 'EqB', 'OrdB' and 'IfB' from the Boolean package if you want to compare 'Vertex' values.+-- Hyperbolic trigonometrical functions aren't provided either.+--+-- Rewrite rule specializations are provided for the Vec package functions 'norm', 'normalize',+-- 'dot' and 'cross' on vectors of 'Vertex' 'Float', so the use of these functions (and others+-- from that package that is defined in terms of them) are highly encouraged.+-----------------------------------------------------------------------------++module Graphics.GPipe.Stream.Primitive (+ -- * Data types+ PrimitiveStream(), + Vertex(), ++ -- * Creating primitive streams+ VertexInput(..), + InputAssembler(), + Triangle(..), + Line(..), + Point(..), + Primitive(), + toGPUStream, + toIndexedGPUStream, +) where++ +import Shader +import GPUStream +import InputAssembler + + + +++
+ src/Graphics/GPipe/Texture.hs view
@@ -0,0 +1,46 @@+-----------------------------------------------------------------------------+--+-- Module : Graphics.GPipe.Texture+-- Copyright : Tobias Bexelius+-- License : BSD3+--+-- Maintainer : Tobias Bexelius+-- Stability : Experimental+-- Portability : Portable+--+-- | Textures are type safe in GPipe, e.g. when you sample a @RGBFormat@ texture, you get an @RGB@ value.+--+-- Textures are either created directly from memory, or by giving a framebuffer a concrete size (which+-- it otherwise don't have). The latter is however not possible for 3D textures.+--+-- Depth textures are textures that contains depth component data (of type @DepthFormat@) but takes the type+-- of @LuminanceFormat@ or @AlphaFormat@ textures, and are sampled as such.+--+-----------------------------------------------------------------------------++module Graphics.GPipe.Texture (+ -- * Data types+ Texture3D(), + Texture2D(), + Texture1D(), + TextureCube(), + -- * Operation+ Texture(..), + -- * Creation + newTexture, + newDepthTexture, + FromFrameBufferColor(..), + FromFrameBufferDepth(..), + DepthColorFormat(), + fromFrameBufferCubeColor, + fromFrameBufferCubeDepth,+ -- * Samplers + Sampler(..), + Filter(..), + EdgeMode(..), +) where++import Resources +import Textures + +
+ src/InputAssembler.hs view
@@ -0,0 +1,104 @@+----------------------------------------------------------------------------- +-- +-- Module : InputAssembler +-- Copyright : Tobias Bexelius +-- License : BSD3 +-- +-- Maintainer : Tobias Bexelius +-- Stability : Experimental +-- Portability : Portable +-- +-- | +-- +----------------------------------------------------------------------------- + +module InputAssembler ( + InputAssembler(), + VertexInput(..), + toGPUStream, + toIndexedGPUStream, +) where + +import GPUStream +import Shader +import Control.Monad.State +import Data.Vec ((:.)(..), Vec2, Vec3, Vec4) + +-- | A monad in which CPU data gets converted to vertex data. +-- Use 'toVertex' in the existing instances of 'VertexInput' to operate in this monad. +newtype InputAssembler a = InputAssembler {fromInputAssembler :: State [Float] a} deriving Monad + +-- | The context of types that can be converted into vertices in 'PrimitiveStream's.+-- Create your own instances in terms of the existing ones, e.g. convert your vertex data to 'Float's, +-- turn them into 'Vertex' 'Float's with 'toVertex' and then convert them to your vertex data representation. +class GPU a => VertexInput a where + -- | Turns an ordinary value into a vertex value in the 'InputAssembler' monad. This should not be strict on its argument.+ -- Its definition should also always use the same series of 'toVertex' calls to convert values of the same type. This unfortunatly+ -- rules out ordinary lists (but instances for fixed length lists from the Vec package are however provided). + toVertex :: CPU a -> InputAssembler a + +instance VertexInput (Vertex Float) where + toVertex a = InputAssembler $ do x <- gets length + modify (a:) + return $ Vertex $ do addInput x + return $ "va" ++ show x +instance VertexInput () where + toVertex () = return () +instance (VertexInput a,VertexInput b) => VertexInput (a,b) where + toVertex (a, b) = do a' <- toVertex a + b' <- toVertex b + return (a', b') +instance (VertexInput a,VertexInput b,VertexInput c) => VertexInput (a,b,c) where + toVertex (a, b, c) = do a' <- toVertex a + b' <- toVertex b + c' <- toVertex c + return (a', b', c') +instance (VertexInput a,VertexInput b,VertexInput c,VertexInput d) => VertexInput (a,b,c,d) where + toVertex (a, b, c, d) = do a' <- toVertex a + b' <- toVertex b + c' <- toVertex c + d' <- toVertex d + return (a', b', c', d')++instance (VertexInput a, VertexInput b) => VertexInput (a:.b) where+ toVertex (a:.b) = do a' <- toVertex a + b' <- toVertex b + return $ a':.b'+ +-- | Converts a list of values to a 'PrimitiveStream', using a specified 'Primitive' type.+-- This function is lazy in the aspect that if parts of the values aren't used on the GPU, they won't+-- get evaluated and transferred there either. +toGPUStream :: (VertexInput a, Primitive p)+ => p -- ^ The primitive type.+ -> [CPU a] -- ^ A list of vertices, with the layout specified by the primitive type.+ -> PrimitiveStream p a -- ^ The resulting 'PrimitiveStream'. +toGPUStream _ [] = PrimitiveStream [] +toGPUStream p xs = let (a, fs) = getVertexInput xs + in PrimitiveStream [((getPrimitiveMode p, VertexSetup fs), a)] + +-- | Converts a list of values to a 'PrimitiveStream', using a specified 'Primitive' type and an index list.+-- This will use index buffer objects on the GPU, and is recommended if several primitives share vertices.+-- This function is lazy in the aspect that if parts of the values aren't used on the GPU, they won't+-- get evaluated and transferred there either. +toIndexedGPUStream :: (VertexInput a, Primitive p)+ => p -- ^ The primitive type.+ -> [CPU a] -- ^ A list of vertices.+ -> [Int] -- ^A list of indexes into the vertex list, with the layout specified by the primitive type.+ -> PrimitiveStream p a -- ^ The resulting 'PrimitiveStream'. +toIndexedGPUStream _ [] _ = PrimitiveStream [] +toIndexedGPUStream p xs i = let (a, fs) = getVertexInput xs + in PrimitiveStream [((getPrimitiveMode p, IndexedVertexSetup fs i), a)] + + +-------------------------------------- +-- Private +-- + +getVertexInput :: forall a. VertexInput a => [CPU a] -> (a, [[Float]]) +getVertexInput (x:xs) = let (a, s) = readInput x + readInput :: CPU a -> (a, [Float]) + readInput = flip runState [] . revState . fromInputAssembler . toVertex + revState m = do x <- m + modify reverse + return x + in (a, s : map (snd . readInput) xs)
+ src/OutputMerger.hs view
@@ -0,0 +1,444 @@+----------------------------------------------------------------------------- +-- +-- Module : OutputMerger +-- Copyright : Tobias Bexelius +-- License : BSD3 +-- +-- Maintainer : Tobias Bexelius +-- Stability : Experimental +-- Portability : Portable +-- +-- |+ +----------------------------------------------------------------------------- + +module OutputMerger ( + FragmentDepth, + ColorMask, Blending(..), BlendEquation(..), BlendingFactor(..), LogicOp(..),+ ComparisonFunction(..), DepthFunction, DepthMask,+ StencilOps(..), StencilOp(..), StencilTest(..), StencilTests(..), + FrameBuffer(), + newFrameBufferColor, + newFrameBufferColorDepth, + newFrameBufferColorDepthStencil, + newFrameBufferColorStencil, + newFrameBufferDepth, + newFrameBufferDepthStencil, + newFrameBufferStencil, + paintColor, + paintDepth, + paintColorDepth, + paintStencil, + paintDepthStencil, + paintColorStencil, + paintColorDepthStencil, + paintRastDepth, + paintColorRastDepth, + paintRastDepthStencil, + paintColorRastDepthStencil, + getFrameBufferCPUFormatByteSize, + getFrameBufferColor, + getFrameBufferDepth, + getFrameBufferStencil, + newWindow, + runFrameBufferInContext +) where + +import Formats +import Shader +import GPUStream +import Resources +import Graphics.Rendering.OpenGL hiding (RGBA, Blend, stencilMask, Color, ColorBuffer, DepthBuffer, StencilBuffer, Vertex) +import qualified Graphics.Rendering.OpenGL as GL +import Data.Vec (vec, (:.)(..), Vec2)+import qualified Graphics.UI.GLUT as GLUT +import Data.Int (Int32) +import Data.Word (Word32) +import Foreign.Ptr (Ptr) +import Graphics.UI.GLUT+ (reshapeCallback, displayCallback, Window)+import Control.Monad (liftM) +import Data.Maybe (fromJust) +import Control.Monad.Reader (runReaderT) +import Control.Exception (evaluate) + +type FragmentDepth = Fragment Float +-- | 'True' for each color component that should be written to the 'FrameBuffer'.+type ColorMask f = Color f Bool+-- | 'True' if the depth component should be written to the 'FrameBuffer'.+type DepthMask = Bool+-- | The function used to compare the fragment's depth and the depth buffers depth with.+type DepthFunction = ComparisonFunction++-- | Sets how the painted colors are blended with the 'FrameBuffer's previous value. +data Blending = NoBlending -- ^ The painted fragment completely overwrites the previous value .+ | Blend (BlendEquation, BlendEquation)+ ((BlendingFactor, BlendingFactor), (BlendingFactor, BlendingFactor))+ (Color RGBAFormat Float) -- ^ Use blending equations to combine the fragment with the previous value.+ -- The first 'BlendEquation' and 'BlendingFactor's is used for front faced triangles and other primitives,+ -- and the second for back faced triangles.+ | BlendLogicOp LogicOp -- ^ Use a 'LogicOp' to combine the fragment with the previous value.+ deriving (Eq,Ord,Show) ++-- | Sets the operations that should be performed on the 'FrameBuffer's stencil value +data StencilOps = StencilOps { + frontStencilOp :: StencilOp, -- ^ Used for front faced triangles and other primitives.+ backStencilOp :: StencilOp -- ^ Used for back faced triangles. + } deriving (Eq,Ord,Show) + +-- | Sets the tests that should be performed on the stencil value, first for front facing triangles and other primitives, then for back facing triangles. +data StencilTests = StencilTests StencilTest StencilTest deriving (Eq,Ord,Show) +-- | Sets a test that should be performed on the stencil value.+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) + +------------------------------------------------------------------++-- | A polymorphic frame buffer. It is parameterized on the type of color buffer, depth buffer and stencil buffer.+-- Any instances of 'ColorFormat' can be used for color buffer, or '()' to denote "no color buffer".+-- For depth and stencil buffers, 'DepthFormat' and 'StencilFormat' marks the existance of buffer, while '()'+-- marks the inexistance. +data FrameBuffer c d s = FrameBuffer (ContextCacheIO ()) + +newFrameBufferColor :: ColorFormat f => Color f Float -> FrameBuffer f () () +newFrameBufferColorDepth :: ColorFormat f => Color f Float -> Depth -> FrameBuffer f DepthFormat () +newFrameBufferColorDepthStencil :: ColorFormat f => Color f Float -> Depth -> Stencil -> FrameBuffer f DepthFormat StencilFormat +newFrameBufferColorStencil :: ColorFormat f => Color f Float -> Stencil -> FrameBuffer f () StencilFormat +newFrameBufferDepth :: Depth -> FrameBuffer () DepthFormat () +newFrameBufferDepthStencil :: Depth -> Stencil -> FrameBuffer () DepthFormat StencilFormat +newFrameBufferStencil :: Stencil -> FrameBuffer () () StencilFormat + +ioEvaluateColor z e x = let (a:.b:.c:.d:.()) = fromColor z e x + in do a' <- ioEvaluate a + b' <- ioEvaluate b + c' <- ioEvaluate c + d' <- ioEvaluate d + return (a':.b':.c':.d':.()) + +newFrameBufferColor c = FrameBuffer $ do + c' <- ioEvaluateColor 0 1 c + setContextWindow + liftIO $ do setNewColor c' + clear [GL.ColorBuffer] +newFrameBufferColorDepth c d = FrameBuffer $ do + c' <- ioEvaluateColor 0 1 c + d' <- ioEvaluate d + setContextWindow + liftIO $ do setNewColor c' + setNewDepth d' + clear [GL.ColorBuffer, GL.DepthBuffer] +newFrameBufferColorDepthStencil c d s = FrameBuffer $ do + c' <- ioEvaluateColor 0 1 c + d' <- ioEvaluate d + s' <- ioEvaluate s + setContextWindow + liftIO $ do setNewColor c' + setNewDepth d' + setNewStencil s' + clear [GL.ColorBuffer, GL.DepthBuffer, GL.StencilBuffer] + +newFrameBufferColorStencil c s = FrameBuffer $ do + c' <- ioEvaluateColor 0 1 c + s' <- ioEvaluate s + setContextWindow + liftIO $ do setNewColor c' + setNewStencil s' + clear [GL.ColorBuffer, GL.StencilBuffer] +newFrameBufferDepth d = FrameBuffer $ do + d' <- ioEvaluate d + setContextWindow + liftIO $ do setNewDepth d' + clear [GL.DepthBuffer] +newFrameBufferDepthStencil d s = FrameBuffer $ do + d' <- ioEvaluate d + s' <- ioEvaluate s + setContextWindow + liftIO $ do setNewDepth d' + setNewStencil s' + clear [GL.DepthBuffer, GL.StencilBuffer] + +newFrameBufferStencil s = FrameBuffer $ do + s' <- ioEvaluate s + setContextWindow + liftIO $ do setNewStencil s' + clear [GL.StencilBuffer] + + +setNewColor (x:.y:.z:.w:.()) = clearColor $= Color4 (realToFrac x) (realToFrac y) (realToFrac z) (realToFrac w) +setNewDepth d = clearDepth $= realToFrac d +setNewStencil s = clearStencil $= fromIntegral s + +------------------------------------------------------------------ + +paintColor :: ColorFormat c => Blending -> ColorMask c -> FragmentStream (Color c (Fragment Float)) -> FrameBuffer c d s -> FrameBuffer c d s +paintDepth :: DepthFunction -> DepthMask -> FragmentStream FragmentDepth -> FrameBuffer c DepthFormat s -> FrameBuffer c DepthFormat s +paintColorDepth :: ColorFormat c => DepthFunction -> DepthMask -> Blending -> ColorMask c -> FragmentStream (Color c (Fragment Float), FragmentDepth) -> FrameBuffer c DepthFormat s -> FrameBuffer c DepthFormat s +paintStencil :: StencilTests -> StencilOps -> StencilOps -> FragmentStream (Fragment a) -> FrameBuffer c d StencilFormat -> FrameBuffer c d StencilFormat +paintDepthStencil :: StencilTests -> StencilOps -> DepthFunction -> DepthMask -> StencilOps -> StencilOps -> FragmentStream FragmentDepth -> FrameBuffer c DepthFormat StencilFormat -> FrameBuffer c DepthFormat StencilFormat +paintColorStencil :: ColorFormat c => StencilTests -> StencilOps -> StencilOps -> Blending -> ColorMask c -> FragmentStream (Color c (Fragment Float)) -> FrameBuffer c d StencilFormat -> FrameBuffer c d StencilFormat +paintColorDepthStencil :: ColorFormat c => StencilTests -> StencilOps -> DepthFunction -> DepthMask -> StencilOps -> StencilOps -> Blending -> ColorMask c -> FragmentStream (Color c (Fragment Float), FragmentDepth) -> FrameBuffer c DepthFormat StencilFormat -> FrameBuffer c DepthFormat StencilFormat + +paintRastDepth :: DepthFunction -> DepthMask -> FragmentStream (Fragment a) -> FrameBuffer c DepthFormat s -> FrameBuffer c DepthFormat s +paintColorRastDepth :: ColorFormat c => DepthFunction -> DepthMask -> Blending -> ColorMask c -> FragmentStream (Color c (Fragment Float)) -> FrameBuffer c DepthFormat s -> FrameBuffer c DepthFormat s +paintRastDepthStencil :: StencilTests -> StencilOps -> DepthFunction -> DepthMask -> StencilOps -> StencilOps -> FragmentStream (Fragment a) -> FrameBuffer c DepthFormat StencilFormat -> FrameBuffer c DepthFormat StencilFormat +paintColorRastDepthStencil :: ColorFormat c => StencilTests -> StencilOps -> DepthFunction -> DepthMask -> StencilOps -> StencilOps -> Blending -> ColorMask c -> FragmentStream (Color c (Fragment Float)) -> FrameBuffer c DepthFormat StencilFormat -> FrameBuffer c DepthFormat StencilFormat + +------------------------------------------------------------------ ++paintColor _ _ (FragmentStream []) fb = fb +paintColor b c s (FrameBuffer io) = FrameBuffer $ loadFragmentColorStream s $ do + b'<-ioEvaluate b + c'<-ioEvaluateColor False False c + io + liftIO $ do + loadBlending b' + loadColorMask c' + depthFunc $= Nothing + stencilTest $= Disabled + +paintDepth _ _ (FragmentStream []) fb = fb +paintDepth f d s (FrameBuffer io) = FrameBuffer $ loadFragmentDepthStream s $ do + f'<-ioEvaluate f + d'<-ioEvaluate d + io + liftIO $ do + depthFunc $= Just f' + depthMask $= toCapability d' + loadColorMask (vec False) + stencilTest $= Disabled + +paintColorDepth _ _ _ _ (FragmentStream []) fb = fb +paintColorDepth f d b c s (FrameBuffer io) = FrameBuffer $ loadFragmentColorDepthStream s $ do + b'<-ioEvaluate b + c'<-ioEvaluateColor False False c + f'<-ioEvaluate f + d'<-ioEvaluate d + io + liftIO $ do + loadBlending b' + loadColorMask c' + depthFunc $= Just f' + depthMask $= toCapability d' + stencilTest $= Disabled + +paintStencil _ _ _ (FragmentStream []) fb = fb +paintStencil t sf p s (FrameBuffer io) = FrameBuffer $ loadFragmentAnyStream s $ do + t'<-ioEvaluate t + sf'<-ioEvaluate sf + p'<-ioEvaluate p + io + liftIO $ do + loadStencilTests t' + loadStencilOps sf' sf' p' + depthFunc $= Nothing + loadColorMask (vec False) + +paintDepthStencil _ _ _ _ _ _ (FragmentStream []) fb = fb +paintDepthStencil t sf f d df p s (FrameBuffer io) = FrameBuffer $ loadFragmentDepthStream s $ do + t'<-ioEvaluate t + sf'<-ioEvaluate sf + f'<-ioEvaluate f + d'<-ioEvaluate d + df'<-ioEvaluate df + p'<-ioEvaluate p + io + liftIO $ do + loadStencilTests t' + loadStencilOps sf' df' p' + depthFunc $= Just f' + depthMask $= toCapability d' + loadColorMask (vec False) + +paintColorStencil _ _ _ _ _ (FragmentStream []) fb = fb +paintColorStencil t sf p b c s (FrameBuffer io) = FrameBuffer $ loadFragmentColorStream s $ do + t'<-ioEvaluate t + sf'<-ioEvaluate sf + p'<-ioEvaluate p + b'<-ioEvaluate b + c'<-ioEvaluateColor False False c + io + liftIO $ do + loadStencilTests t' + loadStencilOps sf' sf' p' + depthFunc $= Nothing + loadBlending b' + loadColorMask c' + +paintColorDepthStencil _ _ _ _ _ _ _ _ (FragmentStream []) fb = fb +paintColorDepthStencil t sf f d df p b c s (FrameBuffer io) = FrameBuffer $ loadFragmentColorDepthStream s $ do + t'<-ioEvaluate t + sf'<-ioEvaluate sf + f'<-ioEvaluate f + d'<-ioEvaluate d + df'<-ioEvaluate df + p'<-ioEvaluate p + b'<-ioEvaluate b + c'<-ioEvaluateColor False False c + io + liftIO $ do + loadStencilTests t' + loadStencilOps sf' df' p' + depthFunc $= Just f' + depthMask $= toCapability d' + loadBlending b' + loadColorMask c' + +paintRastDepth _ _ (FragmentStream []) fb = fb +paintRastDepth f d s (FrameBuffer io) = FrameBuffer $ loadFragmentAnyStream s $ do + f'<-ioEvaluate f + d'<-ioEvaluate d + io + liftIO $ do + depthFunc $= Just f' + depthMask $= toCapability d' + loadColorMask (vec False) + stencilTest $= Disabled + +paintColorRastDepth _ _ _ _ (FragmentStream []) fb = fb +paintColorRastDepth f d b c s (FrameBuffer io) = FrameBuffer $ loadFragmentColorStream s $ do + f'<-ioEvaluate f + d'<-ioEvaluate d + b'<-ioEvaluate b + c'<-ioEvaluateColor False False c + io + liftIO $ do + loadBlending b' + loadColorMask c' + depthFunc $= Just f' + depthMask $= toCapability d' + stencilTest $= Disabled + +paintRastDepthStencil _ _ _ _ _ _ (FragmentStream []) fb = fb +paintRastDepthStencil t sf f d df p s (FrameBuffer io) = FrameBuffer $ loadFragmentAnyStream s $ do + t'<-ioEvaluate t + sf'<-ioEvaluate sf + f'<-ioEvaluate f + d'<-ioEvaluate d + df'<-ioEvaluate df + p'<-ioEvaluate p + io + liftIO $ do + loadStencilTests t' + loadStencilOps sf' df' p' + depthFunc $= Just f' + depthMask $= toCapability d' + loadColorMask (vec False) + +paintColorRastDepthStencil _ _ _ _ _ _ _ _ (FragmentStream []) fb = fb +paintColorRastDepthStencil t sf f d df p b c s (FrameBuffer io) = FrameBuffer $ loadFragmentColorStream s $ do + t'<-ioEvaluate t + sf'<-ioEvaluate sf + f'<-ioEvaluate f + d'<-ioEvaluate d + df'<-ioEvaluate df + p'<-ioEvaluate p + b'<-ioEvaluate b + c'<-ioEvaluateColor False False c + io + liftIO $ do + loadStencilTests t' + loadStencilOps sf' df' p' + depthFunc $= Just f' + depthMask $= toCapability d' + loadBlending b' + loadColorMask c' + +--------------------------------------+-- | Returns the byte size needed to store a certain format and size of a framebuffer. Use this to+-- allocate memory before using 'getFrameBufferColor', 'getFrameBufferDepth' or 'getFrameBufferStencil'. +getFrameBufferCPUFormatByteSize :: StorableCPUFormat f+ => f -- ^ The format to store data to+ -> Vec2 Int -- ^ The size to give the frame buffer+ -> Int -- ^ The size in bytes of the data +getFrameBufferCPUFormatByteSize f (w:.h:.()) = h*formatRowByteSize f w ++-- | Saves a 'FrameBuffer's color buffer to main memory. +getFrameBufferColor :: forall c d s a. GPUFormat c+ => CPUFormat c -- ^ The format to store data to+ -> Vec2 Int -- ^ The size to give the frame buffer+ -> FrameBuffer c d s -- ^ A frame buffer with a color buffer+ -> Ptr a -- ^ A pointer to the memory where the data will be saved+ -> IO () +getFrameBufferColor f s@(w:.h:.()) fb p = do + cache <- getCurrentOrSetHiddenContext + runFrameBufferInContext cache s fb + readPixels (Position 0 0) (Size (fromIntegral w) (fromIntegral h)) (PixelData (toGLPixelFormat (undefined :: c)) (toGLDataType f) p) + +-- | Saves a 'FrameBuffer's depth buffer to main memory. +getFrameBufferDepth :: CPUFormat DepthFormat -- ^ The format to store data to+ -> Vec2 Int -- ^ The size to give the frame buffer+ -> FrameBuffer c DepthFormat s -- ^ A frame buffer with a depth buffer+ -> Ptr a -- ^ A pointer to the memory where the data will be saved+ -> IO () +getFrameBufferDepth f s@(w:.h:.()) fb p = do + cache <- getCurrentOrSetHiddenContext + runFrameBufferInContext cache s fb + readPixels (Position 0 0) (Size (fromIntegral w) (fromIntegral h)) (PixelData DepthComponent (toGLDataType f) p) + +-- | Saves a 'FrameBuffer's stencil buffer to main memory. +getFrameBufferStencil :: CPUFormat StencilFormat -- ^ The format to store data to+ -> Vec2 Int -- ^ The size to give the frame buffer+ -> FrameBuffer c d StencilFormat -- ^ A frame buffer with a stencil buffer+ -> Ptr a -- ^ A pointer to the memory where the data will be saved+ -> IO () +getFrameBufferStencil f s@(w:.h:.()) fb p = do + cache <- getCurrentOrSetHiddenContext + runFrameBufferInContext cache s fb + readPixels (Position 0 0) (Size (fromIntegral w) (fromIntegral h)) (PixelData StencilIndex (toGLDataType f) p) + +-- | Cretes and shows a new GPipe window. Use the last parameter to add extra GLUT callbacks to the window. Note that you can't register your own 'displayCallback' and 'reshapeCallback'. +newWindow :: String -- ^ The window title+ -> Vec2 Int -- ^ The window position+ -> Vec2 Int -- ^ The window size+ -> (IO (FrameBuffer c d s)) -- ^ This 'IO' action will be run every time the window needs to be redrawn, and the resulting 'FrameBuffer' will be drawn in the window.+ -> (Window -> IO ()) -- ^ Extra optional initialization of the window. The provided 'Window' should not be used outside this function.+ -> IO () +newWindow name (x:.y:.()) (w:.h:.()) f xio = + do GLUT.initialWindowPosition $= Position (fromIntegral x) (fromIntegral y) + GLUT.initialWindowSize $= Size (fromIntegral w) (fromIntegral h) + GLUT.initialDisplayMode $= [ GLUT.DoubleBuffered, GLUT.RGBMode, GLUT.WithAlphaComponent, GLUT.WithDepthBuffer, GLUT.WithStencilBuffer] --Enable everything, it might be needed for textures + w <- GLUT.createWindow name + xio w + newContextCache w + displayCallback $= do FrameBuffer io <- f + cache <- liftM fromJust $ getContextCache w --We need to do this to get the correct size + runReaderT io cache + GLUT.swapBuffers + reshapeCallback $= Just (changeContextSize w) + + +runFrameBufferInContext :: ContextCache -> Vec2 Int -> FrameBuffer c d s -> IO () +runFrameBufferInContext c (a:.b:.()) (FrameBuffer io) = do + a' <- evaluate a + b' <- evaluate b + runReaderT io $ c {contextViewPort = Size (fromIntegral a') (fromIntegral b')} + finish +-------------------------------------- +-- Private +-- +toCapability True = Enabled +toCapability False = Disabled + +loadColorMask (r:.g:.b:.a:.()) = colorMask $= Color4 (toCapability r) (toCapability g) (toCapability b) (toCapability a) + +loadBlending NoBlending = do blend $= Disabled + logicOp $= Nothing +loadBlending (Blend e f (RGBA (r:.g:.b:.()) a)) = do+ blend $= Enabled + logicOp $= Nothing + blendColor $= Color4 (realToFrac r) (realToFrac g) (realToFrac b) (realToFrac a) + blendEquationSeparate $= e + blendFuncSeparate $= f +loadBlending (BlendLogicOp op) = logicOp $= Just op + +loadStencilTests (StencilTests f b) = do stencilTest $= Enabled + stencilFuncSeparate Front $= (stencilComparision f, fromIntegral $ stencilReference f, fromIntegral $ stencilMask f) + stencilFuncSeparate Back $= (stencilComparision b, fromIntegral $ stencilReference b, fromIntegral $ stencilMask b) + +loadStencilOps sf df p = do stencilOpSeparate Front $= (frontStencilOp sf, frontStencilOp df, frontStencilOp p) + stencilOpSeparate Back $= (backStencilOp sf, backStencilOp df, backStencilOp p) + +
+ src/Rasterizer.hs view
@@ -0,0 +1,130 @@+----------------------------------------------------------------------------- +-- +-- Module : Rasterizer +-- Copyright : Tobias Bexelius +-- License : BSD3 +-- +-- Maintainer : Tobias Bexelius +-- Stability : Experimental +-- Portability : Portable +-- +-- | +-- +----------------------------------------------------------------------------- + +module Rasterizer ( + Rasterizer(), + VertexOutput(..), + rasterize, + rasterizeFront, + rasterizeFrontAndBack, + rasterizeBack, +) where + +import Shader +import Data.Vec ((:.)(..), Vec2, Vec3, Vec4) +import GPUStream +import Control.Monad.State + +-- | A monad in which vertex data gets converted to fragment data. +-- Use 'toFragment' in the existing instances of 'VertexOutput' to operate in this monad. +newtype Rasterizer a = Rasterizer {fromRasterizer :: State [Shader String] a} deriving Monad ++-- | The context of types that can be rasterized from vertices in 'PrimitiveStream's to fragments in 'FragmentStream's.+-- Create your own instances in terms of the existing ones, e.g. convert your vertex data to 'Vertex' 'Float's, +-- turn them into 'Fragment' 'Float's with 'toFragment' and then convert them to your fragment data representation. +class GPU a => VertexOutput a where + -- | The corresponding type in the 'FragmentStream' after rasterization.+ type FragmentInput a+ -- | Turns a vertex value into a fragment value in the 'Rasterizer' monad. This should not be strict on its argument.+ -- Its definition should also always use the same series of 'toFragment' calls to convert values of the same type. This unfortunatly+ -- rules out ordinary lists (but instances for fixed length lists from the Vec package are however provided). + toFragment :: a -> Rasterizer (FragmentInput a) + +instance VertexOutput (Vertex Float) where + type FragmentInput (Vertex Float) = Fragment Float + toFragment (Vertex a) = Rasterizer $ do x <- gets length + modify (a:) + return $ Fragment $ do addInput x + return $ "fa" ++ show x + +instance VertexOutput () where + type FragmentInput () = () + toFragment () = return () +instance (VertexOutput a,VertexOutput b) => VertexOutput (a,b) where + type FragmentInput (a,b) = (FragmentInput a, FragmentInput b) + toFragment (a, b) = do a' <- toFragment a + b' <- toFragment b + return (a', b') +instance (VertexOutput a,VertexOutput b,VertexOutput c) => VertexOutput (a,b,c) where + type FragmentInput (a,b,c) = (FragmentInput a, FragmentInput b, FragmentInput c) + toFragment (a, b, c) = do a' <- toFragment a + b' <- toFragment b + c' <- toFragment c + return (a', b', c') +instance (VertexOutput a,VertexOutput b,VertexOutput c,VertexOutput d) => VertexOutput (a,b,c,d) where + type FragmentInput (a,b,c,d) = (FragmentInput a, FragmentInput b, FragmentInput c, FragmentInput d) + toFragment (a, b, c, d) = do a' <- toFragment a + b' <- toFragment b + c' <- toFragment c + d' <- toFragment d + return (a', b', c', d') ++instance (VertexOutput a, VertexOutput b) => VertexOutput (a:.b) where+ type FragmentInput (a:.b) = FragmentInput a :. FragmentInput b + toFragment (a:.b) = do a' <- toFragment a + b' <- toFragment b + return $ a':.b' + +-- | Rasterize all types of primitives (and both sides of triangles) with vertices containing canonical view coordinates into fragments. +rasterize :: VertexOutput a+ => PrimitiveStream p (VertexPosition, a) -- ^ The primitive stream with vertices containing canonical view coordinates and data to be interpolated.+ -> FragmentStream (FragmentInput a) -- ^ The resulting fragment stream with fragments containing the interpolated values. +rasterize (PrimitiveStream []) = FragmentStream [] +rasterize (PrimitiveStream xs) = FragmentStream $ map rasterizeOne xs + where rasterizeOne (pdesc, (pos, va)) = ((pdesc, CullNone, fs, getPositionCode pos), true, fa) + where (fa, fs) = getFragmentInput va + +-- | Rasterize both sides of triangles with vertices containing canonical view coordinates into fragments, also returning the primitives side in the fragments. +rasterizeFrontAndBack :: VertexOutput a+ => PrimitiveStream Triangle (VertexPosition, a) -- ^ The primitive stream with vertices containing canonical view coordinates and data to be interpolated.+ -> FragmentStream (Fragment Bool, FragmentInput a) -- ^ The resulting fragment stream with fragments containing a bool saying if the primitive was front facing and the interpolated values. +rasterizeFrontAndBack (PrimitiveStream []) = FragmentStream [] +rasterizeFrontAndBack (PrimitiveStream xs) = FragmentStream $ map rasterizeOne xs + where rasterizeOne (pdesc, (pos, va)) = ((pdesc, CullNone, fs, getPositionCode pos), true, (Fragment $ return "gl_FrontFacing", fa)) + where (fa, fs) = getFragmentInput va + +-- | Rasterize only front side of triangles with vertices containing canonical view coordinates into fragments. +rasterizeFront :: VertexOutput a+ => PrimitiveStream Triangle (VertexPosition, a) -- ^ The primitive stream with vertices containing canonical view coordinates and data to be interpolated.+ -> FragmentStream (FragmentInput a) -- ^ The resulting fragment stream with fragments containing the interpolated values. +rasterizeFront (PrimitiveStream []) = FragmentStream [] +rasterizeFront (PrimitiveStream xs) = FragmentStream $ map rasterizeOne xs + where rasterizeOne (pdesc, (pos, va)) = ((pdesc, CullBack, fs, getPositionCode pos), true, fa) + where (fa, fs) = getFragmentInput va + +-- | Rasterize only back side of triangles with vertices containing canonical view coordinates into fragments. +rasterizeBack :: VertexOutput a+ => PrimitiveStream Triangle (VertexPosition, a) -- ^ The primitive stream with vertices containing canonical view coordinates and data to be interpolated.+ -> FragmentStream (FragmentInput a) -- ^ The resulting fragment stream with fragments containing the interpolated values. +rasterizeBack (PrimitiveStream []) = FragmentStream [] +rasterizeBack (PrimitiveStream xs) = FragmentStream $ map rasterizeOne xs + where rasterizeOne (pdesc, (pos, va)) = ((pdesc, CullFront, fs, getPositionCode pos), true, fa) + where (fa, fs) = getFragmentInput va + +-------------------------------------- +-- Private +-- + +getPositionCode (Vertex x :. Vertex y :. Vertex z :. Vertex w :. ()) = do x' <- x + y' <- y + z' <- z + w' <- w + return $ "vec4(" ++ x' ++ "," ++ y' ++ "," ++ z' ++ "," ++ w' ++ ")" + +getFragmentInput :: VertexOutput a => a -> (FragmentInput a, [Shader String]) +getFragmentInput = flip runState [] . revState . fromRasterizer . toFragment + where + revState m = do x <- m + modify reverse + return x
+ src/Resources.hs view
@@ -0,0 +1,411 @@+----------------------------------------------------------------------------- +-- +-- Module : Resources +-- Copyright : Tobias Bexelius +-- License : BSD3 +-- +-- Maintainer : Tobias Bexelius +-- Stability : Experimental +-- Portability : Portable +-- +-- | +-- +----------------------------------------------------------------------------- + +module Resources ( + createProgramResource, + createVertexBuffer, + createIndexBuffer, + useUniforms, + useProgramResource, + drawIndexVertexBuffer, + drawVertexBuffer, + VertexBuffer(..), + IndexBuffer(..), + UniformLocationSet, + ContextCacheIO, + ContextCache(contextWindow,contextViewPort), + newContextCache, + setContextWindow, + liftIO, + hiddenWindowContextCache, + WinMappedTexture, + newWinMappedTexture, + bindWinMappedTexture, + Sampler(..), + Filter(..), + EdgeMode(..), + SamplerType(..), + UniformSet, + cubeMapTargets, + getContextCache, + saveContextCache, + changeContextSize, + getCurrentOrSetHiddenContext, + ioEvaluate, + evaluateDeep, + evaluatePtr +) where + +import Graphics.Rendering.OpenGL hiding (Sampler3D, Sampler2D, Sampler1D, SamplerCube, Point, Linear, Clamp) +import qualified Data.HashTable as HT +import qualified Graphics.UI.GLUT as GLUT +import Data.Map (Map) +import qualified Data.Map as Map +import System.Mem.StableName+ (makeStableName, hashStableName, StableName)+import Data.Bits+import Control.Monad.Reader+import Control.Monad+import Foreign.C.Types+import Foreign.Storable+import Foreign.Marshal+import Data.List+import Data.Maybe+import Foreign.Ptr+import System.IO.Unsafe (unsafePerformIO)+import Data.IORef+import Control.Exception (evaluate)+import Foreign.ForeignPtr+import System.Mem.Weak (addFinalizer)+ + +data VertexBuffer = VertexBuffer BufferObject Int +data IndexBuffer = IndexBuffer BufferObject Int DataType +type UniformLocationSet = (UniformLocation,UniformLocation,UniformLocation, Map SamplerType UniformLocation) +type UniformSet = ([Float],[Int],[Bool], [(SamplerType, [(Sampler,WinMappedTexture)])]) + +data SamplerType = Sampler3D | Sampler2D | Sampler1D | SamplerCube deriving (Eq, Ord, Enum, Bounded) + +-- | A structure describing how a texture is sampled +data Sampler = Sampler Filter EdgeMode deriving (Eq, Ord) +-- | Filter mode used in sampler state +data Filter = Point | Linear + deriving (Eq,Ord,Bounded,Enum,Show) +-- | Edge mode used in sampler state +data EdgeMode = Wrap | Mirror | Clamp + deriving (Eq,Ord,Bounded,Enum,Show) + +toGLFilter Point = ((Nearest, Just Nearest), Nearest) +toGLFilter Linear = ((Linear', Just Linear'), Linear') +toGLWrap Wrap = (Repeated, Repeat) +toGLWrap Mirror = (Mirrored, Repeat) +toGLWrap Clamp = (Repeated, ClampToEdge) + +type ProgramCache = HT.HashTable (String, String) (Program, (UniformLocationSet,UniformLocationSet)) +type VBCache = HT.HashTable ([Int], StableName [[Float]]) VertexBuffer +type IBCache = HT.HashTable (StableName [Int]) IndexBuffer +data ContextCache = ContextCache {programCache :: ProgramCache, + vbCache :: VBCache, + ibCache :: IBCache, + contextWindow :: GLUT.Window, + contextViewPort :: Size} +newContextCache :: GLUT.Window -> IO ContextCache +newContextCache w = do + pc <- HT.new (==) (\(a,b)-> HT.hashString a `xor` HT.hashString b) + vbc <- HT.new (==) (\(a,b) -> HT.hashString (map toEnum a) `xor` HT.hashInt (hashStableName b)) + ibc <- HT.new (==) (HT.hashInt . hashStableName) + let cache = ContextCache pc vbc ibc w (Size 0 0) + saveContextCache cache + return cache ++setContextWindow :: ContextCacheIO () +setContextWindow = do w <- asks contextWindow + s <- asks contextViewPort + liftIO $ do GLUT.currentWindow $= Just w + viewport $= (Position 0 0, s) + + +type ContextCacheIO = ReaderT ContextCache IO + +createShaderResource :: Shader s => String -> IO s +createShaderResource str = do [s] <- genObjectNames 1 + -- putStrLn $ "Created shader " ++ show s + shaderSource s $= [str] + compileShader s + b <- get $ compileStatus s + if b then return s + else do e <- get $ shaderInfoLog s + error $ e ++ "\nSource:\n\n" ++ str + +createProgramResource :: (String,String) -> (String,String) -> Int -> ContextCacheIO (Program, (UniformLocationSet,UniformLocationSet)) +createProgramResource (vstr,vsig) (fstr,fsig) s = do + cache <- asks programCache + test <- liftIO $ HT.lookup cache (vsig,fsig) + case test of + Just p -> return p + Nothing -> liftIO $ do + [p] <- genObjectNames 1 + -- putStrLn $ "Created program " ++ show p + vs <- createShaderResource vstr + fs <- createShaderResource fstr + attachedShaders p $= ([vs],[fs]) + mapM_ + (\i -> attribLocation p ("attr" ++ show i) $= AttribLocation i) + [0..fromIntegral ((s-1) `div` 4)] + linkProgram p + b <- get $ linkStatus p + unless b $ do + e <- get $ programInfoLog p + error e + let allSamplers = [minBound..maxBound :: SamplerType] + fvu <- get $ uniformLocation p "fvu" + ivu <- get $ uniformLocation p "ivu" + bvu <- get $ uniformLocation p "bvu" + svus' <- mapM (\ s -> get $ uniformLocation p $ "s" ++ show (fromEnum s) ++"vu") allSamplers + let svus = Map.fromAscList $ zip allSamplers svus' + ffu <- get $ uniformLocation p "ffu" + ifu <- get $ uniformLocation p "ifu" + bfu <- get $ uniformLocation p "bfu" + sfus' <- mapM (\ s -> get $ uniformLocation p $ "s" ++ show (fromEnum s) ++"fu") allSamplers + let sfus = Map.fromAscList $ zip allSamplers sfus' + let p' = (p, ((fvu,ivu,bvu,svus),(ffu,ifu,bfu,sfus))) + HT.insert cache (vsig,fsig) p' + return p' + +createVertexBuffer :: [[Float]] -> [Int] -> [[Float]] -> ContextCacheIO VertexBuffer +createVertexBuffer xs i v = do vName <- liftIO $ makeStableName v+ let k = (i,vName)+ cache <- asks vbCache + test <- liftIO $ HT.lookup cache k + case test of + Just b -> return b + Nothing -> do+ w <- asks contextWindow+ liftIO $ do [b] <- genObjectNames 1 + -- putStrLn $ "Created vertex buffer " ++ show b + bindBuffer ArrayBuffer $= Just b + let xsdata = map realToFrac $ concat xs :: [CFloat] + withArray xsdata (\p -> bufferData ArrayBuffer $= (fromIntegral $ sizeOf (0 :: CFloat) * length xsdata, p, StaticDraw)) + let b' = VertexBuffer b $ length (head xs) + HT.insert cache k b'+ addFinalizer v $ do HT.delete cache k+ w' <- get GLUT.currentWindow+ GLUT.currentWindow $= Just w+ deleteObjectNames [b]+ GLUT.currentWindow $= w'+ -- putStrLn "Deleted vertex buffer"+ return b' + +createIndexBuffer :: [Int] -> Int -> ContextCacheIO IndexBuffer +createIndexBuffer xs vs = do cache <- asks ibCache + iName <- liftIO $ makeStableName xs + test <- liftIO $ HT.lookup cache iName+ case test of + Just i -> return i + Nothing -> do+ w <- asks contextWindow+ liftIO $ do [b] <- genObjectNames 1 + -- putStrLn $ "Created index buffer " ++ show b + bindBuffer ElementArrayBuffer $= Just b + i <- if vs > fromIntegral (maxBound :: CUShort) + then do + withArray (map fromIntegral xs :: [CUInt]) (\p -> bufferData ElementArrayBuffer $= (fromIntegral $ sizeOf (0 :: CFloat) * length xs, p, StaticDraw)) + return $ IndexBuffer b (length xs) UnsignedInt + else if vs > fromIntegral (maxBound :: CUChar) + then do + withArray (map fromIntegral xs :: [CUShort]) (\p -> bufferData ElementArrayBuffer $= (fromIntegral $ sizeOf (0 :: CFloat) * length xs, p, StaticDraw)) + return $ IndexBuffer b (length xs) UnsignedShort + else do + withArray (map fromIntegral xs :: [CUChar]) (\p -> bufferData ElementArrayBuffer $= (fromIntegral $ (sizeOf (0 :: CFloat)) * length xs, p, StaticDraw)) + return $ IndexBuffer b (length xs) UnsignedByte + HT.insert cache iName i+ addFinalizer xs $ do HT.delete cache iName+ w' <- get GLUT.currentWindow+ GLUT.currentWindow $= Just w+ deleteObjectNames [b]+ GLUT.currentWindow $= w' + -- putStrLn "Deleted index buffer"+ return i + +useProgramResource :: Program -> ContextCacheIO () +useProgramResource p = liftIO $ currentProgram $= Just p + +useUniforms :: UniformLocationSet -> UniformSet -> ContextCacheIO () +useUniforms (fu,iu,bu,su) (f,i,b,s) = do + w <- asks contextWindow + liftIO $ do + unless (null f) $ withArray (map (TexCoord1 . realToFrac) f :: [TexCoord1 GLfloat]) $ uniformv fu (fromIntegral $ length f) + unless (null i) $ withArray (map (TexCoord1 . fromIntegral) i :: [TexCoord1 GLint]) $ uniformv iu (fromIntegral $ length i) + unless (null b) $ withArray (map (TexCoord1 . fromBool) b :: [TexCoord1 GLint]) $ uniformv bu (fromIntegral $ length b) + mapM_ (useSampler w) s + where + useSampler w (t, xs) = do + let texs = nub xs + samplers <- mapM (createSampler w t) $ zip texs [0..] + let texToSamp = zip texs samplers + ss = map (fromJust . flip lookup texToSamp) xs + withArray ss $ uniformv (su Map.! t) (fromIntegral $ length ss) + createSampler w t ((Sampler f e,tex),i) = do + activeTexture $= TextureUnit i + bindWinMappedTexture (target t) w tex t + textureFilter (target t) $= toGLFilter f + mapM_ (\c -> textureWrapMode (target t) c $= toGLWrap e) [S, T, R, Q] + return $ TexCoord1 (i::GLuint) + target Sampler3D = Texture3D + target Sampler2D = Texture2D + target Sampler1D = Texture1D + target SamplerCube = TextureCubeMap + +useVertexBuffer :: VertexBuffer -> IO () +useVertexBuffer (VertexBuffer b s) = do bindBuffer ArrayBuffer $= Just b + mapM_ + (\i -> do + let ptroffset = nullPtr `plusPtr` (sizeOf (0 :: CFloat) * i * 4) + stride = fromIntegral $ sizeOf (0 :: CFloat) * s + a = AttribLocation $ fromIntegral i + e = fromIntegral $ min (s - i*4) 4 + vertexAttribArray a $= Enabled + vertexAttribPointer a $= (ToFloat, VertexArrayDescriptor e Float stride ptroffset) + ) + [0..(s-1) `div` 4] + + +drawIndexVertexBuffer :: PrimitiveMode -> VertexBuffer -> IndexBuffer -> IO () +drawIndexVertexBuffer p vb (IndexBuffer i s t) = do useVertexBuffer vb + bindBuffer ElementArrayBuffer $= Just i + drawElements p (fromIntegral s) t nullPtr + +drawVertexBuffer :: PrimitiveMode -> VertexBuffer -> Int -> IO () +drawVertexBuffer p vb s = do useVertexBuffer vb + drawArrays p 0 (fromIntegral s) + + +{-# NOINLINE hiddenWindowContextCache #-} +hiddenWindowContextCache :: ContextCache +hiddenWindowContextCache = unsafePerformIO $ do + GLUT.initialDisplayMode $= [ GLUT.SingleBuffered, GLUT.RGBMode, GLUT.WithAlphaComponent, GLUT.WithDepthBuffer, GLUT.WithStencilBuffer ] + w <- GLUT.createWindow "Hidden Window" + GLUT.windowStatus $= GLUT.Hidden + newContextCache w + +{-# NOINLINE windowContextCaches #-} +windowContextCaches :: IORef (Map GLUT.Window ContextCache) +windowContextCaches = unsafePerformIO $ newIORef $ Map.empty + +getContextCache :: GLUT.Window -> IO (Maybe ContextCache) +getContextCache w = do m <- atomicModifyIORef windowContextCaches (\m -> (m,m)) + return $ Map.lookup w m + +saveContextCache :: ContextCache -> IO () +saveContextCache c = atomicModifyIORef windowContextCaches $ \ m -> (Map.insert (contextWindow c) c m, ()) + +changeContextSize :: GLUT.Window -> Size -> IO () +changeContextSize w s = atomicModifyIORef windowContextCaches $ \ m -> (Map.adjust (\c -> c {contextViewPort = s}) w m, ()) + +getCurrentOrSetHiddenContext = do + mw <- get GLUT.currentWindow + case mw of Just w -> do mc <- getContextCache w + case mc of Just cache -> return cache + Nothing -> setAndGetHiddenWindow + Nothing -> setAndGetHiddenWindow + where + setAndGetHiddenWindow = do GLUT.currentWindow $= Just (contextWindow hiddenWindowContextCache) + return hiddenWindowContextCache + + +evaluateDeep a = do t <- evaluate (a==a) + case t of True -> return a + False -> return undefined ++ioEvaluate :: Eq a => a -> ContextCacheIO a +ioEvaluate = liftIO . evaluateDeep + +evaluatePtr p = do a <- peek (castPtr p :: Ptr CUChar) + t <- evaluate (a==a) + case t of True -> return p + False -> return undefined + +---------------------------------------------------- +-- Texture operations + + +type WinMappedTexture = IORef (Map GLUT.Window TextureObject) ++newWinMappedTexture :: (TextureObject -> ContextCache -> IO a) -> IO WinMappedTexture +newWinMappedTexture ionew = do + cache <- getCurrentOrSetHiddenContext + [tex] <- genObjectNames 1 + -- putStrLn $ "Created texture " ++ show tex + ionew tex cache+ ref <- newIORef $ Map.singleton (contextWindow cache) tex+ mkWeakIORef ref $ do m <- readIORef ref+ w <- get GLUT.currentWindow+ mapM_ deleteTexture $ Map.toList m+ GLUT.currentWindow $= w+ -- putStrLn "Deleted texture"+ return ref+ where+ deleteTexture (w,t) = do GLUT.currentWindow $= Just w+ deleteObjectNames [t]+ +bindWinMappedTexture target w ref s = do + mtex <- atomicModifyIORef ref (\a -> (a, takeOne a)) + case mtex of + Right tex -> textureBinding target $= Just tex + Left (w',t) -> do GLUT.currentWindow $= Just w' + textureBinding target $= Just t + ft <- get $ textureLevelRange target + f <- get $ textureInternalFormat (Left target) 0 + tex <- transferTexture s ft f + textureLevelRange target $= ft + -- putStrLn $ "Transferred texture " ++ show tex + atomicModifyIORef ref (flip (,) () . Map.insertWith (const id) w tex) + where takeOne a = case Map.lookup w a of + Nothing -> Left $ Map.elemAt 0 a + Just t -> Right t + createTexInWin = do GLUT.currentWindow $= Just w + [tex] <- genObjectNames 1 + textureBinding target $= Just tex + return tex + transferTexture Sampler3D (from,to) f = do + psSize <- mapM getDataAndSize3D [from..to] + tex <- createTexInWin + mapM_ (setDataWithSize3D f) $ zip psSize [from..to] + return tex + transferTexture Sampler2D (from,to) f = do + psSize <- mapM getDataAndSize2D [from..to] + tex <- createTexInWin + mapM_ (setDataWithSize2D f) $ zip psSize [from..to] + return tex + transferTexture Sampler1D (from,to) f = do + psSize <- mapM getDataAndSize1D [from..to] + tex <- createTexInWin + mapM_ (setDataWithSize1D f) $ zip psSize [from..to] + return tex + transferTexture SamplerCube (from,to) f = do + psSize <- mapM getDataAndSizeCube [(n,side) | n <- [from..to], side <- cubeMapTargets] + tex <- createTexInWin + mapM_ (setDataWithSizeCube f) $ zip psSize [(n,side) | n <- [from..to], side <- cubeMapTargets] + return tex + + getDataAndSize3D n = do + s@(TextureSize3D x y z) <- get $ textureSize3D (Left Texture3D) n + fp <- mallocForeignPtrBytes (fromIntegral x * fromIntegral y * fromIntegral z * 4 * sizeOf (undefined :: Float)) + withForeignPtr fp $ \ p -> getTexImage (Left Texture3D) n (PixelData RGBA Float p) + return (s,fp) + setDataWithSize3D f ((s,fp),n) = + withForeignPtr fp $ \ p -> texImage3D NoProxy n f s 0 (PixelData RGBA Float p) + getDataAndSize2D n = do + s@(TextureSize2D x y) <- get $ textureSize2D (Left Texture2D) n + fp <- mallocForeignPtrBytes (fromIntegral x * fromIntegral y * 4 * sizeOf (undefined :: Float)) + withForeignPtr fp $ \ p -> getTexImage (Left Texture2D) n (PixelData RGBA Float p) + return (s,fp) + setDataWithSize2D f ((s,fp),n) = + withForeignPtr fp $ \ p -> texImage2D Nothing NoProxy n f s 0 (PixelData RGBA Float p) + getDataAndSize1D n = do + s@(TextureSize1D x) <- get $ textureSize1D (Left Texture1D) n + fp <- mallocForeignPtrBytes (fromIntegral x * 4 * sizeOf (undefined :: Float)) + withForeignPtr fp $ \ p -> getTexImage (Left Texture2D) n (PixelData RGBA Float p) + return (s,fp) + setDataWithSize1D f ((s,fp),n) = + withForeignPtr fp $ \ p -> texImage1D NoProxy n f s 0 (PixelData RGBA Float p) + getDataAndSizeCube (n,side) = do + s@(TextureSize2D x y) <- get $ textureSize2D (Right side) n + fp <- mallocForeignPtrBytes (fromIntegral x * fromIntegral y * 4 * sizeOf (undefined :: Float)) + withForeignPtr fp $ \ p -> getTexImage (Right side) n (PixelData RGBA Float p) + return (s,fp) + setDataWithSizeCube f ((s,fp),(n,side)) = + withForeignPtr fp $ \ p -> texImage2D (Just side) NoProxy n f s 0 (PixelData RGBA Float p) + +cubeMapTargets = [TextureCubeMapPositiveX, TextureCubeMapNegativeX, TextureCubeMapPositiveY, TextureCubeMapNegativeY, TextureCubeMapPositiveZ, TextureCubeMapNegativeZ]
+ src/Shader.hs view
@@ -0,0 +1,525 @@+----------------------------------------------------------------------------- +-- +-- Module : Shader +-- Copyright : Tobias Bexelius +-- License : BSD3 +-- +-- Maintainer : Tobias Bexelius +-- Stability : Experimental +-- Portability : Portable +-- +-- | +-- +----------------------------------------------------------------------------- + +module Shader ( + GPU(..), + Shader, + Uniform(..), + addInput, + addUniform, + runShader, + vertexProgram, + fragmentProgram, + colorFragmentShader, + colorDepthFragmentShader, + addVertexSamplerUniform, + addFragmentSamplerUniform, + Vertex(Vertex), + Fragment(Fragment), + Real'(..), + dFdx, + dFdy, + fwidth, + vSampleFunc, + fSampleFunc, + module Data.Boolean +) where + +import System.IO.Unsafe +import Data.Vec ((:.)(..), Vec2, Vec3, Vec4, norm, normalize, dot, cross) +import qualified Data.Vec as Vec +import Data.Unique +import Data.List +import Data.Boolean +import Control.Monad.State +import Data.Map (Map) +import qualified Data.Map as Map hiding (Map) +import Data.IntSet (IntSet) +import qualified Data.IntSet as IntSet hiding (IntSet) +import Control.Arrow (first, second) +import Resources +import Formats + +-- | Denotes a type on the GPU, that can be moved there from the CPU (through the internal use of uniforms).+-- Use the existing instances of this class to create new ones. Note that 'toGPU' should not be strict on its argument.+-- Its definition should also always use the same series of 'toGPU' calls to convert values of the same type. This unfortunatly+-- rules out ordinary lists (but instances for fixed length lists from the Vec package are however provided).+class GPU a where+ -- | The type on the CPU. + type CPU a+ -- | Converts a value from the CPU to the GPU. + toGPU :: CPU a -> a + +type Shader = State (Map Unique Uniform, IntSet) + +vertexProgram vPos rast fins = let ((pos, outs), uns, ins) = runShader $ do vPos' <- vPos + rast' <- selectM fins rast + return (vPos', rast') + sig = shaderInputSplits "attr" "va" ins ++ + vertexOutputSets fins outs ++ + "gl_Position = " ++ pos ++ ";\n" + in (("#version 120\n" ++ + uniformDecls "vu" uns ++ + attributeDecls ins ++ + varyingDecls outs ++ + "void main(){\n" ++ + sig ++ + "}\n", sig), uns, ins) + +fragmentProgram m = let (outs, uns,ins) = runShader m + sig = shaderInputSplits "var" "fa" ins ++outs + in (("#version 120\n" ++ + uniformDecls "fu" uns ++ + varyingDecls ins ++ + "void main(){\n" ++ + sig ++ + "}\n", sig), uns, ins) + +selectM (x:xs) ys = let (a:b) = drop x ys in do a' <- a + b' <- selectM (map (\t -> t-x-1) xs) b + return (a':b') +selectM [] _ = return [] ++colorFragmentShader :: Fragment Bool -> Vec4 (Fragment Float) -> Shader String +colorFragmentShader (Fragment nDisc) (Fragment r :. Fragment g :. Fragment b :. Fragment a :. ()) = + do r' <- r + g' <- g + b' <- b + a' <- a + nDisc' <- nDisc + return $ "if (!" ++ nDisc' ++ ") discard;\n" + ++ "gl_FragColor=vec4(" ++ r' ++ "," ++ g' ++ "," ++ b' ++ "," ++ a' ++ ");\n" + +colorDepthFragmentShader :: Fragment Bool -> (Vec4 (Fragment Float), Fragment Float) -> Shader String +colorDepthFragmentShader (Fragment nDisc) ((Fragment r :. Fragment g :. Fragment b :. Fragment a :. ()), Fragment d) = + do r' <- r + g' <- g + b' <- b + a' <- a + d' <- d + nDisc' <- nDisc + return $ "if (!" ++ nDisc' ++ ") discard;\n" + ++ "gl_FragDepth=" ++ d' ++ ";\n" ++ + "gl_FragColor=vec4(" ++ r' ++ "," ++ g' ++ "," ++ b' ++ "," ++ a' ++ ");\n" + +uniformDecls :: String -> UniformSet -> String +uniformDecls p (f,i,b,s) = let makeU tn xs = if not $ null xs + then "uniform " ++ tn ++ p ++ "[" ++ show (length xs) ++ "];\n" + else "" + in makeU "float f" f ++ makeU "int i" i ++ makeU "bool b" b ++ + concatMap (\(t,xs) -> makeU (samplerTypeString t ++ " s" ++ show (fromEnum t)) xs) s + +-- Generates e.g. [(0,4), (1,4), (2,3)] from [x,x,x,x,x,x,x,x,x,x,x] (length 11) +inputVecs ins = [(i,min (length ins - i*4) 4) | i <- [0..(length ins - 1) `div` 4]] + +attributeDecls ins = concat [ "attribute " ++ tName v ++ " attr" ++ show i ++ ";\n" | (i,v) <- inputVecs ins] +varyingDecls ins = concat [ "varying " ++ tName v ++ " var" ++ show i ++ ";\n" | (i,v) <- inputVecs ins] ++shaderInputSplits :: String -> String -> [Int] -> String +shaderInputSplits from to ins = concat [ "float " ++ to ++ show i ++ " = " ++ from ++ show a ++ subElem c e ++ ";\n" | i <- ins | (a,e) <- inputVecs ins, c <- [0..3]] +vertexOutputSets ins outs = concat [ "var" ++ show v ++ subElem c e ++ " = " ++ outs!!i ++ ";\n" | i <- ins | (v,e) <- inputVecs ins, c <- [0..3]] ++subElem :: Int -> Int -> String +subElem _ 1 = "" +subElem x _ = ['.', (['x','y','z','w']!!x)] ++tName :: Int -> String +tName 1 = "float" +tName x = "vec" ++ show x + +data Uniform = FloatUniform Float + | IntUniform Int + | BoolUniform Bool + | SamplerUniform SamplerType Sampler WinMappedTexture +samplerTypeString Sampler3D = "sampler3D" +samplerTypeString Sampler2D = "sampler2D" +samplerTypeString Sampler1D = "sampler1D" +samplerTypeString SamplerCube = "samplerCube" ++vSampleFunc f t s tex c xs = toColor $ fromVVec 4 (vListFunc f $ [addVertexSamplerUniform t s tex, vVec c] ++ xs) +fSampleFunc f t s tex c xs = toColor $ fromFVec 4 (fListFunc f $ [addFragmentSamplerUniform t s tex, fVec c] ++ xs) + +addVertexSamplerUniform t s = Vertex . addUniform ("s" ++ show (fromEnum t) ++ "vu") . SamplerUniform t s +addFragmentSamplerUniform t s = Fragment . addUniform ("s" ++ show (fromEnum t) ++ "fu") . SamplerUniform t s ++-- | An opaque type constructor for atomic values in a vertex on the GPU, e.g. 'Vertex' 'Float'.+newtype Vertex a = Vertex { fromVertex :: Shader String } +-- | An opaque type constructor for atomic values in a fragment on the GPU, e.g. 'Fragment' 'Float'. +newtype Fragment a = Fragment { fromFragment :: Shader String } + +runShader :: Shader a -> (a, UniformSet, [Int]) +runShader m = (a, getSamplerList $ splitSet ([],[],[], Map.empty) $ reverse $ Map.elems $ fst s, IntSet.toAscList $ snd s) + where (a,s) = runState m (Map.empty, IntSet.empty) + splitSet (f,i,b,s) (FloatUniform u:xs) = splitSet (u:f,i,b,s) xs + splitSet (f,i,b,s) (IntUniform u:xs) = splitSet (f,u:i,b,s) xs + splitSet (f,i,b,s) (BoolUniform u:xs) = splitSet (f,i,u:b,s) xs + splitSet (f,i,b,s) (SamplerUniform t samp tex:xs) = splitSet (f,i,b, Map.insertWith (++) t [(samp,tex)] s) xs + splitSet s [] = s + getSamplerList (f,i,b,s) = (f,i,b, Map.toList s) + ++addInput :: Int -> Shader () +addInput = modify . second . IntSet.insert+addUniform :: String -> Uniform -> Shader String +addUniform p u = do x <- gets fst + case Map.lookupIndex n x of + Nothing -> do let x' = Map.insert n u' x + s = Map.findIndex n x' + modify $ first $ const x' + return $ p ++ "[" ++ show s ++ "]" + Just i -> return $ p ++ "[" ++ show i ++ "]" + where (n,u') = unsafePerformIO $ do n <- newUnique + return (n,u) --wire u to make it happen as often as we want... + + +instance GPU (Vertex Float) where + type CPU (Vertex Float) = Float + toGPU = Vertex . addUniform "fvu" . FloatUniform +instance GPU (Vertex Int) where + type CPU (Vertex Int) = Int + toGPU = Vertex . addUniform "ivu" . IntUniform +instance GPU (Vertex Bool) where + type CPU (Vertex Bool) = Bool + toGPU = Vertex . addUniform "bvu" . BoolUniform + +instance GPU (Fragment Float) where + type CPU (Fragment Float) = Float + toGPU = Fragment . addUniform "ffu" . FloatUniform +instance GPU (Fragment Int) where + type CPU (Fragment Int) = Int + toGPU = Fragment . addUniform "ifu" . IntUniform +instance GPU (Fragment Bool) where + type CPU (Fragment Bool) = Bool + toGPU = Fragment . addUniform "bfu" . BoolUniform + + +instance GPU () where + type CPU () = () + toGPU = id +instance (GPU a, GPU b) => GPU (a,b) where + type CPU (a,b) = (CPU a, CPU b) + toGPU (a,b)= (toGPU a, toGPU b) +instance (GPU a, GPU b, GPU c) => GPU (a,b,c) where + type CPU (a,b,c) = (CPU a, CPU b, CPU c) + toGPU (a,b,c)= (toGPU a, toGPU b, toGPU c) +instance (GPU a, GPU b, GPU c, GPU d) => GPU (a,b,c,d) where + type CPU (a,b,c,d) = (CPU a, CPU b, CPU c, CPU d) + toGPU (a,b,c,d)= (toGPU a, toGPU b, toGPU c, toGPU d) + +instance (GPU a, GPU b) => GPU (a:.b) where + type CPU (a:.b) = CPU a :. CPU b + toGPU (a:.b) = toGPU a :. toGPU b+ +instance Eq (Vertex a) where + (==) = noFun "(==)" + (/=) = noFun "(/=)" +instance Eq (Fragment a) where + (==) = noFun "(==)" + (/=) = noFun "(/=)" + +instance Ord a => Ord (Vertex a) where + (<=) = noFun "(<=)" + min = vBinaryFunc "min" + max = vBinaryFunc "max" +instance Ord a => Ord (Fragment a) where + (<=) = noFun "(<=)" + min = fBinaryFunc "min" + max = fBinaryFunc "max" + +instance Show (Vertex a) where + show = noFun "show" +instance Show (Fragment a) where + show = noFun "show" + +instance Num a => Num (Vertex a) where + negate = vUnaryPreOp "-" + (+) = vBinaryOp "+" + (*) = vBinaryOp "*" + fromInteger a = Vertex $ return $ show (fromInteger a :: a) + abs = vUnaryFunc "abs" + signum = vUnaryFunc "sign" +instance Num a => Num (Fragment a) where + negate = fUnaryPreOp "-" + (+) = fBinaryOp "+" + (*) = fBinaryOp "*" + fromInteger a = Fragment $ return $ show (fromInteger a :: a) + abs = fUnaryFunc "abs" + signum = fUnaryFunc "sign" + +instance Fractional a => Fractional (Vertex a) where + (/) = vBinaryOp "/" + fromRational a = Vertex $ return $ show (fromRational a :: a) +instance Fractional a => Fractional (Fragment a) where + (/) = fBinaryOp "/" + fromRational a = Fragment $ return $ show (fromRational a :: a) + +instance Floating a => Floating (Vertex a) where + pi = fromRational (toRational (pi :: Double)) + sqrt = vUnaryFunc "sqrt" + exp = vUnaryFunc "exp" + log = vUnaryFunc "log" + (**) = vBinaryFunc "pow" + sin = vUnaryFunc "sin" + cos = vUnaryFunc "cos" + tan = vUnaryFunc "tan" + asin = vUnaryFunc "asin" + acos = vUnaryFunc "acos" + atan = vUnaryFunc "atan" + sinh = noFun "sinh" + cosh = noFun "cosh" + asinh = noFun "asinh" + atanh = noFun "atanh" + acosh = noFun "acosh" + +instance Floating a => Floating (Fragment a) where + pi = fromRational (toRational (pi :: Double)) + sqrt = fUnaryFunc "sqrt" + exp = fUnaryFunc "exp" + log = fUnaryFunc "log" + (**) = fBinaryFunc "pow" + sin = fUnaryFunc "sin" + cos = fUnaryFunc "cos" + tan = fUnaryFunc "tan" + asin = fUnaryFunc "asin" + acos = fUnaryFunc "acos" + atan = fUnaryFunc "atan" + sinh = noFun "sinh" + cosh = noFun "cosh" + asinh = noFun "asinh" + atanh = noFun "atanh" + acosh = noFun "acosh" ++-- | This class provides the GPU functions either not found in Prelude's numerical classes, or that has wrong types.+-- Instances are also provided for normal 'Float's and 'Double's.+-- Minimal complete definition: 'floor'' and 'ceiling''.+class (Ord a, Floating a) => Real' a where + rsqrt :: a -> a + exp2 :: a -> a + log2 :: a -> a + floor' :: a -> a + ceiling' :: a -> a + fract' :: a -> a + mod' :: a -> a -> a + clamp :: a -> a -> a -> a + saturate :: a -> a + mix :: a -> a -> a-> a + step :: a -> a -> a + smoothstep :: a -> a -> a -> a + + rsqrt = (1/) . sqrt + exp2 = (2**) + log2 = logBase 2 + clamp x a b = min (max x a) b + saturate x = clamp x 0 1 + mix x y a = x*(1-a)+y*a + step a x | x < a = 0 + | otherwise = 1 + smoothstep a b x = let t = saturate ((x-a) / (b-a)) + in t*t*(3-2*t) + fract' x = x - floor' x + mod' x y = x - y* floor' (x/y)+ +instance Real' Float where + floor' = fromIntegral . floor + ceiling' = fromIntegral . ceiling + +instance Real' Double where + floor' = fromIntegral . floor + ceiling' = fromIntegral . ceiling + +instance Real' (Vertex Float) where + rsqrt = vUnaryFunc "inversesqrt" + exp2 = vUnaryFunc "exp2" + log2 = vUnaryFunc "log2" + floor' = vUnaryFunc "floor" + ceiling' = vUnaryFunc "ceil" + fract' = vUnaryFunc "fract" + mod' = vBinaryFunc "mod" + clamp x a b = vListFunc "clamp" [x,a,b] + mix x y a = vListFunc "mix" [x,y,a] + step = vBinaryFunc "step" + smoothstep a b x = vListFunc "smoothstep" [a,b,x] + +instance Real' (Fragment Float) where + rsqrt = fUnaryFunc "inversesqrt" + exp2 = fUnaryFunc "exp2" + log2 = fUnaryFunc "log2" + floor' = fUnaryFunc "floor" + ceiling' = fUnaryFunc "ceil" + fract' = fUnaryFunc "fract" + mod' = fBinaryFunc "mod" + clamp x a b = fListFunc "clamp" [x,a,b] + mix x y a = fListFunc "mix" [x,y,a] + step = fBinaryFunc "step" + smoothstep a b x = fListFunc "smoothstep" [a,b,x] + +instance Boolean (Vertex Bool) where + true = Vertex $ return "true" + false = Vertex $ return "false" + notB = vUnaryFunc "not" + (&&*) = vBinaryOp "&&" + (||*) = vBinaryOp "||" + +instance Boolean (Fragment Bool) where + true = Fragment $ return "true" + false = Fragment $ return "false" + notB = fUnaryFunc "not" + (&&*) = fBinaryOp "&&" + (||*) = fBinaryOp "||" + +instance Eq a => EqB (Vertex Bool) (Vertex a) where + (==*) = vBinaryOp "==" + (/=*) = vBinaryOp "!=" + +instance Eq a => EqB (Fragment Bool) (Fragment a) where + (==*) = fBinaryOp "==" + (/=*) = fBinaryOp "!=" + +instance Ord a => OrdB (Vertex Bool) (Vertex a) where + (<*) = vBinaryOp "<" + (>=*) = vBinaryOp ">=" + (>*) = vBinaryOp ">" + (<=*) = vBinaryOp "<=" +instance Ord a => OrdB (Fragment Bool) (Fragment a) where + (<*) = fBinaryOp "<" + (>=*) = fBinaryOp ">=" + (>*) = fBinaryOp ">" + (<=*) = fBinaryOp "<=" + +instance IfB (Vertex Bool) (Vertex a) where + ifB c a b = Vertex $ do c' <- fromVertex c + a' <- fromVertex a + b' <- fromVertex b + return $ "(" ++ c' ++ "?" ++ a' ++ ":" ++ b' ++ ")" + +instance IfB (Fragment Bool) (Fragment a) where + ifB c a b = Fragment $ do c' <- fromFragment c + a' <- fromFragment a + b' <- fromFragment b + return $ "(" ++ c' ++ "?" ++ a' ++ ":" ++ b' ++ ")" ++-- | The derivative in x using local differencing of the rasterized value. +dFdx :: Fragment Float -> Fragment Float +-- | The derivative in y using local differencing of the rasterized value. +dFdy :: Fragment Float -> Fragment Float +-- | The sum of the absolute derivative in x and y using local differencing of the rasterized value. +fwidth :: Fragment Float -> Fragment Float +dFdx = fUnaryFunc "dFdx" +dFdy = fUnaryFunc "dFdy" +fwidth = fUnaryFunc "fwidth" + +-------------------------------------- +-- Vector specializations + +{-# RULES "norm/F4" norm = normF4 #-} +{-# RULES "norm/F3" norm = normF3 #-} +{-# RULES "norm/F2" norm = normF2 #-} +normF4 :: Vec4 (Fragment Float) -> Fragment Float +normF4 = fUnaryFunc "length" . fVec +normF3 :: Vec3 (Fragment Float) -> Fragment Float +normF3 = fUnaryFunc "length" . fVec +normF2 :: Vec2 (Fragment Float) -> Fragment Float +normF2 = fUnaryFunc "length" . fVec +{-# RULES "norm/V4" norm = normV4 #-} +{-# RULES "norm/V3" norm = normV3 #-} +{-# RULES "norm/V2" norm = normV2 #-} +normV4 :: Vec4 (Vertex Float) -> Vertex Float +normV4 = vUnaryFunc "length" . vVec +normV3 :: Vec3 (Vertex Float) -> Vertex Float +normV3 = vUnaryFunc "length" . vVec +normV2 :: Vec2 (Vertex Float) -> Vertex Float +normV2 = vUnaryFunc "length" . vVec + +{-# RULES "normalize/F4" normalize = normalizeF4 #-} +{-# RULES "normalize/F3" normalize = normalizeF3 #-} +{-# RULES "normalize/F2" normalize = normalizeF2 #-} +normalizeF4 :: Vec4 (Fragment Float) -> Vec4 (Fragment Float) +normalizeF4 = fromFVec 4 . fUnaryFunc "normalize" . fVec +normalizeF3 :: Vec3 (Fragment Float) -> Vec3 (Fragment Float) +normalizeF3 = fromFVec 3 . fUnaryFunc "normalize" . fVec +normalizeF2 :: Vec2 (Fragment Float) -> Vec2 (Fragment Float) +normalizeF2 = fromFVec 2 . fUnaryFunc "normalize" . fVec +{-# RULES "normalize/V4" normalize = normalizeV4 #-} +{-# RULES "normalize/V3" normalize = normalizeV3 #-} +{-# RULES "normalize/V2" normalize = normalizeV2 #-} +normalizeV4 :: Vec4 (Vertex Float) -> Vec4 (Vertex Float) +normalizeV4 = fromVVec 4 . vUnaryFunc "normalize" . vVec +normalizeV3 :: Vec3 (Vertex Float) -> Vec3 (Vertex Float) +normalizeV3 = fromVVec 3 . vUnaryFunc "normalize" . vVec +normalizeV2 :: Vec2 (Vertex Float) -> Vec2 (Vertex Float) +normalizeV2 = fromVVec 2 . vUnaryFunc "normalize" . vVec + +{-# RULES "dot/F4" dot = dotF4 #-} +{-# RULES "dot/F3" dot = dotF3 #-} +{-# RULES "dot/F2" dot = dotF2 #-} +dotF4 :: Vec4 (Fragment Float) -> Vec4 (Fragment Float) -> Fragment Float +dotF4 a b = fBinaryFunc "dot" (fVec a) (fVec b) +dotF3 :: Vec3 (Fragment Float) -> Vec3 (Fragment Float) -> Fragment Float +dotF3 a b = fBinaryFunc "dot" (fVec a) (fVec b) +dotF2 :: Vec2 (Fragment Float) -> Vec2 (Fragment Float) -> Fragment Float +dotF2 a b = fBinaryFunc "dot" (fVec a) (fVec b) +{-# RULES "dot/V4" dot = dotV4 #-} +{-# RULES "dot/V3" dot = dotV3 #-} +{-# RULES "dot/V2" dot = dotV2 #-} +dotV4 :: Vec4 (Vertex Float) -> Vec4 (Vertex Float) -> Vertex Float +dotV4 a b = vBinaryFunc "dot" (vVec a) (vVec b) +dotV3 :: Vec3 (Vertex Float) -> Vec3 (Vertex Float) -> Vertex Float +dotV3 a b = vBinaryFunc "dot" (vVec a) (vVec b) +dotV2 :: Vec2 (Vertex Float) -> Vec2 (Vertex Float) -> Vertex Float +dotV2 a b = vBinaryFunc "dot" (vVec a) (vVec b) + +{-# RULES "cross/F3" cross = crossF3 #-} +crossF3 :: Vec3 (Fragment Float) -> Vec3 (Fragment Float) -> Vec3 (Fragment Float) +crossF3 a b = fromFVec 3 $ fBinaryFunc "cross" (fVec a) (fVec b) +{-# RULES "cross/V3" cross = crossV3 #-} +crossV3 :: Vec3 (Vertex Float) -> Vec3 (Vertex Float) ->Vec3 (Vertex Float) +crossV3 a b = fromVVec 3 $ vBinaryFunc "cross" (vVec a) (vVec b) + +-------------------------------------- +-- Private +-- +noFun :: String -> a +noFun = error . (++ ": No overloading for Vertex/Fragment") + +vListFunc s xs = Vertex $ do xs' <- mapM fromVertex xs + return $ s ++ "(" ++ intercalate "," xs' ++ ")" +fListFunc s xs = Fragment $ do xs' <- mapM fromFragment xs + return $ s ++ "(" ++ intercalate "," xs' ++ ")" +vUnaryFunc s a = vListFunc s [a] +fUnaryFunc s a = fListFunc s [a] +vBinaryFunc s a b = vListFunc s [a,b] +fBinaryFunc s a b = fListFunc s [a,b] + +vUnaryPreOp s a = Vertex $ do a' <- fromVertex a + return $ "(" ++ s ++ a' ++ ")" +fUnaryPreOp s a = Fragment $ do a' <- fromFragment a + return $ "(" ++ s ++ a' ++ ")" + +vBinaryOp s a b = Vertex $ do a' <- fromVertex a + b' <- fromVertex b + return $ "(" ++ a' ++ s ++ b' ++ ")" +fBinaryOp s a b = Fragment $ do a' <- fromFragment a + b' <- fromFragment b + return $ "(" ++ a' ++ s ++ b' ++ ")" + +vVec v = let xs = Vec.toList v in vListFunc (tName $ length xs) xs +fVec v = let xs = Vec.toList v in fListFunc (tName $ length xs) xs + +fromVVec e v = Vec.fromList $ map (\n -> Vertex $ do v' <- fromVertex v + return (v' ++ subElem n e)) + [0..(e-1)] +fromFVec e v = Vec.fromList $ map (\n -> Fragment $ do v' <- fromFragment v + return (v' ++ subElem n e)) + [0..(e-1)] +
+ src/Textures.hs view
@@ -0,0 +1,338 @@+----------------------------------------------------------------------------- +-- +-- Module : Textures +-- Copyright : Tobias Bexelius +-- License : BSD3 +-- +-- Maintainer : Tobias BexeliusBSD3 +-- Stability : Experimental +-- Portability : Portable +-- +-- | +-- +----------------------------------------------------------------------------- + +module Textures ( + Texture3D(), + Texture2D(), + Texture1D(), + TextureCube(), + Texture(type TextureFormat, type TextureSize, type TextureVertexCoord, type TextureFragmentCoord, textureCPUFormatByteSize, sample, sampleBias, sampleLod), + newTexture, + newDepthTexture, + FromFrameBufferColor(..), + FromFrameBufferDepth(..), + DepthColorFormat(), + fromFrameBufferCubeColor, + fromFrameBufferCubeDepth +) where + +import Data.Vec ((:.)(..), Vec2, Vec3, Vec4) +import Shader +import Resources +import OutputMerger +import Foreign.Ptr +import qualified Graphics.Rendering.OpenGL as GL +import Graphics.Rendering.OpenGL (($=), get) +import qualified Graphics.UI.GLUT as GLUT +import System.IO.Unsafe (unsafePerformIO) +import Formats +import Control.Monad +import Data.List + + +-- | A 3D texture. May only be created from main memory in GPipe.+-- 'Texture3D' @f@ has the following associated types in its 'Texture' instance:+--+-- [@TextureFormat (Texture3D f)@] @f@+--+-- [@TextureSize (Texture3D f)@] 'Vec3' 'Int'+--+-- [@TextureVertexCoord (Texture3D f)@] 'Vec3' @(@'Vertex' 'Float'@)@+--+-- [@TextureFragmentCoord (Texture3D f)@] 'Vec3' @(@'Fragment' 'Float'@)@+-- +newtype Texture3D f = Texture3D WinMappedTexture+-- | A 2D texture.+-- 'Texture2D' @f@ has the following associated types in its 'Texture' instance:+--+-- [@TextureFormat (Texture2D f)@] @f@+--+-- [@TextureSize (Texture2D f)@] 'Vec2' 'Int'+--+-- [@TextureVertexCoord (Texture2D f)@] 'Vec2' @(@'Vertex' 'Float'@)@+--+-- [@TextureFragmentCoord (Texture2D f)@] 'Vec2' @(@'Fragment' 'Float'@)@+-- +newtype Texture2D f = Texture2D WinMappedTexture+-- | A 1D texture. Assumes a frame buffer of height 1 when created from such.+-- 'Texture1D' @f@ has the following associated types in its 'Texture' instance:+--+-- [@TextureFormat (Texture1D f)@] @f@+--+-- [@TextureSize (Texture1D f)@] 'Int'+--+-- [@TextureVertexCoord (Texture1D f)@] 'Vertex' 'Float'+--+-- [@TextureFragmentCoord (Texture1D f)@] 'Fragment' 'Float'+-- +newtype Texture1D f = Texture1D WinMappedTexture+-- | A cube texture. The sides of the cube are always specified in this order: Positive X, negative X,+-- positive Y, negative Y, positive Z, negative Z.+-- 'TextureCube' @f@ has the following associated types in its 'Texture' instance:+--+-- [@TextureFormat (TextureCube f)@] @f@+--+-- [@TextureSize (TextureCube f)@] 'Vec2' 'Int' (The size of each side)+--+-- [@TextureVertexCoord (TextureCube f)@] 'Vec3' @(@'Vertex' 'Float'@)@+--+-- [@TextureFragmentCoord (TextureCube f)@] 'Vec3' @(@'Fragment' 'Float'@)@+-- +newtype TextureCube f = TextureCube WinMappedTexture + +class Texture t where+ -- | The color format of the texture, affects the type of the samples from the texture. + type TextureFormat t+ -- | The type that is used for the dimension of texture. + type TextureSize t+ -- | The sample coordinate in 'Vertex's. + type TextureVertexCoord t + -- | The sample coordinate in 'Fragment's. + type TextureFragmentCoord t + mkTexture :: CPUFormat (TextureFormat t) -> GL.PixelInternalFormat -> TextureSize t -> [Ptr a] -> IO t + -- | Calculates the byte size of all mipmaps for a specific format and size, which eases the useage of+ -- 'newTexture' and 'newDepthTexture'. + textureCPUFormatByteSize :: CPUFormat (TextureFormat t) -> TextureSize t -> [Int]+ -- | Samples the texture using mipmaps in a 'Fragment'. + sample :: Sampler -> t -> TextureFragmentCoord t -> Color (TextureFormat t) (Fragment Float) + -- | Samples the texture using mipmaps in a 'Fragment', with a bias to add to the mipmap level. + sampleBias :: Sampler -> t -> TextureFragmentCoord t -> Fragment Float -> Color (TextureFormat t) (Fragment Float) + -- | Samples the texture using a specific mipmap in a 'Vertex'. + sampleLod :: Sampler -> t -> TextureVertexCoord t -> Vertex Float -> Color (TextureFormat t) (Vertex Float) ++-- | Creates a texture from color data in main memory. It lives in the IO monad for the sake of the Ptr's, and could otherwise safely be wrapped in @unsafePerformIO@ calls. +newTexture :: (Texture t, GPUFormat (TextureFormat t))+ => CPUFormat (TextureFormat t) -- ^ The format of the data in the provided Ptr's.+ -> TextureFormat t -- ^ The format of the resulting texture on the GPU.+ -> TextureSize t -- ^ The dimension of the texture.+ -> [Ptr a] -- ^ A list of Ptr's for each mipmap of the texture (you may provide as many as you want).+ -- For 'TextureCube', this list starts with all mipmaps of the first side, then the mipmaps+ -- of the second, and so on. In this case all sides must have the same number of mipmaps.+ -> IO t +newTexture f i = mkTexture f (toGLInternalFormat i) ++-- | Creates a depth texture from data in main memory. The texture will have the type of a color format and is sampled as such, but contains depth+-- component information internally. It lives in the IO monad for the sake of the Ptr's, and could otherwise safely be wrapped in @unsafePerformIO@ calls. +newDepthTexture :: (Texture t, DepthColorFormat (TextureFormat t))+ => CPUFormat (TextureFormat t) -- ^ The format of the data in the provided Ptr's.+ -> DepthFormat -- ^ The depth format of the resulting texture on the GPU.+ -> TextureSize t-- ^ The dimension of the texture.+ -> [Ptr a] -- ^ A list of Ptr's for each mipmap of the texture (you may provide as many as you want).+ -- For 'TextureCube', this list starts with all mipmaps of the first side, then the mipmaps+ -- of the second, and so on. In this case all sides must have the same number of mipmaps.+ -> IO t +newDepthTexture f i = mkTexture f (toGLInternalFormat i) + +mipLevels 1 = 1 : mipLevels 1 +mipLevels x = x : mipLevels (x `div` 2) +mipLevels' 1 = [1] +mipLevels' x = x : mipLevels' (x `div` 2) + +instance ColorFormat f => Texture (Texture3D f) where + type TextureFormat (Texture3D f) = f + type TextureSize (Texture3D f) = Vec3 Int + type TextureVertexCoord (Texture3D f) = Vec3 (Vertex Float) + type TextureFragmentCoord (Texture3D f) = Vec3 (Fragment Float) + mkTexture f i s ps = liftM Texture3D $ newWinMappedTexture $ \ tex cache -> + do f' <- evaluateDeep f + i' <- evaluateDeep i + x:.y:.z:.() <- evaluateDeep s + ps' <- mapM evaluatePtr ps + GLUT.currentWindow $= Just (contextWindow cache) + let size = GL.TextureSize3D (fromIntegral x) (fromIntegral y) (fromIntegral z) + GL.textureBinding GL.Texture3D $= Just tex + mapM_ (\(n, p) -> + GL.texImage3D GL.NoProxy n i' size 0 + (GL.PixelData (toGLPixelFormat (undefined::f)) (toGLDataType f') p)) + [(i,p) | i<- [0..] | p<- ps'] + GL.textureLevelRange GL.Texture3D $= (0, fromIntegral $ length ps' - 1) + textureCPUFormatByteSize f (x:.y:.z:.()) = map (\(x,y,z)-> y*z*formatRowByteSize f x) [(x',y',z') | x' <- mipLevels x | y' <- mipLevels y | z' <- mipLevels z | _ <- mipLevels' (max x (max y z))] + sample s (Texture3D t) v = fSampleFunc "texture3D" Sampler3D s t v [] + sampleBias s (Texture3D t) v b = fSampleFunc "texture3D" Sampler3D s t v [b] + sampleLod s (Texture3D t) v m = vSampleFunc "texture3DLod" Sampler3D s t v [m] +instance ColorFormat f => Texture (Texture2D f) where + type TextureFormat (Texture2D f) = f + type TextureSize (Texture2D f) = Vec2 Int + type TextureVertexCoord (Texture2D f) = Vec2 (Vertex Float) + type TextureFragmentCoord (Texture2D f) = Vec2 (Fragment Float) + mkTexture f i s ps = liftM Texture2D $ newWinMappedTexture $ \ tex cache-> + do f' <- evaluateDeep f + i' <- evaluateDeep i + x:.y:.() <- evaluateDeep s + ps' <- mapM evaluatePtr ps + GLUT.currentWindow $= Just (contextWindow cache) + let size = GL.TextureSize2D (fromIntegral x) (fromIntegral y) + GL.textureBinding GL.Texture2D $= Just tex + mapM_ (\(n, p) -> + GL.texImage2D Nothing GL.NoProxy n i' size 0 + (GL.PixelData (toGLPixelFormat (undefined::f)) (toGLDataType f') p)) + [(i,p) | i<- [0..] | p<- ps'] + GL.textureLevelRange GL.Texture2D $= (0, fromIntegral $ length ps' - 1) + textureCPUFormatByteSize f (x:.y:.()) = map (\(x,y)-> y*formatRowByteSize f x) [(x',y') | x' <- mipLevels x | y' <- mipLevels y | _ <- mipLevels' (max x y)] + sample s (Texture2D t) v = fSampleFunc "texture2D" Sampler2D s t v [] + sampleBias s (Texture2D t) v b = fSampleFunc "texture2D" Sampler2D s t v [b] + sampleLod s (Texture2D t) v m = vSampleFunc "texture2DLod" Sampler2D s t v [m] +instance ColorFormat f => Texture (Texture1D f) where + type TextureFormat (Texture1D f) = f + type TextureSize (Texture1D f) = Int + type TextureVertexCoord (Texture1D f) = Vertex Float + type TextureFragmentCoord (Texture1D f) = Fragment Float + mkTexture f i s ps = liftM Texture1D $ newWinMappedTexture $ \ tex cache -> + do f' <- evaluateDeep f + i' <- evaluateDeep i + x <- evaluateDeep s + ps' <- mapM evaluatePtr ps + GLUT.currentWindow $= Just (contextWindow cache) + let size = GL.TextureSize1D (fromIntegral x) + GL.textureBinding GL.Texture1D $= Just tex + mapM_ (\(n, p) -> + GL.texImage1D GL.NoProxy n i' size 0 + (GL.PixelData (toGLPixelFormat (undefined::f)) (toGLDataType f') p)) + [(i,p) | i<- [0..] | p<- ps'] + GL.textureLevelRange GL.Texture1D $= (0, fromIntegral $ length ps' - 1) + textureCPUFormatByteSize f x = map (\x-> formatRowByteSize f x) [x' | x' <- mipLevels' x] + sample s (Texture1D t) v = fSampleFunc "texture1D" Sampler1D s t (v:.()) [] + sampleBias s (Texture1D t) v b = fSampleFunc "texture1D" Sampler1D s t (v:.()) [b] + sampleLod s (Texture1D t) v m = vSampleFunc "texture1DLod" Sampler1D s t (v:.()) [m] +instance ColorFormat f => Texture (TextureCube f) where + type TextureFormat (TextureCube f) = f + type TextureSize (TextureCube f) = Vec2 Int + type TextureVertexCoord (TextureCube f) = Vec3 (Vertex Float) + type TextureFragmentCoord (TextureCube f) = Vec3 (Fragment Float) + mkTexture f i s ps = liftM TextureCube $ newWinMappedTexture $ \ tex cache -> + do f' <- evaluateDeep f + i' <- evaluateDeep i + x:.y:.() <- evaluateDeep s + ps' <- mapM evaluatePtr ps + GLUT.currentWindow $= Just (contextWindow cache) + let size = GL.TextureSize2D (fromIntegral x) (fromIntegral y) + GL.textureBinding GL.TextureCubeMap $= Just tex + mapM_ + (\(t,ps'') -> + mapM_ + (\(n, p) -> + GL.texImage2D (Just t) GL.NoProxy n i' size 0 + (GL.PixelData (toGLPixelFormat (undefined::f)) (toGLDataType f') p)) + [(i,p) | i<- [0..] | p<- ps'']) + [(t,ps'') | t <- cubeMapTargets | ps'' <- splitIn 6 ps'] + GL.textureLevelRange GL.TextureCubeMap $= (0, fromIntegral $ length ps' - 1) + textureCPUFormatByteSize f (x:.y:.()) = concat $ replicate 6 $ map (\(x,y)-> y*formatRowByteSize f x) [(x',y') | x' <- mipLevels x | y' <- mipLevels y | _ <- mipLevels' (max x y)] + sample s (TextureCube t) v = fSampleFunc "textureCube" Sampler3D s t v [] + sampleBias s (TextureCube t) v b = fSampleFunc "textureCube" Sampler3D s t v [b] + sampleLod s (TextureCube t) v m = vSampleFunc "textureCubeLod" Sampler3D s t v [m] ++-- | The formats that is instances of this class may be used as depth textures, i.e. created with+-- 'newDepthTexture', 'fromFrameBufferDepth' and 'fromFrameBufferCubeDepth'. +class ColorFormat a => DepthColorFormat a +instance DepthColorFormat LuminanceFormat +instance DepthColorFormat AlphaFormat ++-- | The textures that is instances of this class may be created from a 'FrameBuffer's color buffer. +class (Texture t) => FromFrameBufferColor t c where+ -- | Create a texture of a specific format from a 'FrameBuffer' and a size. + fromFrameBufferColor :: TextureFormat t -> TextureSize t -> FrameBuffer c d s -> t + +instance ColorFormat f => FromFrameBufferColor (Texture2D f) f where + fromFrameBufferColor f s fb = Texture2D $ unsafePerformIO $ do + newWinMappedTexture $ \ tex cache -> + do f' <- evaluateDeep (toGLInternalFormat f) + x:.y:.() <- evaluateDeep s + let size = GL.TextureSize2D (fromIntegral x) (fromIntegral y) + runFrameBufferInContext cache s fb + GL.textureBinding GL.Texture2D $= Just tex + GL.copyTexImage2D Nothing 0 f' (GL.Position 0 0) size 0 + GL.textureLevelRange GL.Texture2D $= (0, 0) +instance ColorFormat f => FromFrameBufferColor (Texture1D f) f where + fromFrameBufferColor f s fb = Texture1D $ unsafePerformIO $ do + newWinMappedTexture $ \ tex cache -> + do f' <- evaluateDeep (toGLInternalFormat f) + x <- evaluateDeep s + let size = GL.TextureSize1D (fromIntegral x) + runFrameBufferInContext cache (x:.1:.()) fb + GL.textureBinding GL.Texture1D $= Just tex + GL.copyTexImage1D 0 f' (GL.Position 0 0) size 0 + GL.textureLevelRange GL.Texture1D $= (0, 0) ++-- | The textures that is instances of this class may be created from a 'FrameBuffer's depth buffer.+-- The texture will have the type of a color format and is sampled as such, but contains depth+-- component information internally. +class Texture t => FromFrameBufferDepth t where + -- | Create a texture of a specific depth format from a 'FrameBuffer' and a size. + fromFrameBufferDepth :: DepthFormat -> TextureSize t -> FrameBuffer c DepthFormat s -> t + +instance DepthColorFormat f => FromFrameBufferDepth (Texture2D f) where + fromFrameBufferDepth f s fb = Texture2D $ unsafePerformIO $ do + newWinMappedTexture $ \ tex cache -> + do f' <- evaluateDeep (toGLInternalFormat f) + x:.y:.() <- evaluateDeep s + let size = GL.TextureSize2D (fromIntegral x) (fromIntegral y) + runFrameBufferInContext cache s fb + GL.textureBinding GL.Texture2D $= Just tex + GL.copyTexImage2D Nothing 0 f' (GL.Position 0 0) size 0 + GL.textureLevelRange GL.Texture2D $= (0, 0) +instance DepthColorFormat f => FromFrameBufferDepth (Texture1D f) where + fromFrameBufferDepth f s fb = Texture1D $ unsafePerformIO $ do + newWinMappedTexture $ \ tex cache -> + do f' <- evaluateDeep (toGLInternalFormat f) + x <- evaluateDeep s + let size = GL.TextureSize1D (fromIntegral x) + runFrameBufferInContext cache (x:.1:.()) fb + GL.textureBinding GL.Texture1D $= Just tex + GL.copyTexImage1D 0 f' (GL.Position 0 0) size 0 + GL.textureLevelRange GL.Texture1D $= (0, 0) ++-- | Create a 'TextureCube' of a specific format and size from the the color buffers of six framebuffers. +fromFrameBufferCubeColor :: ColorFormat c => c -> Vec2 Int -> FrameBuffer c d1 s1 -> FrameBuffer c d2 s2 -> FrameBuffer c d3 s3 -> FrameBuffer c d4 s4 -> FrameBuffer c d5 s5 -> FrameBuffer c d6 s6 -> TextureCube c +-- | Create a 'TextureCube' of a specific depth format and size from the the depth buffers of six framebuffers.+-- The texture will have the type of a color format and is sampled as such, but contains depth+-- component information internally. +fromFrameBufferCubeDepth :: DepthColorFormat d => DepthFormat -> Vec2 Int -> FrameBuffer c1 DepthFormat s1 -> FrameBuffer c2 DepthFormat s2 -> FrameBuffer c3 DepthFormat s3 -> FrameBuffer c4 DepthFormat s4 -> FrameBuffer c5 DepthFormat s5 -> FrameBuffer c6 DepthFormat s6 -> TextureCube d + +fromFrameBufferCubeColor f s b0 b1 b2 b3 b4 b5 = TextureCube $ unsafePerformIO $ do + newWinMappedTexture $ \ tex cache -> + do f' <- evaluateDeep (toGLInternalFormat f) + x:.y:.() <- evaluateDeep s + let size = GL.TextureSize2D (fromIntegral x) (fromIntegral y) + mapM_ (\ (t,io)-> do + io + GL.textureBinding GL.TextureCubeMap $= Just tex + GL.copyTexImage2D (Just t) 0 f' (GL.Position 0 0) size 0) + [(t,io) | t <- cubeMapTargets | io <- [runFrameBufferInContext cache s b0, + runFrameBufferInContext cache s b1, + runFrameBufferInContext cache s b2, + runFrameBufferInContext cache s b3, + runFrameBufferInContext cache s b4, + runFrameBufferInContext cache s b5]] + GL.textureLevelRange GL.TextureCubeMap $= (0, 0) + +fromFrameBufferCubeDepth f s b0 b1 b2 b3 b4 b5 = TextureCube $ unsafePerformIO $ do + newWinMappedTexture $ \ tex cache -> + do f' <- evaluateDeep (toGLInternalFormat f) + x:.y:.() <- evaluateDeep s + let size = GL.TextureSize2D (fromIntegral x) (fromIntegral y) + mapM_ (\ (t,io)-> do + io + GL.textureBinding GL.TextureCubeMap $= Just tex + GL.copyTexImage2D (Just t) 0 f' (GL.Position 0 0) size 0) + [(t,io) | t <- cubeMapTargets | io <- [runFrameBufferInContext cache s b0, + runFrameBufferInContext cache s b1, + runFrameBufferInContext cache s b2, + runFrameBufferInContext cache s b3, + runFrameBufferInContext cache s b4, + runFrameBufferInContext cache s b5]] + GL.textureLevelRange GL.TextureCubeMap $= (0, 0) + +splitIn n xs = unfoldr f xs + where f [] = Nothing + f ys = Just $ splitAt (length xs `div` n) ys