GPipe 1.3 → 1.3.1
raw patch · 17 files changed
+2439/−2450 lines, 17 filesdep +transformersdep −mtldep ~GLUTdep ~OpenGLdep ~Vecsetup-changed
Dependencies added: transformers
Dependencies removed: mtl
Dependency ranges changed: GLUT, OpenGL, Vec, Vec-Boolean, base, containers, list-tries
Files
- GPipe.cabal +30/−42
- Setup.lhs +6/−6
- src/Formats.hs +251/−251
- src/GPUStream.hs +156/−156
- src/Graphics/GPipe.hs +22/−27
- src/Graphics/GPipe/Format.hs +19/−18
- src/Graphics/GPipe/FrameBuffer.hs +28/−28
- src/Graphics/GPipe/Stream.hs +3/−3
- src/Graphics/GPipe/Stream/Fragment.hs +12/−12
- src/Graphics/GPipe/Stream/Primitive.hs +17/−17
- src/Graphics/GPipe/Texture.hs +19/−19
- src/InputAssembler.hs +85/−84
- src/OutputMerger.hs +404/−403
- src/Rasterizer.hs +97/−96
- src/Resources.hs +423/−422
- src/Shader.hs +604/−604
- src/Textures.hs +263/−262
GPipe.cabal view
@@ -1,6 +1,6 @@ name: GPipe-version: 1.3-cabal-version: >= 1.2.3+version: 1.3.1+cabal-version: >= 1.8 build-type: Simple license: BSD3 copyright: Tobias Bexelius@@ -9,7 +9,7 @@ stability: Experimental homepage: http://www.haskell.org/haskellwiki/GPipe package-url: http://hackage.haskell.org/package/GPipe-bug-reports: mailto:tobias_bexelius@hotmail.com+bug-reports: https://github.com/tobbebex/GPipe/issues 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,@@ -17,50 +17,38 @@ 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.- .- Note on installation: If you have cabal installed list-tries with flag containers03 (you should) then use the same flag when installing GPipe. This flag is false by default since it's- false for list-tries as well, and I want Hackage to be able to build it. category: Graphics author: Tobias Bexelius -Flag containers03- Default: False Library- build-depends: containers >= 0.3 && < 0.4, - mtl -any, - list-tries >= 0.4 && < 0.5,- GLUT ==2.2.2.0,- OpenGL ==2.4.0.1,- Boolean == 0.0.1,- Vec == 0.9.7, - Vec-Boolean == 1.0.3,- base >= 3 && < 5+ build-depends: + containers >= 0.4 && <0.5, + list-tries >= 0.4.1 && < 0.5, + GLUT >=2.1.2.1, + OpenGL >=2.2.3.0, + Boolean == 0.0.1, + Vec == 0.9.8, + Vec-Boolean == 1.0.4, + base >= 4 && <5, + transformers - exposed-modules: Graphics.GPipe- Graphics.GPipe.Stream- Graphics.GPipe.Stream.Primitive- Graphics.GPipe.Stream.Fragment- Graphics.GPipe.FrameBuffer- Graphics.GPipe.Texture- Graphics.GPipe.Format- other-modules: Formats - GPUStream - InputAssembler - OutputMerger- Rasterizer - Resources - Shader - Textures- extensions: ParallelListComp- MultiParamTypeClasses- NoMonomorphismRestriction - ScopedTypeVariables - FlexibleContexts- FlexibleInstances - EmptyDataDecls - GeneralizedNewtypeDeriving- TypeFamilies - TypeOperators+ other-modules: + Formats, + GPUStream, + InputAssembler, + OutputMerger, + Rasterizer, + Resources, + Shader, + Textures hs-source-dirs: src+ exposed-modules: + Graphics.GPipe, + Graphics.GPipe.Format, + Graphics.GPipe.FrameBuffer, + Graphics.GPipe.Stream, + Graphics.GPipe.Stream.Fragment, + Graphics.GPipe.Stream.Primitive, + Graphics.GPipe.Texture
Setup.lhs view
@@ -1,6 +1,6 @@-#!/usr/bin/runhaskell -> module Main where -> import Distribution.Simple -> main :: IO () -> main = defaultMain - +#!/usr/bin/runhaskell +> module Main where+> import Distribution.Simple+> main :: IO ()+> main = defaultMain+
src/Formats.hs view
@@ -1,289 +1,289 @@-{-# LANGUAGE UndecidableInstances #-} ------------------------------------------------------------------------------ --- --- 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, zipWith) -import Prelude hiding (zipWith) -import Data.Boolean -import Data.Vec.Boolean - +{-# LANGUAGE UndecidableInstances, TypeFamilies, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}+-----------------------------------------------------------------------------+--+-- 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, zipWith)+import Prelude hiding (zipWith)+import Data.Boolean+import Data.Vec.Boolean+ -- | 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. +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 LuminanceFormat@] 'CPUFormat1Comp' -- -- [@Color LuminanceFormat 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. +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 LuminanceAlphaFormat@] 'CPUFormat2Comp' -- -- [@Color LuminanceAlphaFormat 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. +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 RGBFormat@] 'CPUFormat3Comp' -- -- [@Color RGBFormat 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. +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 RGBAFormat@] 'CPUFormat4Comp' -- -- [@Color RGBAFormat 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. +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 DepthFormat@] 'CPUFormat1Comp'-data DepthFormat = Depth16 | Depth24 | Depth32 deriving (Eq,Ord,Bounded,Enum,Show) --- | A GPU format for a stencil buffer value. +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 StencilFormat@] 'CPUFormat1Comp'-data StencilFormat = StencilFormat deriving (Eq,Ord,Bounded,Enum,Show) +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) +-- | 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) -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 +-- | 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) -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 +-- | 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 - -instance IfB bool a => IfB bool (Color AlphaFormat a) where - ifB c (Alpha t) (Alpha e) = Alpha (ifB c t e) -instance IfB bool a => IfB bool (Color LuminanceFormat a) where - ifB c (Luminance t) (Luminance e) = Luminance (ifB c t e) -instance IfB bool a => IfB bool (Color LuminanceAlphaFormat a) where - ifB c (LuminanceAlpha t1 t2) (LuminanceAlpha e1 e2) = LuminanceAlpha (ifB c t1 e1) (ifB c t2 e2) -instance IfB bool a => IfB bool (Color RGBFormat a) where - ifB c (RGB t) (RGB e) = RGB (ifB c t e) -instance IfB bool a => IfB bool (Color RGBAFormat a) where - ifB c (RGBA t1 t2) (RGBA e1 e2) = RGBA (ifB c t1 e1) (ifB c t2 e2) +-- 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++instance IfB bool a => IfB bool (Color AlphaFormat a) where+ ifB c (Alpha t) (Alpha e) = Alpha (ifB c t e)+instance IfB bool a => IfB bool (Color LuminanceFormat a) where+ ifB c (Luminance t) (Luminance e) = Luminance (ifB c t e)+instance IfB bool a => IfB bool (Color LuminanceAlphaFormat a) where+ ifB c (LuminanceAlpha t1 t2) (LuminanceAlpha e1 e2) = LuminanceAlpha (ifB c t1 e1) (ifB c t2 e2)+instance IfB bool a => IfB bool (Color RGBFormat a) where+ ifB c (RGB t) (RGB e) = RGB (ifB c t e)+instance IfB bool a => IfB bool (Color RGBAFormat a) where+ ifB c (RGBA t1 t2) (RGBA e1 e2) = RGBA (ifB c t1 e1) (ifB c t2 e2)
src/GPUStream.hs view
@@ -1,165 +1,165 @@------------------------------------------------------------------------------ --- --- 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(..), - 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) +-- 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(..),+ 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'). -data PrimitiveStream p a = PrimitiveStreamNoShader PrimitiveStreamDesc a | PrimitiveStreamShader [(PrimitiveStreamDesc, a)] +-- the type of each primitives' vertices' type (built up of atoms of type 'Vertex').+data PrimitiveStream p a = PrimitiveStreamNoShader PrimitiveStreamDesc a | PrimitiveStreamShader [(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 PrimitiveStreamDesc = [(GL.PrimitiveMode, VertexSetup)] -type FragmentStreamDesc = (PrimitiveStreamDesc, CullMode, Vec4 (Vertex Float)) - -instance Functor (PrimitiveStream p) where - fmap f (PrimitiveStreamNoShader [] a) = PrimitiveStreamNoShader [] $ f a - fmap f (PrimitiveStreamNoShader xs a) = PrimitiveStreamShader [(xs, f a)] - fmap f (PrimitiveStreamShader xs) = PrimitiveStreamShader $ map (second f) xs -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 = PrimitiveStreamNoShader [] undefined - PrimitiveStreamNoShader [] _ `mappend` a = a - a `mappend` PrimitiveStreamNoShader [] _ = a - PrimitiveStreamNoShader xs a `mappend` PrimitiveStreamNoShader ys _ = PrimitiveStreamNoShader (xs ++ ys) a -- Optimization! - PrimitiveStreamShader xs `mappend` PrimitiveStreamShader ys = PrimitiveStreamShader $ xs ++ ys - PrimitiveStreamNoShader xs a `mappend` PrimitiveStreamShader ys = PrimitiveStreamShader $ (xs, a):ys - PrimitiveStreamShader xs `mappend` PrimitiveStreamNoShader ys a = PrimitiveStreamShader $ xs ++ [(ys, a)] -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 +-- (built up of atoms of type 'Fragment').+newtype FragmentStream a = FragmentStream [(FragmentStreamDesc, Fragment Bool, a)] -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 - ------------------------------------------ +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 PrimitiveStreamDesc = [(GL.PrimitiveMode, VertexSetup)]+type FragmentStreamDesc = (PrimitiveStreamDesc, CullMode, Vec4 (Vertex Float))++instance Functor (PrimitiveStream p) where+ fmap f (PrimitiveStreamNoShader [] a) = PrimitiveStreamNoShader [] $ f a+ fmap f (PrimitiveStreamNoShader xs a) = PrimitiveStreamShader [(xs, f a)]+ fmap f (PrimitiveStreamShader xs) = PrimitiveStreamShader $ map (second f) xs+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 = PrimitiveStreamNoShader [] undefined+ PrimitiveStreamNoShader [] _ `mappend` a = a+ a `mappend` PrimitiveStreamNoShader [] _ = a+ PrimitiveStreamNoShader xs a `mappend` PrimitiveStreamNoShader ys _ = PrimitiveStreamNoShader (xs ++ ys) a -- Optimization!+ PrimitiveStreamShader xs `mappend` PrimitiveStreamShader ys = PrimitiveStreamShader $ xs ++ ys+ PrimitiveStreamNoShader xs a `mappend` PrimitiveStreamShader ys = PrimitiveStreamShader $ (xs, a):ys+ PrimitiveStreamShader xs `mappend` PrimitiveStreamNoShader ys a = PrimitiveStreamShader $ xs ++ [(ys, a)]+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 +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)) - +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 +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 ((vss, cull, vPos), nd, c) io = drawCall vss cull io $ getShaders vPos nd c Nothing -drawCallColorDepth ((vss, cull, vPos), nd, (c,d)) io = drawCall vss cull io $ getShaders vPos nd c (Just d) - -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 vss cull io ((vkey,vstr,vuns), (fkey,fstr,funs), ins) = do - vss' <- mapM (evalVertexSetups ins) vss - vkey' <- ioEvaluate vkey - fkey' <- ioEvaluate fkey - s <- ioEvaluate (length ins) - vuns' <- ioEvaluate vuns - funs' <- ioEvaluate funs - cull' <- ioEvaluate cull - io - (pr, (vu, fu)) <- createProgramResource vkey' vstr fkey' fstr s - useProgramResource pr - useUniforms vu vuns' - useUniforms fu funs' - liftIO $ useCull cull' - mapM_ (drawVertexSetups ins) vss' - -evalVertexSetups ins (p, VertexSetup v) = do - xs <- ioEvaluate (mapSelect ins v) - vs <- ioEvaluate (length v) - p' <- ioEvaluate p - return (v, xs, p', vs, Nothing) -evalVertexSetups ins (p, IndexedVertexSetup v i) = do - xs <- ioEvaluate (mapSelect ins v) - i' <- ioEvaluate i - vs <- ioEvaluate (length v) - p' <- ioEvaluate p - return (v, xs, p', vs, Just i') - -drawVertexSetups ins (v, xs, p', vs, Nothing) = do - vb <- createVertexBuffer xs ins v - liftIO $ drawVertexBuffer p' vb vs -drawVertexSetups ins (v, xs, p', vs, Just i') = do - ib <- createIndexBuffer i' vs - vb <- createVertexBuffer xs ins v - liftIO $ drawIndexVertexBuffer p' vb ib - -useCull CullNone = cullFace $= Nothing -useCull CullFront = cullFace $= Just Front -useCull CullBack = cullFace $= Just Back +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 ((vss, cull, vPos), nd, c) io = drawCall vss cull io $ getShaders vPos nd c Nothing+drawCallColorDepth ((vss, cull, vPos), nd, (c,d)) io = drawCall vss cull io $ getShaders vPos nd c (Just d)++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 vss cull io ((vkey,vstr,vuns), (fkey,fstr,funs), ins) = do+ vss' <- mapM (evalVertexSetups ins) vss+ vkey' <- ioEvaluate vkey+ fkey' <- ioEvaluate fkey+ s <- ioEvaluate (length ins)+ vuns' <- ioEvaluate vuns+ funs' <- ioEvaluate funs+ cull' <- ioEvaluate cull+ io+ (pr, (vu, fu)) <- createProgramResource vkey' vstr fkey' fstr s+ useProgramResource pr+ useUniforms vu vuns'+ useUniforms fu funs'+ liftIO $ useCull cull'+ mapM_ (drawVertexSetups ins) vss'++evalVertexSetups ins (p, VertexSetup v) = do+ xs <- ioEvaluate (mapSelect ins v)+ vs <- ioEvaluate (length v)+ p' <- ioEvaluate p+ return (v, xs, p', vs, Nothing)+evalVertexSetups ins (p, IndexedVertexSetup v i) = do+ xs <- ioEvaluate (mapSelect ins v)+ i' <- ioEvaluate i+ vs <- ioEvaluate (length v)+ p' <- ioEvaluate p+ return (v, xs, p', vs, Just i')+ +drawVertexSetups ins (v, xs, p', vs, Nothing) = do+ vb <- createVertexBuffer xs ins v+ liftIO $ drawVertexBuffer p' vb vs+drawVertexSetups ins (v, xs, p', vs, Just i') = do+ ib <- createIndexBuffer i' vs+ vb <- createVertexBuffer xs ins v+ liftIO $ drawIndexVertexBuffer p' vb ib++useCull CullNone = cullFace $= Nothing+useCull CullFront = cullFace $= Just Front+useCull CullBack = cullFace $= Just Back
src/Graphics/GPipe.hs view
@@ -1,13 +1,13 @@------------------------------------------------------------------------------ --- --- Module : GPipe --- Copyright : Tobias Bexelius --- License : BSD3 --- --- Maintainer : Tobias Bexelius --- Stability : Experimental --- Portability : Portable --- +-----------------------------------------------------------------------------+--+-- 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,@@ -16,21 +16,16 @@ -- -- 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. ------------------------------------------------------------------------------ - +-- 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 + module X+) where++import Graphics.GPipe.Stream as X+import Graphics.GPipe.Stream.Primitive as X+import Graphics.GPipe.Stream.Fragment as X+import Graphics.GPipe.FrameBuffer as X+import Graphics.GPipe.Texture as X+import Graphics.GPipe.Format as X
src/Graphics/GPipe/Format.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- -- Module : Graphics.GPipe.Format@@ -14,26 +15,26 @@ module Graphics.GPipe.Format ( -- * GPU formats- AlphaFormat(..), - LuminanceFormat(..), - LuminanceAlphaFormat(..), - RGBFormat(..), - RGBAFormat(..), - DepthFormat(..), - StencilFormat(..), - GPUFormat(type CPUFormat), - ColorFormat(), - Color(..), - Depth, - Stencil, + AlphaFormat(..),+ LuminanceFormat(..),+ LuminanceAlphaFormat(..),+ RGBFormat(..),+ RGBAFormat(..),+ DepthFormat(..),+ StencilFormat(..),+ GPUFormat(type CPUFormat),+ ColorFormat(),+ Color(..),+ Depth,+ Stencil, -- * CPU formats- CPUFormat4Comp(..), - CPUFormat3Comp(..), - CPUFormat2Comp(..), - CPUFormat1Comp(..), + CPUFormat4Comp(..),+ CPUFormat3Comp(..),+ CPUFormat2Comp(..),+ CPUFormat1Comp(..), StorableCPUFormat(), ) where- -import Formats ++import Formats
src/Graphics/GPipe/FrameBuffer.hs view
@@ -17,25 +17,25 @@ module Graphics.GPipe.FrameBuffer ( -- * The data type- FrameBuffer(), + FrameBuffer(), -- * Displaying framebuffers newWindow,- -- * Creation + -- * Creation -- | These functions create new 'FrameBuffer's with initial color, depth values and\/or stencil values.- newFrameBufferColor, - newFrameBufferColorDepth, - newFrameBufferColorStencil, - newFrameBufferColorDepthStencil, - newFrameBufferDepth, - newFrameBufferStencil, - newFrameBufferDepthStencil, + 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, + 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@@ -48,25 +48,25 @@ -- -- 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, + paintColor,+ paintDepth,+ paintColorDepth,+ paintStencil,+ paintDepthStencil,+ paintColorStencil,+ paintColorDepthStencil,+ paintRastDepth,+ paintColorRastDepth,+ paintRastDepthStencil,+ paintColorRastDepthStencil, ColorMask, Blending(..), BlendEquation(..), BlendingFactor(..), LogicOp(..), ComparisonFunction(..), DepthFunction, DepthMask,- StencilOps(..), StencilOp(..), StencilTest(..), StencilTests(..), - FragmentDepth, + StencilOps(..), StencilOp(..), StencilTest(..), StencilTests(..),+ FragmentDepth, ) where -import OutputMerger - +import OutputMerger+
src/Graphics/GPipe/Stream.hs view
@@ -24,12 +24,12 @@ Convert(..), -- * Reexports (:.)(..),Vec2,Vec3,Vec4,- module Data.Vec.LinAlg, - module Data.Boolean + module Data.Vec.LinAlg, + module Data.Boolean ) where import Shader-import Data.Boolean +import Data.Boolean import Data.Vec import Data.Vec.LinAlg import Data.Vec.Boolean()
src/Graphics/GPipe/Stream/Fragment.hs view
@@ -35,28 +35,28 @@ module Graphics.GPipe.Stream.Fragment ( -- * Data types- FragmentStream(), - Fragment(), + FragmentStream(),+ Fragment(), -- * Various fragment functions dFdx, dFdy, fwidth,- filterFragments, + filterFragments, -- * Creating fragment streams- VertexOutput(..), - Rasterizer(), + 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). - rasterizeFront, - rasterizeBack, - rasterizeFrontAndBack, + -- must duplicate these positions into the vertices interpolated values if you need them in the fragments (which is very unusual).+ rasterizeFront,+ rasterizeBack,+ rasterizeFrontAndBack, ) where -import Shader -import GPUStream -import Rasterizer +import Shader+import GPUStream+import Rasterizer
src/Graphics/GPipe/Stream/Primitive.hs view
@@ -34,27 +34,27 @@ module Graphics.GPipe.Stream.Primitive ( -- * Data types- PrimitiveStream(), - Vertex(), + PrimitiveStream(),+ Vertex(), -- * Creating primitive streams- VertexInput(..), - InputAssembler(), - Triangle(..), - Line(..), - Point(..), - Primitive(), - toGPUStream, - toIndexedGPUStream, + VertexInput(..),+ InputAssembler(),+ Triangle(..),+ Line(..),+ Point(..),+ Primitive(),+ toGPUStream,+ toIndexedGPUStream, ) where - -import Shader -import GPUStream -import InputAssembler - - - ++import Shader+import GPUStream+import InputAssembler+++
src/Graphics/GPipe/Texture.hs view
@@ -20,27 +20,27 @@ module Graphics.GPipe.Texture ( -- * Data types- Texture3D(), - Texture2D(), - Texture1D(), - TextureCube(), + Texture3D(),+ Texture2D(),+ Texture1D(),+ TextureCube(), -- * Operation- Texture(..), - -- * Creation - newTexture, - newDepthTexture, - FromFrameBufferColor(..), - FromFrameBufferDepth(..), - DepthColorFormat(), - fromFrameBufferCubeColor, + Texture(..),+ -- * Creation+ newTexture,+ newDepthTexture,+ FromFrameBufferColor(..),+ FromFrameBufferDepth(..),+ DepthColorFormat(),+ fromFrameBufferCubeColor, fromFrameBufferCubeDepth,- -- * Samplers - Sampler(..), - Filter(..), - EdgeMode(..), + -- * Samplers+ Sampler(..),+ Filter(..),+ EdgeMode(..), ) where -import Resources -import Textures - +import Resources+import Textures+
src/InputAssembler.hs view
@@ -1,103 +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 - +{-# LANGUAGE RankNTypes, TypeOperators, FlexibleInstances, GeneralizedNewtypeDeriving, ScopedTypeVariables #-} +-----------------------------------------------------------------------------+--+-- Module : InputAssembler+-- Copyright : Tobias Bexelius+-- License : BSD3+--+-- Maintainer : Tobias Bexelius+-- Stability : Experimental+-- Portability : Portable+--+-- |+--+-----------------------------------------------------------------------------++module InputAssembler (+ InputAssembler(),+ VertexInput(..),+ toGPUStream,+ toIndexedGPUStream,+) where++import Control.Monad.Trans.State.Lazy +import GPUStream+import Shader+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 +-- 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. The following rule must be satisfied:- -- - -- > toVertex undefined >> a = a - -- + -- + -- > toVertex undefined >> a = a+ -- -- This ensures that its definition 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 $ inputVertex 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 + -- 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 $ inputVertex 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 + 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. +-- 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 _ [] = PrimitiveStreamNoShader [] undefined -toGPUStream p xs = let (a, fs) = getVertexInput xs - in PrimitiveStreamNoShader [(getPrimitiveMode p, VertexSetup fs)] a - + -> PrimitiveStream p a -- ^ The resulting 'PrimitiveStream'.+toGPUStream _ [] = PrimitiveStreamNoShader [] undefined+toGPUStream p xs = let (a, fs) = getVertexInput xs+ in PrimitiveStreamNoShader [(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. +-- 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 _ [] _ = PrimitiveStreamNoShader [] undefined -toIndexedGPUStream p xs i = let (a, fs) = getVertexInput xs - in PrimitiveStreamNoShader [(getPrimitiveMode p, IndexedVertexSetup fs i)] a - - --------------------------------------- --- Private --- - -getVertexInput :: forall a. VertexInput a => [CPU a] -> (a, [[Float]]) -getVertexInput xs = let readInput :: CPU a -> (a, [Float]) - readInput = flip runState [] . fromInputAssembler . toVertex - e = "The method toVertex of an instance of Graphics.GPipe.Stream.Primitive.VertexInput is strict in it's input. Remember that 'toVertex undefined >> a' must be equal to 'a'. Contact the GPipe author for more information." - in (fst $ readInput (error e :: CPU a), map (reverse . snd . readInput) xs) + -> PrimitiveStream p a -- ^ The resulting 'PrimitiveStream'.+toIndexedGPUStream _ [] _ = PrimitiveStreamNoShader [] undefined+toIndexedGPUStream p xs i = let (a, fs) = getVertexInput xs+ in PrimitiveStreamNoShader [(getPrimitiveMode p, IndexedVertexSetup fs i)] a+++--------------------------------------+-- Private+--++getVertexInput :: forall a. VertexInput a => [CPU a] -> (a, [[Float]])+getVertexInput xs = let readInput :: CPU a -> (a, [Float])+ readInput = flip runState [] . fromInputAssembler . toVertex+ e = "The method toVertex of an instance of Graphics.GPipe.Stream.Primitive.VertexInput is strict in it's input. Remember that 'toVertex undefined >> a' must be equal to 'a'. Contact the GPipe author for more information."+ in (fst $ readInput (error e :: CPU a), map (reverse . snd . readInput) xs)
src/OutputMerger.hs view
@@ -1,68 +1,69 @@------------------------------------------------------------------------------ --- --- Module : OutputMerger --- Copyright : Tobias Bexelius --- License : BSD3 --- --- Maintainer : Tobias Bexelius --- Stability : Experimental --- Portability : Portable --- +{-# LANGUAGE RankNTypes, ScopedTypeVariables #-} +-----------------------------------------------------------------------------+--+-- Module : OutputMerger+-- Copyright : Tobias Bexelius+-- License : BSD3+--+-- Maintainer : Tobias Bexelius+-- Stability : Experimental+-- Portability : Portable+-- -- |- ------------------------------------------------------------------------------ - -module OutputMerger ( - FragmentDepth, ++-----------------------------------------------------------------------------++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 + 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 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 +import Control.Monad (liftM)+import Data.Maybe (fromJust)+import Control.Exception (evaluate)+import Control.Monad.Trans.Reader (runReaderT) ++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'.@@ -70,7 +71,7 @@ -- | 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. +-- | 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))@@ -78,380 +79,380 @@ -- 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) + deriving (Eq,Ord,Show) --- | Sets the operations that should be performed on the 'FrameBuffer's stencil value -data StencilOps = StencilOps { +-- | 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) + 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) - +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':.()) - -setDefaultStates :: IO () -setDefaultStates = do frontFace $= CCW - depthRange $= (0,1) - - -newFrameBufferColor c = FrameBuffer $ do - c' <- ioEvaluateColor 0 1 c - setContextWindow - liftIO $ do setDefaultStates - setNewColor c' - clear [GL.ColorBuffer] -newFrameBufferColorDepth c d = FrameBuffer $ do - c' <- ioEvaluateColor 0 1 c - d' <- ioEvaluate d - setContextWindow - liftIO $ do setDefaultStates - 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 setDefaultStates - 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 setDefaultStates - setNewColor c' - setNewStencil s' - clear [GL.ColorBuffer, GL.StencilBuffer] -newFrameBufferDepth d = FrameBuffer $ do - d' <- ioEvaluate d - setContextWindow - liftIO $ do setDefaultStates - setNewDepth d' - clear [GL.DepthBuffer] -newFrameBufferDepthStencil d s = FrameBuffer $ do - d' <- ioEvaluate d - s' <- ioEvaluate s - setContextWindow - liftIO $ do setDefaultStates - setNewDepth d' - setNewStencil s' - clear [GL.DepthBuffer, GL.StencilBuffer] - -newFrameBufferStencil s = FrameBuffer $ do - s' <- ioEvaluate s - setContextWindow - liftIO $ do setDefaultStates - 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 - ------------------------------------------------------------------- +-- marks the inexistance. +data FrameBuffer c d s = FrameBuffer (ContextCacheIO ()) -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' - +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':.())++setDefaultStates :: IO ()+setDefaultStates = do frontFace $= CCW+ depthRange $= (0,1)+ ++newFrameBufferColor c = FrameBuffer $ do+ c' <- ioEvaluateColor 0 1 c+ setContextWindow+ liftIO $ do setDefaultStates+ setNewColor c'+ clear [GL.ColorBuffer]+newFrameBufferColorDepth c d = FrameBuffer $ do+ c' <- ioEvaluateColor 0 1 c+ d' <- ioEvaluate d+ setContextWindow+ liftIO $ do setDefaultStates+ 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 setDefaultStates+ 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 setDefaultStates+ setNewColor c'+ setNewStencil s'+ clear [GL.ColorBuffer, GL.StencilBuffer]+newFrameBufferDepth d = FrameBuffer $ do+ d' <- ioEvaluate d+ setContextWindow+ liftIO $ do setDefaultStates+ setNewDepth d'+ clear [GL.DepthBuffer]+newFrameBufferDepthStencil d s = FrameBuffer $ do+ d' <- ioEvaluate d+ s' <- ioEvaluate s+ setContextWindow+ liftIO $ do setDefaultStates+ setNewDepth d'+ setNewStencil s'+ clear [GL.DepthBuffer, GL.StencilBuffer]++newFrameBufferStencil s = FrameBuffer $ do+ s' <- ioEvaluate s+ setContextWindow+ liftIO $ do setDefaultStates+ 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'. +-- 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 + -> 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. +-- | 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. + -> 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. + -> 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'. + -> 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 -> (Vec2 Int -> IO (FrameBuffer c d s)) -- ^ This function is evaluated every time the window needs to be redrawn, and the resulting 'FrameBuffer' will be drawn in the window. The parameter is the current size of 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 cache <- liftM fromJust $ getContextCache w --We need to do this to get the correct size - let Size x y = contextViewPort cache - FrameBuffer io <- f (fromIntegral x :. fromIntegral y :. ()) - 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 + -> 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 cache <- liftM fromJust $ getContextCache w --We need to do this to get the correct size+ let Size x y = contextViewPort cache+ FrameBuffer io <- f (fromIntegral x :. fromIntegral y :. ())+ 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) - - + 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
@@ -1,108 +1,109 @@------------------------------------------------------------------------------ --- --- Module : Rasterizer --- Copyright : Tobias Bexelius --- License : BSD3 --- --- Maintainer : Tobias Bexelius --- Stability : Experimental --- Portability : Portable --- --- | --- ------------------------------------------------------------------------------ - -module Rasterizer ( - Rasterizer(), - VertexOutput(..), - rasterizeFront, - rasterizeBack, - rasterizeFrontAndBack, -) where - -import Shader -import Data.Vec ((:.)(..), Vec2, Vec3, Vec4) -import GPUStream -import Control.Monad.Identity - --- | 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 :: Identity a} deriving (Functor, Monad) +{-# LANGUAGE TypeOperators, TypeFamilies, FlexibleInstances, GeneralizedNewtypeDeriving #-} +-----------------------------------------------------------------------------+--+-- Module : Rasterizer+-- Copyright : Tobias Bexelius+-- License : BSD3+--+-- Maintainer : Tobias Bexelius+-- Stability : Experimental+-- Portability : Portable+--+-- |+--+----------------------------------------------------------------------------- +module Rasterizer (+ Rasterizer(),+ VertexOutput(..),+ rasterizeFront,+ rasterizeBack,+ rasterizeFrontAndBack,+) where++import Shader+import Data.Vec ((:.)(..), Vec2, Vec3, Vec4)+import GPUStream+import Data.Functor.Identity++-- | 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 :: Identity a} deriving (Functor, 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 +-- 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. - toFragment :: a -> Rasterizer (FragmentInput a) - -instance VertexOutput (Vertex Float) where - type FragmentInput (Vertex Float) = Fragment Float - toFragment = Rasterizer . return . rasterizeVertex - -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') + -- | Turns a vertex value into a fragment value in the 'Rasterizer' monad. + toFragment :: a -> Rasterizer (FragmentInput a) +instance VertexOutput (Vertex Float) where+ type FragmentInput (Vertex Float) = Fragment Float+ toFragment = Rasterizer . return . rasterizeVertex++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 front side of all types of primitives with vertices containing canonical view coordinates into fragments. + type FragmentInput (a:.b) = FragmentInput a :. FragmentInput b+ toFragment (a:.b) = do a' <- toFragment a+ b' <- toFragment b+ return $ a':.b'++-- | Rasterize front side of all types of primitives with vertices containing canonical view coordinates into fragments. rasterizeFront :: 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. -rasterizeFront x = case x of - (PrimitiveStreamShader xs) -> FragmentStream $ map rasterizeOne xs - (PrimitiveStreamNoShader [] _) -> FragmentStream [] - (PrimitiveStreamNoShader xs a) -> FragmentStream [rasterizeOne (xs, a)] - where rasterizeOne (pdesc, (pos, va)) = ((pdesc, CullBack, pos), true, getFragmentInput va) - --- | Rasterize both sides of triangles with vertices containing canonical view coordinates into fragments, also returning the primitives side in the fragments. + -> FragmentStream (FragmentInput a) -- ^ The resulting fragment stream with fragments containing the interpolated values.+rasterizeFront x = case x of+ (PrimitiveStreamShader xs) -> FragmentStream $ map rasterizeOne xs+ (PrimitiveStreamNoShader [] _) -> FragmentStream []+ (PrimitiveStreamNoShader xs a) -> FragmentStream [rasterizeOne (xs, a)]+ where rasterizeOne (pdesc, (pos, va)) = ((pdesc, CullBack, pos), true, 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 x = case x of - (PrimitiveStreamShader xs) -> FragmentStream $ map rasterizeOne xs - (PrimitiveStreamNoShader [] _) -> FragmentStream [] - (PrimitiveStreamNoShader xs a) -> FragmentStream [rasterizeOne (xs, a)] - where rasterizeOne (pdesc, (pos, va)) = ((pdesc, CullNone, pos), true, (fragmentFrontFacing, getFragmentInput va)) - --- | Rasterize back side of triangles with vertices containing canonical view coordinates into fragments. + -> 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 x = case x of + (PrimitiveStreamShader xs) -> FragmentStream $ map rasterizeOne xs+ (PrimitiveStreamNoShader [] _) -> FragmentStream []+ (PrimitiveStreamNoShader xs a) -> FragmentStream [rasterizeOne (xs, a)]+ where rasterizeOne (pdesc, (pos, va)) = ((pdesc, CullNone, pos), true, (fragmentFrontFacing, getFragmentInput va))++-- | Rasterize 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 x = case x of - (PrimitiveStreamShader xs) -> FragmentStream $ map rasterizeOne xs - (PrimitiveStreamNoShader [] _) -> FragmentStream [] - (PrimitiveStreamNoShader xs a) -> FragmentStream [rasterizeOne (xs, a)] - where rasterizeOne (pdesc, (pos, va)) = ((pdesc, CullFront, pos), true, getFragmentInput va) - --------------------------------------- --- Private --- - -getFragmentInput :: VertexOutput a => a -> FragmentInput a -getFragmentInput = runIdentity . fromRasterizer . toFragment + -> FragmentStream (FragmentInput a) -- ^ The resulting fragment stream with fragments containing the interpolated values.+rasterizeBack x = case x of+ (PrimitiveStreamShader xs) -> FragmentStream $ map rasterizeOne xs+ (PrimitiveStreamNoShader [] _) -> FragmentStream []+ (PrimitiveStreamNoShader xs a) -> FragmentStream [rasterizeOne (xs, a)]+ where rasterizeOne (pdesc, (pos, va)) = ((pdesc, CullFront, pos), true, getFragmentInput va)++--------------------------------------+-- Private+--++getFragmentInput :: VertexOutput a => a -> FragmentInput a+getFragmentInput = runIdentity . fromRasterizer . toFragment
src/Resources.hs view
@@ -1,66 +1,65 @@------------------------------------------------------------------------------ --- --- 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, - UniformSet, - ContextCacheIO, - ContextCache(contextWindow,contextViewPort), - newContextCache, - setContextWindow, - liftIO, - hiddenWindowContextCache, - WinMappedTexture, - newWinMappedTexture, - bindWinMappedTexture, - Sampler(..), - Filter(..), - EdgeMode(..), - SamplerType(..), - cubeMapTargets, - getContextCache, - saveContextCache, - changeContextSize, - getCurrentOrSetHiddenContext, - ioEvaluate, - evaluateDeep, - evaluatePtr, - ShaderInfo, - ShaderKey, - ShaderKeyNode(..), - Op, - Const(..), - Uniform(..) -) where - -import Graphics.Rendering.OpenGL hiding (Sampler3D, Sampler2D, Sampler1D, SamplerCube, Point, Linear, Clamp, Uniform) -import qualified Data.HashTable as HT -import qualified Graphics.UI.GLUT as GLUT -import Data.Map (Map) -import qualified Data.Map as Map +-----------------------------------------------------------------------------+--+-- 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,+ UniformSet,+ ContextCacheIO,+ ContextCache(contextWindow,contextViewPort),+ newContextCache,+ setContextWindow,+ liftIO,+ hiddenWindowContextCache,+ WinMappedTexture,+ newWinMappedTexture,+ bindWinMappedTexture,+ Sampler(..),+ Filter(..),+ EdgeMode(..),+ SamplerType(..),+ cubeMapTargets,+ getContextCache,+ saveContextCache,+ changeContextSize,+ getCurrentOrSetHiddenContext,+ ioEvaluate,+ evaluateDeep,+ evaluatePtr,+ ShaderInfo,+ ShaderKey,+ ShaderKeyNode(..),+ Op,+ Const(..),+ Uniform(..)+) where++import Graphics.Rendering.OpenGL hiding (Sampler3D, Sampler2D, Sampler1D, SamplerCube, Point, Linear, Clamp, Uniform)+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 import Data.Bits-import Control.Monad.Reader import Control.Monad import Foreign.C.Types import Foreign.Storable@@ -73,149 +72,151 @@ import Control.Exception (evaluate) import Foreign.ForeignPtr import System.Mem.Weak (addFinalizer)-import Data.Unique -import Data.ListTrie.Patricia.Map (TrieMap) -import qualified Data.ListTrie.Patricia.Map as TrieMap -import Data.ListTrie.Base.Map (WrappedIntMap) - -data VertexBuffer = VertexBuffer BufferObject Int -data IndexBuffer = IndexBuffer BufferObject Int DataType -type UniformLocationSet = (UniformLocation,UniformLocation,UniformLocation, Map SamplerType UniformLocation) - -data SamplerType = Sampler3D | Sampler2D | Sampler1D | SamplerCube deriving (Eq, Ord, Enum, Bounded) -type UniformSet = ([Float],[Int],[Bool],Map SamplerType [(Sampler, WinMappedTexture)]) - -type ShaderInfo = (ShaderKey, String, UniformSet) -type ShaderKey = ([Int], [(ShaderKeyNode, [Int])]) -data ShaderKeyNode = ShaderKeyUniform - | ShaderKeyConstant !Const - | ShaderKeyInput !Int - | ShaderKeyOp !Op - deriving (Eq, Ord) -type Op = String -data Const = ConstFloat Float - | ConstInt Int - | ConstBool Bool - deriving (Eq, Ord) -data Uniform = UniformFloat Float - | UniformInt Int - | UniformBool Bool - | UniformSampler SamplerType Sampler WinMappedTexture - --- | 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 ProgramCacheValue = (Program, (UniformLocationSet,UniformLocationSet)) -type ProgramCacheMap = TrieMap Map (ShaderKeyNode, [Int]) (TrieMap Map (ShaderKeyNode, [Int]) (TrieMap WrappedIntMap Int (TrieMap WrappedIntMap Int ProgramCacheValue))) -type ProgramCache = IORef ProgramCacheMap -- (Map (ShaderKey, ShaderKey) (Program, (UniformLocationSet,UniformLocationSet))) -pCacheLookup :: ShaderKey -> ShaderKey -> ProgramCacheMap -> Maybe ProgramCacheValue -pCacheLookup (k3, k1) (k4, k2) m1 = TrieMap.lookup k1 m1 >>= TrieMap.lookup k2 >>= TrieMap.lookup k3 >>= TrieMap.lookup k4 -pCacheInsert :: ShaderKey -> ShaderKey -> ProgramCacheValue -> ProgramCacheMap -> ProgramCacheMap -pCacheInsert (k3, k1) (k4, k2) v m1 = TrieMap.alter' ins2 k1 m1 - where ins2 Nothing = Just $ TrieMap.singleton k2 $ TrieMap.singleton k3 $ TrieMap.singleton k4 v - ins2 (Just m2) = Just $ TrieMap.alter' ins3 k2 m2 - ins3 Nothing = Just $ TrieMap.singleton k3 $ TrieMap.singleton k4 v - ins3 (Just m3) = Just $ TrieMap.alter' ins4 k3 m3 - ins4 Nothing = Just $ TrieMap.singleton k4 v - ins4 (Just m4) = Just $ TrieMap.insert k4 v m4 - -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 <- newIORef TrieMap.empty - 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 +import Data.Unique+import Data.ListTrie.Patricia.Map (TrieMap)+import qualified Data.ListTrie.Patricia.Map as TrieMap+import Data.ListTrie.Base.Map (WrappedIntMap)+import Control.Monad.Trans.Reader +import Control.Monad.IO.Class -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 :: ShaderKey -> String -> ShaderKey -> String -> Int -> ContextCacheIO (Program, (UniformLocationSet,UniformLocationSet)) -createProgramResource vkey vstr fkey fstr s = do - cache <- asks programCache - m <- liftIO $ readIORef cache - case pCacheLookup vkey fkey m 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 ("v" ++ 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 "vuf" - ivu <- get $ uniformLocation p "vui" - bvu <- get $ uniformLocation p "vub" - svus' <- mapM (\ s -> get $ uniformLocation p $ "vus" ++ show (fromEnum s)) allSamplers - let svus = Map.fromAscList $ zip allSamplers svus' - ffu <- get $ uniformLocation p "fuf" - ifu <- get $ uniformLocation p "fui" - bfu <- get $ uniformLocation p "fub" - sfus' <- mapM (\ s -> get $ uniformLocation p $ "fus" ++ show (fromEnum s)) allSamplers - let sfus = Map.fromAscList $ zip allSamplers sfus' - let p' = (p, ((fvu,ivu,bvu,svus),(ffu,ifu,bfu,sfus))) - atomicModifyIORef cache (flip (,) () . pCacheInsert vkey fkey p') - return p' - -createVertexBuffer :: [[Float]] -> [Int] -> [[Float]] -> ContextCacheIO VertexBuffer +data VertexBuffer = VertexBuffer BufferObject Int+data IndexBuffer = IndexBuffer BufferObject Int DataType+type UniformLocationSet = (UniformLocation,UniformLocation,UniformLocation, Map SamplerType UniformLocation)++data SamplerType = Sampler3D | Sampler2D | Sampler1D | SamplerCube deriving (Eq, Ord, Enum, Bounded)+type UniformSet = ([Float],[Int],[Bool],Map SamplerType [(Sampler, WinMappedTexture)])++type ShaderInfo = (ShaderKey, String, UniformSet)+type ShaderKey = ([Int], [(ShaderKeyNode, [Int])])+data ShaderKeyNode = ShaderKeyUniform + | ShaderKeyConstant !Const+ | ShaderKeyInput !Int+ | ShaderKeyOp !Op+ deriving (Eq, Ord)+type Op = String+data Const = ConstFloat Float+ | ConstInt Int+ | ConstBool Bool+ deriving (Eq, Ord)+data Uniform = UniformFloat Float+ | UniformInt Int+ | UniformBool Bool+ | UniformSampler SamplerType Sampler WinMappedTexture+ +-- | 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 ProgramCacheValue = (Program, (UniformLocationSet,UniformLocationSet))+type ProgramCacheMap = TrieMap Map (ShaderKeyNode, [Int]) (TrieMap Map (ShaderKeyNode, [Int]) (TrieMap WrappedIntMap Int (TrieMap WrappedIntMap Int ProgramCacheValue)))+type ProgramCache = IORef ProgramCacheMap -- (Map (ShaderKey, ShaderKey) (Program, (UniformLocationSet,UniformLocationSet)))+pCacheLookup :: ShaderKey -> ShaderKey -> ProgramCacheMap -> Maybe ProgramCacheValue+pCacheLookup (k3, k1) (k4, k2) m1 = TrieMap.lookup k1 m1 >>= TrieMap.lookup k2 >>= TrieMap.lookup k3 >>= TrieMap.lookup k4+pCacheInsert :: ShaderKey -> ShaderKey -> ProgramCacheValue -> ProgramCacheMap -> ProgramCacheMap +pCacheInsert (k3, k1) (k4, k2) v = TrieMap.alter' ins2 k1+ where ins2 Nothing = Just $ TrieMap.singleton k2 $ TrieMap.singleton k3 $ TrieMap.singleton k4 v+ ins2 (Just m2) = Just $ TrieMap.alter' ins3 k2 m2+ ins3 Nothing = Just $ TrieMap.singleton k3 $ TrieMap.singleton k4 v+ ins3 (Just m3) = Just $ TrieMap.alter' ins4 k3 m3+ ins4 Nothing = Just $ TrieMap.singleton k4 v+ ins4 (Just m4) = Just $ TrieMap.insert k4 v m4+ +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 <- newIORef TrieMap.empty+ 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 :: ShaderKey -> String -> ShaderKey -> String -> Int -> ContextCacheIO (Program, (UniformLocationSet,UniformLocationSet))+createProgramResource vkey vstr fkey fstr s = do+ cache <- asks programCache+ m <- liftIO $ readIORef cache+ case pCacheLookup vkey fkey m 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 ('v' : 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 "vuf"+ ivu <- get $ uniformLocation p "vui"+ bvu <- get $ uniformLocation p "vub"+ svus' <- mapM (\ s -> get $ uniformLocation p $ "vus" ++ show (fromEnum s)) allSamplers+ let svus = Map.fromAscList $ zip allSamplers svus'+ ffu <- get $ uniformLocation p "fuf"+ ifu <- get $ uniformLocation p "fui"+ bfu <- get $ uniformLocation p "fub"+ sfus' <- mapM (\ s -> get $ uniformLocation p $ "fus" ++ show (fromEnum s)) allSamplers+ let sfus = Map.fromAscList $ zip allSamplers sfus'+ let p' = (p, ((fvu,ivu,bvu,svus),(ffu,ifu,bfu,sfus)))+ atomicModifyIORef cache (flip (,) () . pCacheInsert vkey fkey 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 + 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) + 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@@ -223,153 +224,153 @@ 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 + 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 + 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 + 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' + 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) $ Map.toList 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] - return $ TexCoord1 (fromIntegral i::GLint) - 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 evaluate (a==a) - return a + return i -ioEvaluate :: Eq a => a -> ContextCacheIO a -ioEvaluate = liftIO . evaluateDeep - -evaluatePtr p = do a <- peek (castPtr p :: Ptr CUChar) - evaluate (a==a) - return p - ----------------------------------------------------- --- Texture operations - - -type WinMappedTexture = IORef (Map GLUT.Window TextureObject) +useProgramResource :: Program -> ContextCacheIO ()+useProgramResource p = liftIO $ currentProgram $= Just p -newWinMappedTexture :: (TextureObject -> ContextCache -> IO a) -> IO WinMappedTexture -newWinMappedTexture ionew = do - cache <- getCurrentOrSetHiddenContext - [tex] <- genObjectNames 1 - -- putStrLn $ "Created texture " ++ show tex - swapBytes Unpack $= False - lsbFirst Unpack $= False - rowLength Unpack $= 0 - skipRows Unpack $= 0 - skipPixels Unpack $= 0 - rowAlignment Unpack $= 1 -- Set to no padding - imageHeight Unpack $= 0 - skipImages Unpack $= 0 +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) $ Map.toList 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]+ return $ TexCoord1 (fromIntegral i::GLint)+ 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 evaluate (a==a)+ return a++ioEvaluate :: Eq a => a -> ContextCacheIO a+ioEvaluate = liftIO . evaluateDeep++evaluatePtr p = do a <- peek (castPtr p :: Ptr CUChar)+ evaluate (a==a)+ return p++----------------------------------------------------+-- 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+ swapBytes Unpack $= False+ lsbFirst Unpack $= False+ rowLength Unpack $= 0+ skipRows Unpack $= 0+ skipPixels Unpack $= 0+ rowAlignment Unpack $= 1 -- Set to no padding+ imageHeight Unpack $= 0+ skipImages Unpack $= 0 ionew tex cache ref <- newIORef $ Map.singleton (contextWindow cache) tex mkWeakIORef ref $ do m <- readIORef ref@@ -381,90 +382,90 @@ 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 - swapBytes Unpack $= False - lsbFirst Unpack $= False - rowLength Unpack $= 0 - skipRows Unpack $= 0 - skipPixels Unpack $= 0 - rowAlignment Unpack $= 1 -- Set to no padding - imageHeight Unpack $= 0 - skipImages Unpack $= 0 - swapBytes Pack $= False - lsbFirst Pack $= False - rowLength Pack $= 0 - skipRows Pack $= 0 - skipPixels Pack $= 0 - rowAlignment Pack $= 1 -- Set to no padding - imageHeight Pack $= 0 - skipImages Pack $= 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] + +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+ swapBytes Unpack $= False+ lsbFirst Unpack $= False+ rowLength Unpack $= 0+ skipRows Unpack $= 0+ skipPixels Unpack $= 0+ rowAlignment Unpack $= 1 -- Set to no padding+ imageHeight Unpack $= 0+ skipImages Unpack $= 0+ swapBytes Pack $= False+ lsbFirst Pack $= False+ rowLength Pack $= 0+ skipRows Pack $= 0+ skipPixels Pack $= 0+ rowAlignment Pack $= 1 -- Set to no padding+ imageHeight Pack $= 0+ skipImages Pack $= 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
@@ -1,604 +1,604 @@------------------------------------------------------------------------------ --- --- Module : Shader --- Copyright : Tobias Bexelius --- License : BSD3 --- --- Maintainer : Tobias Bexelius --- Stability : Experimental --- Portability : Portable --- --- | --- ------------------------------------------------------------------------------ - -module Shader ( - GPU(..), - rasterizeVertex, - inputVertex, - fragmentFrontFacing, - Vertex(), - Fragment(), - ShaderInfo, - getShaders, - Real'(..), - Convert(..), - dFdx, - dFdy, - fwidth, - vSampleBinFunc, - fSampleBinFunc, - vSampleTernFunc, - fSampleTernFunc, - 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.Maybe -import Data.Boolean -import Control.Monad.State -import Data.Map (Map) -import qualified Data.Map as Map hiding (Map) -import qualified Data.HashTable as HT -import Control.Exception (evaluate)-import System.Mem.StableName-import Data.IntSet (IntSet) -import qualified Data.IntSet as IntSet hiding (IntSet) -import Control.Arrow (first, second) -import Resources -import Formats - -infixl 7 `mod'` - --- | 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.-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 - -data ShaderTree = ShaderUniform !Uniform - | ShaderConstant !Const - | ShaderInput !Int - | ShaderInputTree ShaderTree - | ShaderOp !Op (String -> [String] -> String) [ShaderTree] -type ShaderDAG = ([Int],[(ShaderTree, [Int])]) - --- | An opaque type constructor for atomic values in a vertex on the GPU, e.g. 'Vertex' 'Float'.-newtype Vertex a = Vertex { fromVertex :: ShaderTree } --- | An opaque type constructor for atomic values in a fragment on the GPU, e.g. 'Fragment' 'Float'. -newtype Fragment a = Fragment { fromFragment :: ShaderTree } - -rasterizeVertex :: Vertex Float -> Fragment Float -rasterizeVertex = Fragment . ShaderInputTree . fromVertex -inputVertex :: Int -> Vertex Float -inputVertex = Vertex . ShaderInput -fragmentFrontFacing :: Fragment Bool-fragmentFrontFacing = Fragment $ ShaderOp "gl_ff" (assign "bool" (const "gl_FrontFacing")) []- -getShaders :: Vec4 (Vertex Float) -> Fragment Bool -> Vec4 (Fragment Float) -> Maybe (Fragment Float) -> (ShaderInfo, ShaderInfo, [Int]) -getShaders pos (Fragment ndisc) color mdepth = ((createShaderKey vdag,vstr,vuns),(createShaderKey fdag,fstr,funs), inputs) - where fcolor = fromFragment $ fFromVec "vec4" color - (varyings, fdag@(fcolor':ndisc':mdepth',_)) = splitShaders (createDAG (fcolor:ndisc: map fromFragment (maybeToList mdepth))) - vpos = fromVertex $ vFromVec "vec4" pos - vdag@(vpos':varyings',_) = createDAG (vpos:varyings) - inputs = extractInputs vdag - vcodeAssigns = getCodeAssignments (fromJust . flip elemIndex inputs) (length inputs) "v" vdag - vCodeFinish = setVaryings varyings' ++ - "gl_Position = t" ++ show vpos' ++ ";\n" - fcodeAssigns = getCodeAssignments id (length varyings') "f" fdag - depthAssign = case mdepth' of [d] -> "gl_FragDepth = t" ++ show d ++ ";\n" - [] -> "" - fcodeFinish = "if (!t" ++ show ndisc' ++ ") discard;\n" ++ - depthAssign ++ - "gl_FragColor = t" ++ show fcolor' ++ ";\n" - vuns = extractUniforms vdag - funs = extractUniforms fdag - attributeDecl = inoutDecls "attribute" "v" (length inputs) - varyingDecl = inoutDecls "varying" "f" (length varyings') - vstr = makeShader (attributeDecl ++ varyingDecl ++ uniformDecls "v" vuns) (vcodeAssigns ++ vCodeFinish) - fstr = makeShader (varyingDecl ++ uniformDecls "f" funs) (fcodeAssigns ++ fcodeFinish) - -vSampleBinFunc f t s tex c = toColor $ vToVec "float" 4 (vBinaryFunc "vec4" f (Vertex $ ShaderUniform $ UniformSampler t s tex) (vFromVec (tName c) c)) -fSampleBinFunc f t s tex c = toColor $ fToVec "float" 4 (fBinaryFunc "vec4" f (Fragment $ ShaderUniform $ UniformSampler t s tex) (fFromVec (tName c) c)) -vSampleTernFunc f t s tex c x = toColor $ vToVec "float" 4 (vTernaryFunc "vec4" f (Vertex $ ShaderUniform $ UniformSampler t s tex) (vFromVec (tName c) c) x) -fSampleTernFunc f t s tex c x = toColor $ fToVec "float" 4 (fTernaryFunc "vec4" f (Fragment $ ShaderUniform $ UniformSampler t s tex) (fFromVec (tName c) c) x) --instance GPU (Vertex Float) where - type CPU (Vertex Float) = Float - toGPU = Vertex . ShaderUniform . UniformFloat -instance GPU (Vertex Int) where - type CPU (Vertex Int) = Int - toGPU = Vertex . ShaderUniform . UniformInt -instance GPU (Vertex Bool) where - type CPU (Vertex Bool) = Bool - toGPU = Vertex . ShaderUniform . UniformBool - -instance GPU (Fragment Float) where - type CPU (Fragment Float) = Float - toGPU = Fragment . ShaderUniform . UniformFloat -instance GPU (Fragment Int) where - type CPU (Fragment Int) = Int - toGPU = Fragment . ShaderUniform . UniformInt -instance GPU (Fragment Bool) where - type CPU (Fragment Bool) = Bool - toGPU = Fragment . ShaderUniform . UniformBool - -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 Show (Vertex a) where - show = noFun "show" -instance Show (Fragment a) where - show = noFun "show" - -instance Ord (Vertex Float) where - (<=) = noFun "(<=)" - min = vBinaryFunc "float" "min" - max = vBinaryFunc "float" "max" -instance Ord (Fragment Float) where - (<=) = noFun "(<=)" - min = fBinaryFunc "float" "min" - max = fBinaryFunc "float" "max" -instance Num (Vertex Float) where - negate = vUnaryPreOp "float" "-" - (+) = vBinaryOp "float" "+" - (*) = vBinaryOp "float" "*" - fromInteger = Vertex . ShaderConstant . ConstFloat . fromInteger - abs = vUnaryFunc "float" "abs" - signum = vUnaryFunc "float" "sign" -instance Num (Fragment Float) where - negate = fUnaryPreOp "float" "-" - (+) = fBinaryOp "float" "+" - (*) = fBinaryOp "float" "*" - fromInteger = Fragment . ShaderConstant . ConstFloat . fromInteger - abs = fUnaryFunc "float" "abs" - signum = fUnaryFunc "float" "sign" - - -instance Ord (Vertex Int) where - (<=) = noFun "(<=)" - min = noFun "min" - max = noFun "max" -instance Ord (Fragment Int) where - (<=) = noFun "(<=)" - min = noFun "min" - max = noFun "max" -instance Num (Vertex Int) where - negate = vUnaryPreOp "int" "-" - (+) = vBinaryOp "int" "+" - (*) = vBinaryOp "int" "*" - fromInteger = Vertex . ShaderConstant . ConstInt . fromInteger - abs = noFun "abs" - signum = noFun "sign" -instance Num (Fragment Int) where - negate = fUnaryPreOp "int" "-" - (+) = fBinaryOp "int" "+" - (*) = fBinaryOp "int" "*" - fromInteger = Fragment . ShaderConstant . ConstInt . fromInteger - abs = noFun "abs" - signum = noFun "sign" - - -instance Fractional (Vertex Float) where - (/) = vBinaryOp "float" "/" - fromRational = Vertex . ShaderConstant . ConstFloat . fromRational -instance Fractional (Fragment Float) where - (/) = fBinaryOp "float" "/" - fromRational = Fragment . ShaderConstant . ConstFloat . fromRational -instance Floating (Vertex Float) where - pi = Vertex $ ShaderConstant $ ConstFloat pi - sqrt = vUnaryFunc "float" "sqrt" - exp = vUnaryFunc "float" "exp" - log = vUnaryFunc "float" "log" - (**) = vBinaryFunc "float" "pow" - sin = vUnaryFunc "float" "sin" - cos = vUnaryFunc "float" "cos" - tan = vUnaryFunc "float" "tan" - asin = vUnaryFunc "float" "asin" - acos = vUnaryFunc "float" "acos" - atan = vUnaryFunc "float" "atan" - sinh = noFun "float" "sinh" - cosh = noFun "float" "cosh" - asinh = noFun "float" "asinh" - atanh = noFun "float" "atanh" - acosh = noFun "float" "acosh" -instance Floating (Fragment Float) where - pi = Fragment $ ShaderConstant $ ConstFloat pi - sqrt = fUnaryFunc "float" "sqrt" - exp = fUnaryFunc "float" "exp" - log = fUnaryFunc "float" "log" - (**) = fBinaryFunc "float" "pow" - sin = fUnaryFunc "float" "sin" - cos = fUnaryFunc "float" "cos" - tan = fUnaryFunc "float" "tan" - asin = fUnaryFunc "float" "asin" - acos = fUnaryFunc "float" "acos" - atan = fUnaryFunc "float" "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 "float" "inversesqrt" - exp2 = vUnaryFunc "float" "exp2" - log2 = vUnaryFunc "float" "log2" - floor' = vUnaryFunc "float" "floor" - ceiling' = vUnaryFunc "float" "ceil" - fract' = vUnaryFunc "float" "fract" - mod' = vBinaryFunc "float" "mod" - clamp = vTernaryFunc "float" "clamp" - mix = vTernaryFunc "float" "mix" - step = vBinaryFunc "float" "step" - smoothstep = vTernaryFunc "float" "smoothstep" - -instance Real' (Fragment Float) where - rsqrt = fUnaryFunc "float" "inversesqrt" - exp2 = fUnaryFunc "float" "exp2" - log2 = fUnaryFunc "float" "log2" - floor' = fUnaryFunc "float" "floor" - ceiling' = fUnaryFunc "float" "ceil" - fract' = fUnaryFunc "float" "fract" - mod' = fBinaryFunc "float" "mod" - clamp = fTernaryFunc "float" "clamp" - mix = fTernaryFunc "float" "mix" - step = fBinaryFunc "float" "step" - smoothstep = fTernaryFunc "float" "smoothstep" - -instance Boolean (Vertex Bool) where - true = Vertex $ ShaderConstant $ ConstBool True - false = Vertex $ ShaderConstant $ ConstBool False - notB = vUnaryPreOp "bool" "!" - (&&*) = vBinaryOp "bool" "&&" - (||*) = vBinaryOp "bool" "||" -instance Boolean (Fragment Bool) where - true = Fragment $ ShaderConstant $ ConstBool True - false = Fragment $ ShaderConstant $ ConstBool False - notB = fUnaryPreOp "bool" "!" - (&&*) = fBinaryOp "bool" "&&" - (||*) = fBinaryOp "bool" "||" -instance Eq a => EqB (Vertex Bool) (Vertex a) where - (==*) = vBinaryOp "bool" "==" - (/=*) = vBinaryOp "bool" "!=" -instance Eq a => EqB (Fragment Bool) (Fragment a) where - (==*) = fBinaryOp "bool" "==" - (/=*) = fBinaryOp "bool" "!=" -instance Ord a => OrdB (Vertex Bool) (Vertex a) where - (<*) = vBinaryOp "bool" "<" - (>=*) = vBinaryOp "bool" ">=" - (>*) = vBinaryOp "bool" ">" - (<=*) = vBinaryOp "bool" "<=" -instance Ord a => OrdB (Fragment Bool) (Fragment a) where - (<*) = fBinaryOp "bool" "<" - (>=*) = fBinaryOp "bool" ">=" - (>*) = fBinaryOp "bool" ">" - (<=*) = fBinaryOp "bool" "<=" - -instance IfB (Vertex Bool) (Vertex Int) where - ifB c a b = Vertex $ ShaderOp "if" (assign "int" (\[a,b,c]->a++"?"++b++":"++c)) [fromVertex c,fromVertex a,fromVertex b] -instance IfB (Vertex Bool) (Vertex Float) where - ifB c a b = Vertex $ ShaderOp "if" (assign "float" (\[a,b,c]->a++"?"++b++":"++c)) [fromVertex c,fromVertex a,fromVertex b] -instance IfB (Vertex Bool) (Vertex Bool) where - ifB c a b = Vertex $ ShaderOp "if" (assign "bool" (\[a,b,c]->a++"?"++b++":"++c)) [fromVertex c,fromVertex a,fromVertex b] - -instance IfB (Fragment Bool) (Fragment Int) where - ifB c a b = Fragment $ ShaderOp "if" (assign "int" (\[a,b,c]->a++"?"++b++":"++c)) [fromFragment c,fromFragment a,fromFragment b] -instance IfB (Fragment Bool) (Fragment Float) where - ifB c a b = Fragment $ ShaderOp "if" (assign "float" (\[a,b,c]->a++"?"++b++":"++c)) [fromFragment c,fromFragment a,fromFragment b] -instance IfB (Fragment Bool) (Fragment Bool) where - ifB c a b = Fragment $ ShaderOp "if" (assign "bool" (\[a,b,c]->a++"?"++b++":"++c)) [fromFragment c,fromFragment a,fromFragment b] ---- | Provides a common way to convert numeric types to integer and floating point representations.-class Convert a where- type ConvertFloat a- type ConvertInt a- -- | Convert to a floating point number.- toFloat :: a -> ConvertFloat a- -- | Convert to an integral number, using truncation if necessary.- toInt :: a -> ConvertInt a--instance Convert Float where- type ConvertFloat Float = Float- type ConvertInt Float = Int- toFloat = id- toInt = truncate-instance Convert Int where- type ConvertFloat Int = Float- type ConvertInt Int = Int- toFloat = fromIntegral- toInt = id-instance Convert (Vertex Float) where- type ConvertFloat (Vertex Float) = Vertex Float- type ConvertInt (Vertex Float) = Vertex Int- toFloat = id- toInt = vUnaryFunc "int" "int"-instance Convert (Vertex Int) where- type ConvertFloat (Vertex Int) = Vertex Float- type ConvertInt (Vertex Int) = Vertex Int- toFloat = vUnaryFunc "float" "float"- toInt = id-instance Convert (Fragment Float) where- type ConvertFloat (Fragment Float) = Fragment Float- type ConvertInt (Fragment Float) = Fragment Int- toFloat = id- toInt = fUnaryFunc "int" "int"-instance Convert (Fragment Int) where- type ConvertFloat (Fragment Int) = Fragment Float- type ConvertInt (Fragment Int) = Fragment Int- toFloat = fUnaryFunc "float" "float"- toInt = id- --- | 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 "float" "dFdx" -dFdy = fUnaryFunc "float" "dFdy" -fwidth = fUnaryFunc "float" "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 "float" "length" . fFromVec "vec4" -normF3 :: Vec3 (Fragment Float) -> Fragment Float -normF3 = fUnaryFunc "float" "length" . fFromVec "vec3" -normF2 :: Vec2 (Fragment Float) -> Fragment Float -normF2 = fUnaryFunc "float" "length" . fFromVec "vec2" -{-# RULES "norm/V4" norm = normV4 #-} -{-# RULES "norm/V3" norm = normV3 #-} -{-# RULES "norm/V2" norm = normV2 #-} -normV4 :: Vec4 (Vertex Float) -> Vertex Float -normV4 = vUnaryFunc "float" "length" . vFromVec "vec4" -normV3 :: Vec3 (Vertex Float) -> Vertex Float -normV3 = vUnaryFunc "float" "length" . vFromVec "vec3" -normV2 :: Vec2 (Vertex Float) -> Vertex Float -normV2 = vUnaryFunc "float" "length" . vFromVec "vec3" - -{-# RULES "normalize/F4" normalize = normalizeF4 #-} -{-# RULES "normalize/F3" normalize = normalizeF3 #-} -{-# RULES "normalize/F2" normalize = normalizeF2 #-} -normalizeF4 :: Vec4 (Fragment Float) -> Vec4 (Fragment Float) -normalizeF4 = fToVec "float" 4 . fUnaryFunc "vec4" "normalize" . fFromVec "vec4" -normalizeF3 :: Vec3 (Fragment Float) -> Vec3 (Fragment Float) -normalizeF3 = fToVec "float" 3 . fUnaryFunc "vec3" "normalize" . fFromVec "vec3" -normalizeF2 :: Vec2 (Fragment Float) -> Vec2 (Fragment Float) -normalizeF2 = fToVec "float" 2 . fUnaryFunc "vec2" "normalize" . fFromVec "vec2" -{-# RULES "normalize/V4" normalize = normalizeV4 #-} -{-# RULES "normalize/V3" normalize = normalizeV3 #-} -{-# RULES "normalize/V2" normalize = normalizeV2 #-} -normalizeV4 :: Vec4 (Vertex Float) -> Vec4 (Vertex Float) -normalizeV4 = vToVec "float" 4 . vUnaryFunc "vec4" "normalize" . vFromVec "vec4" -normalizeV3 :: Vec3 (Vertex Float) -> Vec3 (Vertex Float) -normalizeV3 = vToVec "float" 3 . vUnaryFunc "vec3" "normalize" . vFromVec "vec3" -normalizeV2 :: Vec2 (Vertex Float) -> Vec2 (Vertex Float) -normalizeV2 = vToVec "float" 2 . vUnaryFunc "vec2" "normalize" . vFromVec "vec2" - -{-# 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 "float" "dot" (fFromVec "vec4" a) (fFromVec "vec4" b) -dotF3 :: Vec3 (Fragment Float) -> Vec3 (Fragment Float) -> Fragment Float -dotF3 a b = fBinaryFunc "float" "dot" (fFromVec "vec3" a) (fFromVec "vec3" b) -dotF2 :: Vec2 (Fragment Float) -> Vec2 (Fragment Float) -> Fragment Float -dotF2 a b = fBinaryFunc "float" "dot" (fFromVec "vec2" a) (fFromVec "vec2" 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 "float" "dot" (vFromVec "vec4" a) (vFromVec "vec4" b) -dotV3 :: Vec3 (Vertex Float) -> Vec3 (Vertex Float) -> Vertex Float -dotV3 a b = vBinaryFunc "float" "dot" (vFromVec "vec3" a) (vFromVec "vec3" b) -dotV2 :: Vec2 (Vertex Float) -> Vec2 (Vertex Float) -> Vertex Float -dotV2 a b = vBinaryFunc "float" "dot" (vFromVec "vec2" a) (vFromVec "vec2" b) - -{-# RULES "cross/F3" cross = crossF3 #-} -crossF3 :: Vec3 (Fragment Float) -> Vec3 (Fragment Float) -> Vec3 (Fragment Float) -crossF3 a b = fToVec "float" 3 $ fBinaryFunc "vec3" "cross" (fFromVec "vec3" a) (fFromVec "vec3" b) -{-# RULES "cross/V3" cross = crossV3 #-} -crossV3 :: Vec3 (Vertex Float) -> Vec3 (Vertex Float) ->Vec3 (Vertex Float) -crossV3 a b = vToVec "float" 3 $ vBinaryFunc "vec3" "cross" (vFromVec "vec3" a) (vFromVec "vec3" b) - --------------------------------------- --- Private --- -noFun :: String -> a -noFun = error . (++ ": No overloading for Vertex/Fragment") - -setVaryings xs = setVaryings' 0 $ map (('t':) . show) xs - where - setVaryings' _ [] = "" - setVaryings' n xs = case splitAt 4 xs of (ys,rest) -> "f" ++ show n ++ " = " ++ tName' (length ys) ++ "(" ++ intercalate "," ys ++ ");\n" ++ setVaryings' (n+1) rest - -inoutDecls t n i = inoutDecls' i 0 - where inoutDecls' i x | i >= 4 = t ++ " vec4 " ++ n ++ show x ++ ";\n" ++ inoutDecls' (i-4) (x+1) - | i == 0 = "" - | otherwise = t ++ " " ++ tName' i ++ " " ++ n ++ show x ++ ";\n" - -uniformDecls :: String -> UniformSet -> String -uniformDecls p (f,i,b,s) = makeU "float" "f" (length f) ++ - makeU "int" "i" (length i) ++ - makeU "bool" "b" (length b) ++ - concatMap (\(t,xs) -> makeU (sampName t) ('s':show (fromEnum t)) (length xs)) (Map.toList s) - where makeU t n 0 = "" - makeU t n i = "uniform " ++ t ++ " " ++ p ++ "u" ++ n ++ "[" ++ show i ++ "];\n" - -makeShader init assignments = "#version 120\n" ++ - init ++ - "void main(){\n" ++ - assignments ++ - "}\n" - -createShaderKey :: ShaderDAG -> ShaderKey -createShaderKey (a,xs) = (a,map (first toShaderKeyNode) xs) - where toShaderKeyNode (ShaderUniform _) = ShaderKeyUniform - toShaderKeyNode (ShaderInput a) = ShaderKeyInput a - toShaderKeyNode (ShaderConstant a) = ShaderKeyConstant a - toShaderKeyNode (ShaderOp a _ _) = ShaderKeyOp a - toShaderKeyNode (ShaderInputTree _) = error "Use splitShaders first" - -splitShaders :: ShaderDAG -> ([ShaderTree], ShaderDAG) -- ^ (previous, current) -splitShaders (a,xs) = case mapAccumL splitNode [] xs of (trees, xs2) -> (reverse trees, (a,xs2)) - where splitNode ts (ShaderInputTree a, ys) = (a:ts, (ShaderInput (length ts), ys)) - splitNode ts a = (ts, a) - -createDAG :: [ShaderTree] -> ShaderDAG -createDAG = second reverse . unsafePerformIO . startDAG - where startDAG xs = do ht <- HT.new (==) (fromIntegral . hashStableName) - runStateT (mapM (createDAG' ht) xs) [] - createDAG' :: HT.HashTable (StableName ShaderTree) Int -> ShaderTree -> StateT [(ShaderTree, [Int])] IO Int - createDAG' ht n = do n' <- liftIO $ evaluate n -- To make makeStableName "stable" - k <- liftIO $ makeStableName n' - m <- liftIO $ HT.lookup ht k - case m of - Just i -> return i - Nothing -> do xs' <- case n' of - ShaderOp _ _ xs -> mapM (createDAG' ht) xs - _ -> return [] - ys <- get - let y = length ys - liftIO $ HT.insert ht k y - put $ (n',xs'):ys - return y - - - -extractUniforms :: ShaderDAG -> UniformSet -extractUniforms (_,xs) = foldl' extractUniform ([],[],[],Map.empty) $ reverse $ map fst xs - where extractUniform (a,b,c,m) (ShaderUniform (UniformFloat x)) = (x:a,b,c,m) - extractUniform (a,b,c,m) (ShaderUniform (UniformInt x)) = (a,x:b,c,m) - extractUniform (a,b,c,m) (ShaderUniform (UniformBool x)) = (a,b,x:c,m) - extractUniform (a,b,c,m) (ShaderUniform (UniformSampler t s tex)) = (a,b,c,Map.insertWith' (++) t [(s,tex)] m) - extractUniform x _ = x - -extractInputs :: ShaderDAG -> [Int] -extractInputs (_,xs) = IntSet.toAscList $ foldl' extractIn (IntSet.empty) $ map fst xs - where extractIn s (ShaderInput a) = IntSet.insert a s - extractIn x _ = x - -getCodeAssignments :: (Int -> Int) -> Int -> String -> ShaderDAG -> String -getCodeAssignments inF numIns inName (_,xs) = concat $ snd $ mapAccumL getCode ((0,0,0,Map.empty),Map.empty) $ zip [0..] xs - where getCode ((f,i,b,s),inlns) (n, (ShaderUniform (UniformFloat _), _)) = (((f+1,i,b,s),inlns), assign "float" (const $ inName ++ "uf[" ++ show f ++ "]") (var n) []) - getCode ((f,i,b,s),inlns) (n, (ShaderUniform (UniformInt _), _)) = (((f,i+1,b,s),inlns), assign "int" (const $ inName ++ "ui[" ++ show i ++ "]") (var n) []) - getCode ((f,i,b,s),inlns) (n, (ShaderUniform (UniformBool _), _)) = (((f,i,b+1,s),inlns), assign "bool" (const $ inName ++ "ub[" ++ show b ++ "]") (var n) []) - getCode ((f,i,b,s),inlns) (n, (ShaderUniform (UniformSampler t _ _), _)) = - case first (fromMaybe 0) $ Map.insertLookupWithKey (const $ const (+1)) t 1 s of - (x, s') -> (((f,i,b,s'),Map.insert n (inName ++ "us" ++ show (fromEnum t) ++ "[" ++ show x ++ "]") inlns), "") - getCode x (n, (ShaderConstant (ConstFloat f), _)) = (x, assign "float" (const $ show f) (var n) []) - getCode x (n, (ShaderConstant (ConstInt i), _)) = (x, assign "int" (const $ show i) (var n) []) - getCode x (n, (ShaderConstant (ConstBool b), _)) = (x, assign "bool" (const $ if b then "true" else "false") (var n) []) - getCode x (n, (ShaderInput i, _)) = (x, assign "float" (const $ inName ++ inoutAccessor (inF i) numIns) (var n) []) - getCode x@(_,inlns) (n, (ShaderOp _ f _, xs)) = (x, f (var n) (map (varMaybeInline inlns) xs)) - getCode _ (_, (ShaderInputTree _, _)) = error "Shader.getCodeAssignments: Use splitShaders first!" - var n = 't' : show n - varMaybeInline inlns n = case Map.lookup n inlns of Just str -> str - Nothing -> var n - -inoutAccessor i tot = case divMod i 4 of (d,m) -> if i+1 == tot && m == 0 then show d else show d ++ "." ++ (["x","y","z","w"]!!m) - -sampName Sampler3D = "sampler3D" -sampName Sampler2D = "sampler2D" -sampName Sampler1D = "sampler1D" -sampName SamplerCube = "samplerCube" - -tName v = tName' $ Vec.length v -tName' 1 = "float" -tName' x = "vec" ++ show x - -assign :: String -> ([String] -> String) -> String -> [String] -> String -assign t f x ys = t ++ " " ++ x ++ "=" ++ f ys ++ ";\n" -binFunc :: String -> [String] -> String -binFunc s = head . binFunc' - where - binFunc' (a:b:xs) = binFunc' $ (s ++ "(" ++ a ++ "," ++ b ++ ")"):binFunc' xs - binFunc' x = x - -vBinaryOp t s a b = Vertex $ ShaderOp s (assign t (intercalate s)) [fromVertex a, fromVertex b] -vUnaryPreOp t s a = Vertex $ ShaderOp s (assign t ((s ++) . head)) [fromVertex a] -vUnaryPostOp t s a = Vertex $ ShaderOp s (assign t ((++ s) . head)) [fromVertex a] -vUnaryFunc t s a = Vertex $ ShaderOp s (assign t (((s ++ "(") ++) . (++ ")") . head)) [fromVertex a] -vBinaryFunc t s a b = Vertex $ ShaderOp s (assign t (binFunc s)) [fromVertex a, fromVertex b] -vTernaryFunc t s a b c = Vertex $ ShaderOp s (assign t (\[a,b,c]->s++"("++a++","++b++","++c++")")) [fromVertex a, fromVertex b, fromVertex c] -vFromVec t = Vertex . ShaderOp "" (assign t (((t ++ "(") ++) . (++ ")") . intercalate ",")) . map fromVertex . Vec.toList -vToVec t n a = Vec.fromList $ map (\s -> Vertex $ ShaderOp s (assign t (\[x]->x++"["++s++"]")) [fromVertex a]) [show n' | n' <-[0..n - 1]] - -fBinaryOp t s a b = Fragment $ ShaderOp s (assign t (intercalate s)) [fromFragment a, fromFragment b] -fUnaryPreOp t s a = Fragment $ ShaderOp s (assign t ((s ++) . head)) [fromFragment a] -fUnaryPostOp t s a = Fragment $ ShaderOp s (assign t ((++ s) . head)) [fromFragment a] -fUnaryFunc t s a = Fragment $ ShaderOp s (assign t (((s ++ "(") ++) . (++ ")") . head)) [fromFragment a] -fBinaryFunc t s a b = Fragment $ ShaderOp s (assign t (binFunc s)) [fromFragment a, fromFragment b] -fTernaryFunc t s a b c = Fragment $ ShaderOp s (assign t (\[a,b,c]->s++"("++a++","++b++","++c++")")) [fromFragment a, fromFragment b, fromFragment c] -fFromVec t = Fragment . ShaderOp "" (assign t (((t ++ "(") ++) . (++ ")") . intercalate ",")) . map fromFragment . Vec.toList -fToVec t n a = Vec.fromList $ map (\s -> Fragment $ ShaderOp s (assign t (\[x]->x++"["++s++"]")) [fromFragment a]) [show n' | n' <-[0..n - 1]] - +{-# LANGUAGE TypeOperators, TypeFamilies, FlexibleInstances, MultiParamTypeClasses #-} +-----------------------------------------------------------------------------+--+-- Module : Shader+-- Copyright : Tobias Bexelius+-- License : BSD3+--+-- Maintainer : Tobias Bexelius+-- Stability : Experimental+-- Portability : Portable+--+-- |+--+-----------------------------------------------------------------------------++module Shader (+ GPU(..),+ rasterizeVertex,+ inputVertex,+ fragmentFrontFacing,+ Vertex(),+ Fragment(),+ ShaderInfo,+ getShaders,+ Real'(..),+ Convert(..),+ dFdx,+ dFdy,+ fwidth,+ vSampleBinFunc,+ fSampleBinFunc,+ vSampleTernFunc,+ fSampleTernFunc,+ module Data.Boolean+) where++import Control.Monad.Trans.State.Lazy (put, get, StateT, runStateT) +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.Maybe+import Data.Boolean+import Data.Map (Map)+import qualified Data.Map as Map hiding (Map)+import qualified Data.HashTable as HT+import Control.Exception (evaluate)+import System.Mem.StableName+import Data.IntSet (IntSet)+import qualified Data.IntSet as IntSet hiding (IntSet)+import Control.Arrow (first, second)+import Resources+import Formats++infixl 7 `mod'`++-- | 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.+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++data ShaderTree = ShaderUniform !Uniform + | ShaderConstant !Const+ | ShaderInput !Int+ | ShaderInputTree ShaderTree+ | ShaderOp !Op (String -> [String] -> String) [ShaderTree]+type ShaderDAG = ([Int],[(ShaderTree, [Int])])++-- | An opaque type constructor for atomic values in a vertex on the GPU, e.g. 'Vertex' 'Float'.+newtype Vertex a = Vertex { fromVertex :: ShaderTree }+-- | An opaque type constructor for atomic values in a fragment on the GPU, e.g. 'Fragment' 'Float'. +newtype Fragment a = Fragment { fromFragment :: ShaderTree }++rasterizeVertex :: Vertex Float -> Fragment Float+rasterizeVertex = Fragment . ShaderInputTree . fromVertex+inputVertex :: Int -> Vertex Float+inputVertex = Vertex . ShaderInput+fragmentFrontFacing :: Fragment Bool+fragmentFrontFacing = Fragment $ ShaderOp "gl_ff" (assign "bool" (const "gl_FrontFacing")) []++getShaders :: Vec4 (Vertex Float) -> Fragment Bool -> Vec4 (Fragment Float) -> Maybe (Fragment Float) -> (ShaderInfo, ShaderInfo, [Int])+getShaders pos (Fragment ndisc) color mdepth = ((createShaderKey vdag,vstr,vuns),(createShaderKey fdag,fstr,funs), inputs)+ where fcolor = fromFragment $ fFromVec "vec4" color+ (varyings, fdag@(fcolor':ndisc':mdepth',_)) = splitShaders (createDAG (fcolor:ndisc: map fromFragment (maybeToList mdepth)))+ vpos = fromVertex $ vFromVec "vec4" pos+ vdag@(vpos':varyings',_) = createDAG (vpos:varyings)+ inputs = extractInputs vdag+ vcodeAssigns = getCodeAssignments (fromJust . flip elemIndex inputs) (length inputs) "v" vdag+ vCodeFinish = setVaryings varyings' +++ "gl_Position = t" ++ show vpos' ++ ";\n"+ fcodeAssigns = getCodeAssignments id (length varyings') "f" fdag+ depthAssign = case mdepth' of [d] -> "gl_FragDepth = t" ++ show d ++ ";\n"+ [] -> ""+ fcodeFinish = "if (!t" ++ show ndisc' ++ ") discard;\n" +++ depthAssign +++ "gl_FragColor = t" ++ show fcolor' ++ ";\n"+ vuns = extractUniforms vdag+ funs = extractUniforms fdag+ attributeDecl = inoutDecls "attribute" "v" (length inputs)+ varyingDecl = inoutDecls "varying" "f" (length varyings')+ vstr = makeShader (attributeDecl ++ varyingDecl ++ uniformDecls "v" vuns) (vcodeAssigns ++ vCodeFinish)+ fstr = makeShader (varyingDecl ++ uniformDecls "f" funs) (fcodeAssigns ++ fcodeFinish) + +vSampleBinFunc f t s tex c = toColor $ vToVec "float" 4 (vBinaryFunc "vec4" f (Vertex $ ShaderUniform $ UniformSampler t s tex) (vFromVec (tName c) c))+fSampleBinFunc f t s tex c = toColor $ fToVec "float" 4 (fBinaryFunc "vec4" f (Fragment $ ShaderUniform $ UniformSampler t s tex) (fFromVec (tName c) c))+vSampleTernFunc f t s tex c x = toColor $ vToVec "float" 4 (vTernaryFunc "vec4" f (Vertex $ ShaderUniform $ UniformSampler t s tex) (vFromVec (tName c) c) x)+fSampleTernFunc f t s tex c x = toColor $ fToVec "float" 4 (fTernaryFunc "vec4" f (Fragment $ ShaderUniform $ UniformSampler t s tex) (fFromVec (tName c) c) x)++instance GPU (Vertex Float) where+ type CPU (Vertex Float) = Float+ toGPU = Vertex . ShaderUniform . UniformFloat+instance GPU (Vertex Int) where+ type CPU (Vertex Int) = Int+ toGPU = Vertex . ShaderUniform . UniformInt+instance GPU (Vertex Bool) where+ type CPU (Vertex Bool) = Bool+ toGPU = Vertex . ShaderUniform . UniformBool++instance GPU (Fragment Float) where+ type CPU (Fragment Float) = Float+ toGPU = Fragment . ShaderUniform . UniformFloat+instance GPU (Fragment Int) where+ type CPU (Fragment Int) = Int+ toGPU = Fragment . ShaderUniform . UniformInt+instance GPU (Fragment Bool) where+ type CPU (Fragment Bool) = Bool+ toGPU = Fragment . ShaderUniform . UniformBool++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 Show (Vertex a) where+ show = noFun "show"+instance Show (Fragment a) where+ show = noFun "show"++instance Ord (Vertex Float) where+ (<=) = noFun "(<=)"+ min = vBinaryFunc "float" "min"+ max = vBinaryFunc "float" "max"+instance Ord (Fragment Float) where+ (<=) = noFun "(<=)"+ min = fBinaryFunc "float" "min"+ max = fBinaryFunc "float" "max"+instance Num (Vertex Float) where+ negate = vUnaryPreOp "float" "-"+ (+) = vBinaryOp "float" "+"+ (*) = vBinaryOp "float" "*"+ fromInteger = Vertex . ShaderConstant . ConstFloat . fromInteger+ abs = vUnaryFunc "float" "abs"+ signum = vUnaryFunc "float" "sign"+instance Num (Fragment Float) where+ negate = fUnaryPreOp "float" "-"+ (+) = fBinaryOp "float" "+"+ (*) = fBinaryOp "float" "*"+ fromInteger = Fragment . ShaderConstant . ConstFloat . fromInteger+ abs = fUnaryFunc "float" "abs"+ signum = fUnaryFunc "float" "sign"+ ++instance Ord (Vertex Int) where+ (<=) = noFun "(<=)"+ min = noFun "min"+ max = noFun "max"+instance Ord (Fragment Int) where+ (<=) = noFun "(<=)"+ min = noFun "min"+ max = noFun "max"+instance Num (Vertex Int) where+ negate = vUnaryPreOp "int" "-"+ (+) = vBinaryOp "int" "+"+ (*) = vBinaryOp "int" "*"+ fromInteger = Vertex . ShaderConstant . ConstInt . fromInteger+ abs = noFun "abs"+ signum = noFun "sign"+instance Num (Fragment Int) where+ negate = fUnaryPreOp "int" "-"+ (+) = fBinaryOp "int" "+"+ (*) = fBinaryOp "int" "*"+ fromInteger = Fragment . ShaderConstant . ConstInt . fromInteger+ abs = noFun "abs"+ signum = noFun "sign"+ + +instance Fractional (Vertex Float) where+ (/) = vBinaryOp "float" "/"+ fromRational = Vertex . ShaderConstant . ConstFloat . fromRational+instance Fractional (Fragment Float) where+ (/) = fBinaryOp "float" "/"+ fromRational = Fragment . ShaderConstant . ConstFloat . fromRational+instance Floating (Vertex Float) where+ pi = Vertex $ ShaderConstant $ ConstFloat pi+ sqrt = vUnaryFunc "float" "sqrt"+ exp = vUnaryFunc "float" "exp"+ log = vUnaryFunc "float" "log"+ (**) = vBinaryFunc "float" "pow"+ sin = vUnaryFunc "float" "sin"+ cos = vUnaryFunc "float" "cos"+ tan = vUnaryFunc "float" "tan"+ asin = vUnaryFunc "float" "asin"+ acos = vUnaryFunc "float" "acos"+ atan = vUnaryFunc "float" "atan"+ sinh = noFun "float" "sinh"+ cosh = noFun "float" "cosh"+ asinh = noFun "float" "asinh"+ atanh = noFun "float" "atanh"+ acosh = noFun "float" "acosh"+instance Floating (Fragment Float) where+ pi = Fragment $ ShaderConstant $ ConstFloat pi+ sqrt = fUnaryFunc "float" "sqrt"+ exp = fUnaryFunc "float" "exp"+ log = fUnaryFunc "float" "log"+ (**) = fBinaryFunc "float" "pow"+ sin = fUnaryFunc "float" "sin"+ cos = fUnaryFunc "float" "cos"+ tan = fUnaryFunc "float" "tan"+ asin = fUnaryFunc "float" "asin"+ acos = fUnaryFunc "float" "acos"+ atan = fUnaryFunc "float" "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 = min (max x a)+ 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 "float" "inversesqrt"+ exp2 = vUnaryFunc "float" "exp2"+ log2 = vUnaryFunc "float" "log2"+ floor' = vUnaryFunc "float" "floor"+ ceiling' = vUnaryFunc "float" "ceil"+ fract' = vUnaryFunc "float" "fract"+ mod' = vBinaryFunc "float" "mod"+ clamp = vTernaryFunc "float" "clamp"+ mix = vTernaryFunc "float" "mix"+ step = vBinaryFunc "float" "step"+ smoothstep = vTernaryFunc "float" "smoothstep"+ +instance Real' (Fragment Float) where+ rsqrt = fUnaryFunc "float" "inversesqrt"+ exp2 = fUnaryFunc "float" "exp2"+ log2 = fUnaryFunc "float" "log2"+ floor' = fUnaryFunc "float" "floor"+ ceiling' = fUnaryFunc "float" "ceil"+ fract' = fUnaryFunc "float" "fract"+ mod' = fBinaryFunc "float" "mod"+ clamp = fTernaryFunc "float" "clamp"+ mix = fTernaryFunc "float" "mix"+ step = fBinaryFunc "float" "step"+ smoothstep = fTernaryFunc "float" "smoothstep"++instance Boolean (Vertex Bool) where+ true = Vertex $ ShaderConstant $ ConstBool True+ false = Vertex $ ShaderConstant $ ConstBool False+ notB = vUnaryPreOp "bool" "!"+ (&&*) = vBinaryOp "bool" "&&"+ (||*) = vBinaryOp "bool" "||"+instance Boolean (Fragment Bool) where+ true = Fragment $ ShaderConstant $ ConstBool True+ false = Fragment $ ShaderConstant $ ConstBool False+ notB = fUnaryPreOp "bool" "!"+ (&&*) = fBinaryOp "bool" "&&"+ (||*) = fBinaryOp "bool" "||"+instance Eq a => EqB (Vertex Bool) (Vertex a) where+ (==*) = vBinaryOp "bool" "=="+ (/=*) = vBinaryOp "bool" "!="+instance Eq a => EqB (Fragment Bool) (Fragment a) where+ (==*) = fBinaryOp "bool" "=="+ (/=*) = fBinaryOp "bool" "!="+instance Ord a => OrdB (Vertex Bool) (Vertex a) where+ (<*) = vBinaryOp "bool" "<"+ (>=*) = vBinaryOp "bool" ">="+ (>*) = vBinaryOp "bool" ">"+ (<=*) = vBinaryOp "bool" "<="+instance Ord a => OrdB (Fragment Bool) (Fragment a) where+ (<*) = fBinaryOp "bool" "<"+ (>=*) = fBinaryOp "bool" ">="+ (>*) = fBinaryOp "bool" ">"+ (<=*) = fBinaryOp "bool" "<="++instance IfB (Vertex Bool) (Vertex Int) where+ ifB c a b = Vertex $ ShaderOp "if" (assign "int" (\[a,b,c]->a++"?"++b++":"++c)) [fromVertex c,fromVertex a,fromVertex b]+instance IfB (Vertex Bool) (Vertex Float) where+ ifB c a b = Vertex $ ShaderOp "if" (assign "float" (\[a,b,c]->a++"?"++b++":"++c)) [fromVertex c,fromVertex a,fromVertex b]+instance IfB (Vertex Bool) (Vertex Bool) where+ ifB c a b = Vertex $ ShaderOp "if" (assign "bool" (\[a,b,c]->a++"?"++b++":"++c)) [fromVertex c,fromVertex a,fromVertex b]+ +instance IfB (Fragment Bool) (Fragment Int) where+ ifB c a b = Fragment $ ShaderOp "if" (assign "int" (\[a,b,c]->a++"?"++b++":"++c)) [fromFragment c,fromFragment a,fromFragment b]+instance IfB (Fragment Bool) (Fragment Float) where+ ifB c a b = Fragment $ ShaderOp "if" (assign "float" (\[a,b,c]->a++"?"++b++":"++c)) [fromFragment c,fromFragment a,fromFragment b]+instance IfB (Fragment Bool) (Fragment Bool) where+ ifB c a b = Fragment $ ShaderOp "if" (assign "bool" (\[a,b,c]->a++"?"++b++":"++c)) [fromFragment c,fromFragment a,fromFragment b]++-- | Provides a common way to convert numeric types to integer and floating point representations.+class Convert a where+ type ConvertFloat a+ type ConvertInt a+ -- | Convert to a floating point number.+ toFloat :: a -> ConvertFloat a+ -- | Convert to an integral number, using truncation if necessary.+ toInt :: a -> ConvertInt a++instance Convert Float where+ type ConvertFloat Float = Float+ type ConvertInt Float = Int+ toFloat = id+ toInt = truncate+instance Convert Int where+ type ConvertFloat Int = Float+ type ConvertInt Int = Int+ toFloat = fromIntegral+ toInt = id+instance Convert (Vertex Float) where+ type ConvertFloat (Vertex Float) = Vertex Float+ type ConvertInt (Vertex Float) = Vertex Int+ toFloat = id+ toInt = vUnaryFunc "int" "int"+instance Convert (Vertex Int) where+ type ConvertFloat (Vertex Int) = Vertex Float+ type ConvertInt (Vertex Int) = Vertex Int+ toFloat = vUnaryFunc "float" "float"+ toInt = id+instance Convert (Fragment Float) where+ type ConvertFloat (Fragment Float) = Fragment Float+ type ConvertInt (Fragment Float) = Fragment Int+ toFloat = id+ toInt = fUnaryFunc "int" "int"+instance Convert (Fragment Int) where+ type ConvertFloat (Fragment Int) = Fragment Float+ type ConvertInt (Fragment Int) = Fragment Int+ toFloat = fUnaryFunc "float" "float"+ toInt = id+ +-- | 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 "float" "dFdx"+dFdy = fUnaryFunc "float" "dFdy"+fwidth = fUnaryFunc "float" "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 "float" "length" . fFromVec "vec4"+normF3 :: Vec3 (Fragment Float) -> Fragment Float+normF3 = fUnaryFunc "float" "length" . fFromVec "vec3"+normF2 :: Vec2 (Fragment Float) -> Fragment Float+normF2 = fUnaryFunc "float" "length" . fFromVec "vec2"+{-# RULES "norm/V4" norm = normV4 #-}+{-# RULES "norm/V3" norm = normV3 #-}+{-# RULES "norm/V2" norm = normV2 #-}+normV4 :: Vec4 (Vertex Float) -> Vertex Float+normV4 = vUnaryFunc "float" "length" . vFromVec "vec4"+normV3 :: Vec3 (Vertex Float) -> Vertex Float+normV3 = vUnaryFunc "float" "length" . vFromVec "vec3"+normV2 :: Vec2 (Vertex Float) -> Vertex Float+normV2 = vUnaryFunc "float" "length" . vFromVec "vec3"++{-# RULES "normalize/F4" normalize = normalizeF4 #-}+{-# RULES "normalize/F3" normalize = normalizeF3 #-}+{-# RULES "normalize/F2" normalize = normalizeF2 #-}+normalizeF4 :: Vec4 (Fragment Float) -> Vec4 (Fragment Float)+normalizeF4 = fToVec "float" 4 . fUnaryFunc "vec4" "normalize" . fFromVec "vec4"+normalizeF3 :: Vec3 (Fragment Float) -> Vec3 (Fragment Float)+normalizeF3 = fToVec "float" 3 . fUnaryFunc "vec3" "normalize" . fFromVec "vec3"+normalizeF2 :: Vec2 (Fragment Float) -> Vec2 (Fragment Float)+normalizeF2 = fToVec "float" 2 . fUnaryFunc "vec2" "normalize" . fFromVec "vec2"+{-# RULES "normalize/V4" normalize = normalizeV4 #-}+{-# RULES "normalize/V3" normalize = normalizeV3 #-}+{-# RULES "normalize/V2" normalize = normalizeV2 #-}+normalizeV4 :: Vec4 (Vertex Float) -> Vec4 (Vertex Float)+normalizeV4 = vToVec "float" 4 . vUnaryFunc "vec4" "normalize" . vFromVec "vec4"+normalizeV3 :: Vec3 (Vertex Float) -> Vec3 (Vertex Float)+normalizeV3 = vToVec "float" 3 . vUnaryFunc "vec3" "normalize" . vFromVec "vec3"+normalizeV2 :: Vec2 (Vertex Float) -> Vec2 (Vertex Float)+normalizeV2 = vToVec "float" 2 . vUnaryFunc "vec2" "normalize" . vFromVec "vec2"++{-# 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 "float" "dot" (fFromVec "vec4" a) (fFromVec "vec4" b)+dotF3 :: Vec3 (Fragment Float) -> Vec3 (Fragment Float) -> Fragment Float+dotF3 a b = fBinaryFunc "float" "dot" (fFromVec "vec3" a) (fFromVec "vec3" b)+dotF2 :: Vec2 (Fragment Float) -> Vec2 (Fragment Float) -> Fragment Float+dotF2 a b = fBinaryFunc "float" "dot" (fFromVec "vec2" a) (fFromVec "vec2" 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 "float" "dot" (vFromVec "vec4" a) (vFromVec "vec4" b)+dotV3 :: Vec3 (Vertex Float) -> Vec3 (Vertex Float) -> Vertex Float+dotV3 a b = vBinaryFunc "float" "dot" (vFromVec "vec3" a) (vFromVec "vec3" b)+dotV2 :: Vec2 (Vertex Float) -> Vec2 (Vertex Float) -> Vertex Float+dotV2 a b = vBinaryFunc "float" "dot" (vFromVec "vec2" a) (vFromVec "vec2" b)++{-# RULES "cross/F3" cross = crossF3 #-}+crossF3 :: Vec3 (Fragment Float) -> Vec3 (Fragment Float) -> Vec3 (Fragment Float)+crossF3 a b = fToVec "float" 3 $ fBinaryFunc "vec3" "cross" (fFromVec "vec3" a) (fFromVec "vec3" b)+{-# RULES "cross/V3" cross = crossV3 #-}+crossV3 :: Vec3 (Vertex Float) -> Vec3 (Vertex Float) ->Vec3 (Vertex Float)+crossV3 a b = vToVec "float" 3 $ vBinaryFunc "vec3" "cross" (vFromVec "vec3" a) (vFromVec "vec3" b)++--------------------------------------+-- Private+--+noFun :: String -> a+noFun = error . (++ ": No overloading for Vertex/Fragment")++setVaryings xs = setVaryings' 0 $ map (('t':) . show) xs+ where + setVaryings' _ [] = ""+ setVaryings' n xs = case splitAt 4 xs of (ys,rest) -> "f" ++ show n ++ " = " ++ tName' (length ys) ++ "(" ++ intercalate "," ys ++ ");\n" ++ setVaryings' (n+1) rest++inoutDecls t n i = inoutDecls' i 0 + where inoutDecls' i x | i >= 4 = t ++ " vec4 " ++ n ++ show x ++ ";\n" ++ inoutDecls' (i-4) (x+1)+ | i == 0 = ""+ | otherwise = t ++ " " ++ tName' i ++ " " ++ n ++ show x ++ ";\n"+ +uniformDecls :: String -> UniformSet -> String+uniformDecls p (f,i,b,s) = makeU "float" "f" (length f) +++ makeU "int" "i" (length i) +++ makeU "bool" "b" (length b) +++ concatMap (\(t,xs) -> makeU (sampName t) ('s':show (fromEnum t)) (length xs)) (Map.toList s)+ where makeU t n 0 = ""+ makeU t n i = "uniform " ++ t ++ " " ++ p ++ "u" ++ n ++ "[" ++ show i ++ "];\n"+ +makeShader init assignments = "#version 120\n" +++ init +++ "void main(){\n" +++ assignments +++ "}\n"+ +createShaderKey :: ShaderDAG -> ShaderKey+createShaderKey (a,xs) = (a,map (first toShaderKeyNode) xs)+ where toShaderKeyNode (ShaderUniform _) = ShaderKeyUniform+ toShaderKeyNode (ShaderInput a) = ShaderKeyInput a+ toShaderKeyNode (ShaderConstant a) = ShaderKeyConstant a+ toShaderKeyNode (ShaderOp a _ _) = ShaderKeyOp a+ toShaderKeyNode (ShaderInputTree _) = error "Use splitShaders first"++splitShaders :: ShaderDAG -> ([ShaderTree], ShaderDAG) -- ^ (previous, current)+splitShaders (a,xs) = case mapAccumL splitNode [] xs of (trees, xs2) -> (reverse trees, (a,xs2))+ where splitNode ts (ShaderInputTree a, ys) = (a:ts, (ShaderInput (length ts), ys))+ splitNode ts a = (ts, a)++createDAG :: [ShaderTree] -> ShaderDAG+createDAG = second reverse . unsafePerformIO . startDAG+ where startDAG xs = do ht <- HT.new (==) (fromIntegral . hashStableName)+ runStateT (mapM (createDAG' ht) xs) []+ createDAG' :: HT.HashTable (StableName ShaderTree) Int -> ShaderTree -> StateT [(ShaderTree, [Int])] IO Int+ createDAG' ht n = do n' <- liftIO $ evaluate n -- To make makeStableName "stable"+ k <- liftIO $ makeStableName n'+ m <- liftIO $ HT.lookup ht k+ case m of+ Just i -> return i+ Nothing -> do xs' <- case n' of + ShaderOp _ _ xs -> mapM (createDAG' ht) xs+ _ -> return []+ ys <- get+ let y = length ys+ liftIO $ HT.insert ht k y+ put $ (n',xs'):ys+ return y++++extractUniforms :: ShaderDAG -> UniformSet +extractUniforms (_,xs) = foldl' extractUniform ([],[],[],Map.empty) $ reverse $ map fst xs+ where extractUniform (a,b,c,m) (ShaderUniform (UniformFloat x)) = (x:a,b,c,m)+ extractUniform (a,b,c,m) (ShaderUniform (UniformInt x)) = (a,x:b,c,m)+ extractUniform (a,b,c,m) (ShaderUniform (UniformBool x)) = (a,b,x:c,m)+ extractUniform (a,b,c,m) (ShaderUniform (UniformSampler t s tex)) = (a,b,c,Map.insertWith' (++) t [(s,tex)] m)+ extractUniform x _ = x ++extractInputs :: ShaderDAG -> [Int]+extractInputs (_,xs) = IntSet.toAscList $ foldl' extractIn IntSet.empty $ map fst xs+ where extractIn s (ShaderInput a) = IntSet.insert a s+ extractIn x _ = x ++getCodeAssignments :: (Int -> Int) -> Int -> String -> ShaderDAG -> String+getCodeAssignments inF numIns inName (_,xs) = concat $ snd $ mapAccumL getCode ((0,0,0,Map.empty),Map.empty) $ zip [0..] xs+ where getCode ((f,i,b,s),inlns) (n, (ShaderUniform (UniformFloat _), _)) = (((f+1,i,b,s),inlns), assign "float" (const $ inName ++ "uf[" ++ show f ++ "]") (var n) [])+ getCode ((f,i,b,s),inlns) (n, (ShaderUniform (UniformInt _), _)) = (((f,i+1,b,s),inlns), assign "int" (const $ inName ++ "ui[" ++ show i ++ "]") (var n) [])+ getCode ((f,i,b,s),inlns) (n, (ShaderUniform (UniformBool _), _)) = (((f,i,b+1,s),inlns), assign "bool" (const $ inName ++ "ub[" ++ show b ++ "]") (var n) [])+ getCode ((f,i,b,s),inlns) (n, (ShaderUniform (UniformSampler t _ _), _)) =+ case first (fromMaybe 0) $ Map.insertLookupWithKey (const $ const (+1)) t 1 s of+ (x, s') -> (((f,i,b,s'),Map.insert n (inName ++ "us" ++ show (fromEnum t) ++ "[" ++ show x ++ "]") inlns), "") + getCode x (n, (ShaderConstant (ConstFloat f), _)) = (x, assign "float" (const $ show f) (var n) [])+ getCode x (n, (ShaderConstant (ConstInt i), _)) = (x, assign "int" (const $ show i) (var n) [])+ getCode x (n, (ShaderConstant (ConstBool b), _)) = (x, assign "bool" (const $ if b then "true" else "false") (var n) [])+ getCode x (n, (ShaderInput i, _)) = (x, assign "float" (const $ inName ++ inoutAccessor (inF i) numIns) (var n) [])+ getCode x@(_,inlns) (n, (ShaderOp _ f _, xs)) = (x, f (var n) (map (varMaybeInline inlns) xs))+ getCode _ (_, (ShaderInputTree _, _)) = error "Shader.getCodeAssignments: Use splitShaders first!"+ var n = 't' : show n+ varMaybeInline inlns n = fromMaybe (var n) (Map.lookup n inlns)++inoutAccessor i tot = case divMod i 4 of (d,m) -> if i+1 == tot && m == 0 then show d else show d ++ "." ++ (["x","y","z","w"]!!m)++sampName Sampler3D = "sampler3D"+sampName Sampler2D = "sampler2D"+sampName Sampler1D = "sampler1D"+sampName SamplerCube = "samplerCube"++tName v = tName' $ Vec.length v+tName' 1 = "float"+tName' x = "vec" ++ show x++assign :: String -> ([String] -> String) -> String -> [String] -> String+assign t f x ys = t ++ " " ++ x ++ "=" ++ f ys ++ ";\n"+binFunc :: String -> [String] -> String+binFunc s = head . binFunc'+ where+ binFunc' (a:b:xs) = binFunc' $ (s ++ "(" ++ a ++ "," ++ b ++ ")"):binFunc' xs+ binFunc' x = x++vBinaryOp t s a b = Vertex $ ShaderOp s (assign t (intercalate s)) [fromVertex a, fromVertex b]+vUnaryPreOp t s a = Vertex $ ShaderOp s (assign t ((s ++) . head)) [fromVertex a]+vUnaryPostOp t s a = Vertex $ ShaderOp s (assign t ((++ s) . head)) [fromVertex a]+vUnaryFunc t s a = Vertex $ ShaderOp s (assign t (((s ++ "(") ++) . (++ ")") . head)) [fromVertex a]+vBinaryFunc t s a b = Vertex $ ShaderOp s (assign t (binFunc s)) [fromVertex a, fromVertex b]+vTernaryFunc t s a b c = Vertex $ ShaderOp s (assign t (\[a,b,c]->s++"("++a++","++b++","++c++")")) [fromVertex a, fromVertex b, fromVertex c]+vFromVec t = Vertex . ShaderOp "" (assign t (((t ++ "(") ++) . (++ ")") . intercalate ",")) . map fromVertex . Vec.toList +vToVec t n a = Vec.fromList $ map (\s -> Vertex $ ShaderOp s (assign t (\[x]->x++"["++s++"]")) [fromVertex a]) [show n' | n' <-[0..n - 1]]++fBinaryOp t s a b = Fragment $ ShaderOp s (assign t (intercalate s)) [fromFragment a, fromFragment b]+fUnaryPreOp t s a = Fragment $ ShaderOp s (assign t ((s ++) . head)) [fromFragment a]+fUnaryPostOp t s a = Fragment $ ShaderOp s (assign t ((++ s) . head)) [fromFragment a]+fUnaryFunc t s a = Fragment $ ShaderOp s (assign t (((s ++ "(") ++) . (++ ")") . head)) [fromFragment a]+fBinaryFunc t s a b = Fragment $ ShaderOp s (assign t (binFunc s)) [fromFragment a, fromFragment b]+fTernaryFunc t s a b c = Fragment $ ShaderOp s (assign t (\[a,b,c]->s++"("++a++","++b++","++c++")")) [fromFragment a, fromFragment b, fromFragment c]+fFromVec t = Fragment . ShaderOp "" (assign t (((t ++ "(") ++) . (++ ")") . intercalate ",")) . map fromFragment . Vec.toList +fToVec t n a = Vec.fromList $ map (\s -> Fragment $ ShaderOp s (assign t (\[x]->x++"["++s++"]")) [fromFragment a]) [show n' | n' <-[0..n - 1]]+
src/Textures.hs view
@@ -1,46 +1,47 @@------------------------------------------------------------------------------ --- --- 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 - - +{-# LANGUAGE ParallelListComp, TypeFamilies, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, ScopedTypeVariables #-} +-----------------------------------------------------------------------------+--+-- 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: --@@ -51,7 +52,7 @@ -- [@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:@@ -63,7 +64,7 @@ -- [@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:@@ -75,7 +76,7 @@ -- [@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.@@ -88,30 +89,30 @@ -- [@TextureVertexCoord (TextureCube f)@] 'Vec3' @(@'Vertex' 'Float'@)@ -- -- [@TextureFragmentCoord (TextureCube f)@] 'Vec3' @(@'Fragment' 'Float'@)@--- -newtype TextureCube f = TextureCube WinMappedTexture - +-- +newtype TextureCube f = TextureCube WinMappedTexture+ class Texture t where- -- | The color format of the texture, affects the type of the samples from the texture. + -- | 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. + -- | 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 + -- | 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'. + -- '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) + -- | 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. +-- | 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.@@ -120,11 +121,11 @@ -- 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. -- All rows and depth levels are tightly packed, i.e. no padding between them and 1 byte alignment.- -> IO t -newTexture f i = mkTexture f (toGLInternalFormat i) + -> 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. +-- 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.@@ -133,208 +134,208 @@ -- 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. -- All rows and depth levels are tightly packed, i.e. no padding between them and 1 byte alignment.- -> 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 = fSampleBinFunc "texture3D" Sampler3D s t v - sampleBias s (Texture3D t) v b = fSampleTernFunc "texture3D" Sampler3D s t v b - sampleLod s (Texture3D t) v m = vSampleTernFunc "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 = fSampleBinFunc "texture2D" Sampler2D s t v - sampleBias s (Texture2D t) v b = fSampleTernFunc "texture2D" Sampler2D s t v b - sampleLod s (Texture2D t) v m = vSampleTernFunc "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 = fSampleBinFunc "texture1D" Sampler1D s t (v:.()) - sampleBias s (Texture1D t) v b = fSampleTernFunc "texture1D" Sampler1D s t (v:.()) b - sampleLod s (Texture1D t) v m = vSampleTernFunc "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 = fSampleBinFunc "textureCube" Sampler3D s t v - sampleBias s (TextureCube t) v b = fSampleTernFunc "textureCube" Sampler3D s t v b - sampleLod s (TextureCube t) v m = vSampleTernFunc "textureCubeLod" Sampler3D s t v m + -> 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 = fSampleBinFunc "texture3D" Sampler3D s t v+ sampleBias s (Texture3D t) v b = fSampleTernFunc "texture3D" Sampler3D s t v b+ sampleLod s (Texture3D t) v m = vSampleTernFunc "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 = fSampleBinFunc "texture2D" Sampler2D s t v+ sampleBias s (Texture2D t) v b = fSampleTernFunc "texture2D" Sampler2D s t v b+ sampleLod s (Texture2D t) v m = vSampleTernFunc "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 = fSampleBinFunc "texture1D" Sampler1D s t (v:.())+ sampleBias s (Texture1D t) v b = fSampleTernFunc "texture1D" Sampler1D s t (v:.()) b+ sampleLod s (Texture1D t) v m = vSampleTernFunc "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 = fSampleBinFunc "textureCube" Sampler3D s t v+ sampleBias s (TextureCube t) v b = fSampleTernFunc "textureCube" Sampler3D s t v b+ sampleLod s (TextureCube t) v m = vSampleTernFunc "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 +-- '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. +-- | 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) + -- | 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) +-- 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 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 +-- 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