diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,4 @@ +### 0.1 + +- Initial revision. Do not consider this revision as a stable release. It’s experimental. The + first stable release will be **1.0**. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2015, Dimitri Sabadie + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Dimitri Sabadie nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/luminance.cabal b/luminance.cabal new file mode 100644 --- /dev/null +++ b/luminance.cabal @@ -0,0 +1,113 @@ +name: luminance +version: 0.1 +synopsis: Type-safe, dependently-typed and stateless graphics framework +description: This package exposes several modules to work with /GPU/ in a stateless and + type-safe way. Currently, it uses **OpenGL** as backend hardware technology but + others will be added later on, such as **Vulkan**. + . + The initial unstable version is /0.1/. Consider everything in that version as + part of an experiment, even though the library should be free of bugs. If you + find any, please report an issue. If you think something could be enhanced, + feel free to fill in an issue as well. + . + One very important point is the fact that **luminance** has nothing to do with + /3D engines/ or /scene development kits/. Don’t expect to find /materials/, + /lights/ or /mesh/ loaders. It’s just a graphics framework initiated to fix the + design choices of **OpenGL**. It won’t change in any other way. +license: BSD3 +license-file: LICENSE +author: Dimitri Sabadie +maintainer: Dimitri Sabadie +copyright: Dimitri Sabadie +homepage: https://github.com/phaazon/luminance +bug-reports: https://github.com/phaazon/luminance/issues +category: Graphics +extra-source-files: CHANGELOG.md + +build-type: Simple +cabal-version: >= 1.10 + +source-repository head + type: git + location: git://github.com/phaazon/luminance.git + +flag debug-gl + description: Enable OpenGL stdout debug (for development only) + default: False + manual: True + +library + ghc-options: -W -Wall + + if flag(debug-gl) + cpp-options: -DDEBUG_GL + + exposed-modules: Graphics.Luminance + , Graphics.Luminance.Batch + , Graphics.Luminance.Blending + , Graphics.Luminance.Buffer + , Graphics.Luminance.Cmd + , Graphics.Luminance.Core.Tuple + , Graphics.Luminance.Framebuffer + , Graphics.Luminance.Geometry + , Graphics.Luminance.Pixel + , Graphics.Luminance.Query + , Graphics.Luminance.RW + , Graphics.Luminance.RenderCmd + , Graphics.Luminance.Shader + , Graphics.Luminance.Shader.Program + , Graphics.Luminance.Shader.Stage + , Graphics.Luminance.Shader.Uniform + , Graphics.Luminance.Texture + , Graphics.Luminance.Vertex + + other-modules: Graphics.Luminance.Core.Batch + , Graphics.Luminance.Core.Blending + , Graphics.Luminance.Core.Buffer + , Graphics.Luminance.Core.Cmd + , Graphics.Luminance.Core.Debug + , Graphics.Luminance.Core.Framebuffer + , Graphics.Luminance.Core.Geometry + , Graphics.Luminance.Core.Pixel + , Graphics.Luminance.Core.Query + , Graphics.Luminance.Core.RenderCmd + , Graphics.Luminance.Core.Renderbuffer + , Graphics.Luminance.Core.RW + , Graphics.Luminance.Core.Shader.Program + , Graphics.Luminance.Core.Shader.Stage + , Graphics.Luminance.Core.Shader.Uniform + , Graphics.Luminance.Core.Texture + , Graphics.Luminance.Core.Vertex + + default-extensions: DataKinds + , DeriveFoldable + , DeriveFunctor + , FlexibleContexts + , FlexibleInstances + , GADTs + , GeneralizedNewtypeDeriving + , MultiParamTypeClasses + , MultiWayIf + , PolyKinds + , RankNTypes + , ScopedTypeVariables + , StandaloneDeriving + , TupleSections + , TypeFamilies + , TypeOperators + + other-extensions: CPP + , UndecidableInstances + + build-depends: base >= 4.8 && < 4.9 + , contravariant >= 1.3 && < 1.4 + , gl >= 0.7 && < 0.8 + , mtl >= 2.2 && < 2.3 + , resourcet >= 1.1 && < 1.2 + , semigroups >= 0.16 && < 0.17 + , transformers >= 0.4 && < 0.5 + , void >= 0.7 && < 0.8 + + hs-source-dirs: src + + default-language: Haskell2010 diff --git a/src/Graphics/Luminance.hs b/src/Graphics/Luminance.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Luminance.hs @@ -0,0 +1,27 @@ +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2015 Dimitri Sabadie +-- License : BSD3 +-- +-- Maintainer : Dimitri Sabadie +-- Stability : experimental +-- Portability : portable +---------------------------------------------------------------------------- + +module Graphics.Luminance ( + module X + ) where + +import Graphics.Luminance.Batch as X +import Graphics.Luminance.Blending as X +import Graphics.Luminance.Buffer as X +import Graphics.Luminance.Cmd as X +import Graphics.Luminance.Framebuffer as X +import Graphics.Luminance.Geometry as X +import Graphics.Luminance.Pixel as X +import Graphics.Luminance.Query as X +import Graphics.Luminance.RenderCmd as X +import Graphics.Luminance.RW as X +import Graphics.Luminance.Shader as X +import Graphics.Luminance.Texture as X +import Graphics.Luminance.Vertex as X diff --git a/src/Graphics/Luminance/Batch.hs b/src/Graphics/Luminance/Batch.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Luminance/Batch.hs @@ -0,0 +1,22 @@ +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2015 Dimitri Sabadie +-- License : BSD3 +-- +-- Maintainer : Dimitri Sabadie +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- + +module Graphics.Luminance.Batch ( + -- * Framebuffer batch + FBBatch + , framebufferBatch + -- * Shader program batch + , SPBatch + , AnySPBatch + , anySPBatch + , shaderProgramBatch + ) where + +import Graphics.Luminance.Core.Batch diff --git a/src/Graphics/Luminance/Blending.hs b/src/Graphics/Luminance/Blending.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Luminance/Blending.hs @@ -0,0 +1,30 @@ +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2015 Dimitri Sabadie +-- License : BSD3 +-- +-- Maintainer : Dimitri Sabadie +-- Stability : experimental +-- Portability : portable +-- +-- That module exports blending-related types and functions. +-- +-- Given two pixels @src@ and @dst@ – source and destination, we associate +-- each pixel a /blending factor/ – respectively, @srcK@ and @dstK@. @src@ is +-- the pixel being computed, and @dst@ is the pixel that is already stored in +-- the framebuffer. +-- +-- The pixels can be blended in several ways. See the documentation of +-- 'BlendingMode' for further details. +-- +-- The factors are encoded with 'BlendingFactor'. +----------------------------------------------------------------------------- + +module Graphics.Luminance.Blending ( + -- * Blending modes + BlendingMode(..) + -- * Blending factors + , BlendingFactor(..) + ) where + +import Graphics.Luminance.Core.Blending diff --git a/src/Graphics/Luminance/Buffer.hs b/src/Graphics/Luminance/Buffer.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Luminance/Buffer.hs @@ -0,0 +1,33 @@ +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2015 Dimitri Sabadie +-- License : BSD3 +-- +-- Maintainer : Dimitri Sabadie +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- + +module Graphics.Luminance.Buffer ( + -- * Buffer creation + Buffer + , bufferID + , createBuffer + , createBuffer_ + -- * Buffer access + , BufferRW + -- * Buffer regions + , Region + , BuildRegion + , newRegion + -- * Operations on buffer regions + , readWhole + , writeWhole + , fill + , (@?) + , (@!) + , writeAt + , writeAt' + ) where + +import Graphics.Luminance.Core.Buffer diff --git a/src/Graphics/Luminance/Cmd.hs b/src/Graphics/Luminance/Cmd.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Luminance/Cmd.hs @@ -0,0 +1,20 @@ +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2015 Dimitri Sabadie +-- License : BSD3 +-- +-- Maintainer : Dimitri Sabadie +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- + +module Graphics.Luminance.Cmd ( + -- * Command type + Cmd + , runCmd + -- * Available commands + , draw + , blit + ) where + +import Graphics.Luminance.Core.Cmd diff --git a/src/Graphics/Luminance/Core/Batch.hs b/src/Graphics/Luminance/Core/Batch.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Luminance/Core/Batch.hs @@ -0,0 +1,103 @@ +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2015 Dimitri Sabadie +-- License : BSD3 +-- +-- Maintainer : Dimitri Sabadie +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- + +module Graphics.Luminance.Core.Batch where + +import Control.Monad.IO.Class ( MonadIO(..) ) +import Data.Bits +import Data.Foldable ( traverse_ ) +import Foreign.Ptr ( nullPtr ) +import Graphics.GL +import Graphics.Luminance.Core.Blending ( setBlending ) +import Graphics.Luminance.Core.Framebuffer ( Framebuffer(..) ) +import Graphics.Luminance.Core.Geometry ( Geometry(..), VertexArray(..) ) +import Graphics.Luminance.Core.Shader.Program ( Program(..) ) +import Graphics.Luminance.Core.RenderCmd ( RenderCmd(..) ) +import Graphics.Luminance.Core.Shader.Uniform ( U(..) ) + +-------------------------------------------------------------------------------- +-- Framebuffer batch ----------------------------------------------------------- + +-- |'Framebuffer' batch. +-- +-- A 'FBBatch' is used to expose a 'Framebuffer' and share it between several shader program +-- batches. +data FBBatch rw c d = FBBatch { + fbBatchFramebuffer :: Framebuffer rw c d + , fbBatchSPBatch :: [AnySPBatch rw c d] + } + +-- |Run a 'FBBatch'. +runFBBatch :: (MonadIO m) => FBBatch rw c d -> m () +runFBBatch (FBBatch fb spbs) = do + liftIO $ glBindFramebuffer GL_DRAW_FRAMEBUFFER (fromIntegral $ framebufferID fb) + liftIO $ glClear $ GL_DEPTH_BUFFER_BIT .|. GL_COLOR_BUFFER_BIT + traverse_ (\(AnySPBatch spb) -> runSPBatch spb) spbs + +-- |Share a 'Framebuffer' between several shader program batches. +framebufferBatch :: Framebuffer rw c d -> [AnySPBatch rw c d] -> FBBatch rw c d +framebufferBatch = FBBatch + +-------------------------------------------------------------------------------- +-- Shader program batch -------------------------------------------------------- + +-- |Shader 'Program' batch. +-- +-- Such a batch is used to share a 'Program' between several 'RenderCmd'. It also +-- gathers a uniform @'U' u@ and a 'u' value to send to the uniform. +-- +-- The 'u' type can be used to send uniforms for the whole batch. It can be useful +-- for cold values – that won’t change very often for a given frame – like the resolution of the +-- screen, the mouse cursor coordinates, the time, and so on and so forth. +-- +-- The 'v' type variable is used to add uniforms per-'RenderCmd'. +data SPBatch rw c d u v = SPBatch { + spBatchShaderProgram :: Program + , spBatchUniform :: U u + , spBatchUniformValue :: u + , spBatchGeometries :: [RenderCmd rw c d v Geometry] + } + +-- |Abstract 'SPBatch' over uniform interface. +data AnySPBatch rw c d = forall u v. AnySPBatch (SPBatch rw c d u v) + +-- FIXME: should we call this function 'abstractSPBatch'? +-- |Abstract 'SPBatch'. +anySPBatch :: SPBatch rw c d u v -> AnySPBatch rw c d +anySPBatch = AnySPBatch + +-- Run a 'SPBatch' in 'MonadIO'. +runSPBatch :: (MonadIO m) => SPBatch rw c d u v -> m () +runSPBatch (SPBatch prog uni u geometries) = do + liftIO $ do + glUseProgram (programID prog) + runU uni u + traverse_ drawGeometry geometries + +-- |Create a new 'SPBatch'. +shaderProgramBatch :: Program -> U u -> u -> [RenderCmd rw c d v Geometry] -> SPBatch rw c d u v +shaderProgramBatch = SPBatch + +-------------------------------------------------------------------------------- +-- Geometry draw function ------------------------------------------------------ + +-- Draw the 'Geometry' held by a 'RenderCmd'. +drawGeometry :: (MonadIO m) => RenderCmd rw c d u Geometry -> m () +drawGeometry (RenderCmd blending depthTest uni u geometry) = do + setBlending blending + (if depthTest then glEnable else glDisable) GL_DEPTH_TEST + liftIO (runU uni u) + case geometry of + DirectGeometry (VertexArray vid mode vbNb) -> do + glBindVertexArray vid + glDrawArrays mode 0 vbNb + IndexedGeometry (VertexArray vid mode ixNb) -> do + glBindVertexArray vid + glDrawElements mode ixNb GL_UNSIGNED_INT nullPtr diff --git a/src/Graphics/Luminance/Core/Blending.hs b/src/Graphics/Luminance/Core/Blending.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Luminance/Core/Blending.hs @@ -0,0 +1,111 @@ +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2015 Dimitri Sabadie +-- License : BSD3 +-- +-- Maintainer : Dimitri Sabadie +-- Stability : experimental +-- Portability : portable +-- +-- That module exports blending-related types and functions. +-- +-- Given two pixels @src@ and @dst@ – source and destination, we associate +-- each pixel a /blending factor/ – respectively, @srcK@ and @dstK@. @src@ is +-- the pixel being computed, and @dst@ is the pixel that is already stored in +-- the framebuffer. +-- +-- The pixels can be blended in several ways. See the documentation of +-- 'BlendingMode' for further details. +-- +-- The factors are encoded with 'BlendingFactor'. +----------------------------------------------------------------------------- + +module Graphics.Luminance.Core.Blending where + +import Control.Monad.IO.Class ( MonadIO(..) ) +import Graphics.GL + +-- |All different blending modes. +-- +-- 'Additive' represents the following blending equation: +-- +-- @blended = src * srcK + dst * dstK +-- +-- 'Subtract' represents the following blending equation: +-- +-- @blended = src * srcK - dst * dstK +-- +-- Because subtracting is not commutating, 'ReverseSubtract' represents the following additional +-- blending equation: +-- +-- @blended = dst * dstK - src * srcK@ +-- +-- 'Min' represents the following blending equation: +-- +-- @blended = min src dst@ +-- +-- 'Max' represents the following blending equation: +-- +-- @blended = max src dst@ +data BlendingMode + = Additive + | Subtract + | ReverseSubtract + | Min + | Max + deriving (Eq,Show) + +fromBlendingMode :: BlendingMode -> GLenum +fromBlendingMode m = case m of + Additive -> GL_FUNC_ADD + Subtract -> GL_FUNC_SUBTRACT + ReverseSubtract -> GL_FUNC_REVERSE_SUBTRACT + Min -> GL_MIN + Max -> GL_MAX + +-- |Blending factors. +data BlendingFactor + = One + | Zero + | SrcColor + | NegativeSrcColor + | DestColor + | NegativeDestColor + | SrcAlpha + | NegativeSrcAlpha + | DstAlpha + | NegativeDstAlpha + -- | ConstantColor + -- | NegativeConstantColor + -- | ConstantAlpha + -- | NegativeConstantAlpha + | SrcAlphaSaturate + deriving (Eq,Show) + +fromBlendingFactor :: BlendingFactor -> GLenum +fromBlendingFactor f = case f of + One -> GL_ONE + Zero -> GL_ZERO + SrcColor -> GL_SRC_COLOR + NegativeSrcColor -> GL_ONE_MINUS_SRC_COLOR + DestColor -> GL_DST_COLOR + NegativeDestColor -> GL_ONE_MINUS_DST_COLOR + SrcAlpha -> GL_SRC_ALPHA + NegativeSrcAlpha -> GL_ONE_MINUS_SRC_ALPHA + DstAlpha -> GL_DST_ALPHA + NegativeDstAlpha -> GL_ONE_MINUS_DST_ALPHA + -- ConstantColor -> GL_CONSTANT_COLOR + -- NegativeConstantColor -> GL_ONE_MINUS_CONSTANT_COLOR + -- ConstantAlpha -> GL_CONSTANT_ALPHA + -- NegativeConstantAlpha -> GL_ONE_MINUS_CONSTANT_ALPHA + SrcAlphaSaturate -> GL_SRC_ALPHA_SATURATE + +-- Sets blending mode and both factors after having initialized the blending if something is +-- passed. If 'Nothing', that function disables the blending. +setBlending :: (MonadIO m) => Maybe (BlendingMode,BlendingFactor,BlendingFactor) -> m () +setBlending blending = liftIO $ case blending of + Just (mode,src,dst) -> do + glEnable GL_BLEND + glBlendEquation (fromBlendingMode mode) + glBlendFunc (fromBlendingFactor src) (fromBlendingFactor dst) + Nothing -> glDisable GL_BLEND diff --git a/src/Graphics/Luminance/Core/Buffer.hs b/src/Graphics/Luminance/Core/Buffer.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Luminance/Core/Buffer.hs @@ -0,0 +1,165 @@ +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2015 Dimitri Sabadie +-- License : BSD3 +-- +-- Maintainer : Dimitri Sabadie +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- + +module Graphics.Luminance.Core.Buffer where + +import Control.Monad.IO.Class ( MonadIO(..) ) +import Control.Monad.RWS ( RWS, ask, get, evalRWS, execRWS, put ) +import Control.Monad.Trans.Resource ( MonadResource, register ) +import Data.Bits ( (.|.) ) +import Data.Foldable ( toList ) +import Data.Word ( Word32 ) +import Foreign.Marshal.Alloc ( alloca ) +import Foreign.Marshal.Array ( peekArray, pokeArray ) +import Foreign.Marshal.Utils ( with ) +import Foreign.Ptr ( Ptr, castPtr, nullPtr, plusPtr ) +import Foreign.Storable ( Storable(..) ) +import Graphics.GL +import Graphics.Luminance.Core.RW + +-- |A 'Buffer' is an opaque and untyped region of abstract GPU memory. You cannot do much with it +-- and you might even not see the type in the user interface as it’s not really needed. It’s shown +-- for informational purposes only. +newtype Buffer = Buffer { bufferID :: GLuint } deriving (Eq,Show) + +-- Create a new 'Buffer' and return its GPU address by mapping it to a @Ptr ()@. +mkBuffer :: (MonadIO m,MonadResource m) + => GLbitfield + -> Word32 + -> m (Buffer,Ptr ()) +mkBuffer flags size = do + (bid,mapped) <- liftIO . alloca $ \p -> do + glCreateBuffers 1 p + bid <- peek p + mapped <- createStorage bid flags size + pure (bid,mapped) + _ <- register . with bid $ glDeleteBuffers 1 + pure (Buffer bid,mapped) + +-- Create the required OpenGL storage for a 'Buffer'. +createStorage :: GLuint -> GLbitfield -> Word32 -> IO (Ptr ()) +createStorage bid flags size = do + glNamedBufferStorage bid bytes nullPtr flags + ptr <- glMapNamedBufferRange bid 0 bytes flags + pure ptr + where + bytes = fromIntegral size + +-- |Create a new 'Buffer' using regions through the 'BuildRegion' monadic type. The 'Buffer' is +-- returned as well as the computed 'a' value in the 'BuildRegion'. +-- +-- Typically, the user will wrap the 'Region' in the 'a' type. +mkBufferWithRegions :: (MonadIO m,MonadResource m) + => GLbitfield + -> BuildRegion rw a + -> m (a,Buffer) +mkBufferWithRegions flags buildRegions = do + (buffer,mapped) <- mkBuffer flags bytes + pure (fst $ evalRWS built mapped 0,buffer) + where + built = runBuildRegion buildRegions + (bytes,_) = execRWS built nullPtr 0 + +-- |'Buffer'’s 'Region's can have reads and writes. That typeclass makes implements all possible +-- cases. +class BufferRW rw where + bufferFlagsFromRW :: rw -> GLenum + +instance BufferRW R where + bufferFlagsFromRW _ = GL_MAP_READ_BIT + +instance BufferRW RW where + bufferFlagsFromRW _ = GL_MAP_READ_BIT .|. GL_MAP_WRITE_BIT + +instance BufferRW W where + bufferFlagsFromRW _ = GL_MAP_WRITE_BIT + +-- |Create a new 'Buffer' and expose 'Region's. Through the 'BuildRegion' type, you can yield new +-- regions and embed them in the type of your choice. The function returns that type. +createBuffer :: forall a m rw. (BufferRW rw,MonadIO m,MonadResource m) + => BuildRegion rw a + -> m a +createBuffer = fmap fst . mkBufferWithRegions (bufferFlagsFromRW (undefined :: rw) .|. GL_MAP_PERSISTENT_BIT .|. GL_MAP_COHERENT_BIT) + +-- Special case of 'createBuffer', returning the 'Buffer' in addition for internal uses. +createBuffer_ :: forall a m rw. (BufferRW rw,MonadIO m,MonadResource m) + => BuildRegion rw a + -> m (a,Buffer) +createBuffer_ = mkBufferWithRegions $ + bufferFlagsFromRW (undefined :: rw) .|. GL_MAP_PERSISTENT_BIT .|. GL_MAP_COHERENT_BIT + +-- |A 'Region' is a GPU typed memory area. It can be pictured as a GPU array. +data Region rw a = Region { + regionPtr :: Ptr a + , regionSize :: RegionSize a + } deriving (Eq,Show) + +-- FIXME: do we really need that?! +-- |Size of a region, in elements. You don’t have to worry about bytes consideration. If you want +-- a @Region rw Float@ with 10 elements in it, use @RegionSize 10@. That’s as simple as that. +newtype RegionSize a = RegionSize Word32 deriving (Eq,Num,Show) + +-- Get the size in bytes of a 'RegionSize'. +bytesOfR :: forall a. (Storable a) => RegionSize a -> Word32 +bytesOfR (RegionSize size) = fromIntegral (sizeOf (undefined :: a)) * size + +-- |Convenient type to build 'Region's. +newtype BuildRegion rw a = BuildRegion { + runBuildRegion :: RWS (Ptr ()) () Word32 a + } deriving (Applicative,Functor,Monad) + +-- |Create a new 'Region' by providing the number of wished elements. +newRegion :: forall rw a. (Storable a) => Word32 -> BuildRegion rw (Region rw a) +newRegion size = BuildRegion $ do + offset <- get + put $ offset + bytesOfR regionS + ptr <- ask + pure $ Region (castPtr $ ptr `plusPtr` fromIntegral offset) regionS + where + regionS :: RegionSize a + regionS = RegionSize size + +-- |Read a whole 'Region'. +readWhole :: (MonadIO m,Readable r,Storable a) => Region r a -> m [a] +readWhole (Region p (RegionSize nb)) = liftIO $ peekArray (fromIntegral nb) p + +-- |Write the whole 'Region'. If value are missing, only the provided values will replace the +-- existing ones. If there are more values than the size of the 'Region', they are ignored. +writeWhole :: (Foldable f,MonadIO m,Storable a,Writable w) + => Region w a + -> f a + -> m () +writeWhole (Region p (RegionSize nb)) values = + liftIO . pokeArray p . take (fromIntegral nb) $ toList values + +-- |Fill a 'Region' with a value. +fill :: (MonadIO m,Storable a,Writable w) => Region w a -> a -> m () +fill (Region p (RegionSize nb)) a = + liftIO . pokeArray p $ replicate (fromIntegral nb) a + +-- |Index getter. Bounds checking is performed and returns 'Nothing' if out of bounds. +(@?) :: (MonadIO m,Storable a,Readable r) => Region r a -> Word32 -> m (Maybe a) +Region p (RegionSize nb) @? i + | i >= nb = pure Nothing + | otherwise = liftIO $ Just <$> peekElemOff p (fromIntegral i) + +-- |Index getter. Unsafe version of '(@?)'. +(@!) :: (MonadIO m,Storable a,Readable r) => Region r a -> Word32 -> m a +Region p _ @! i = liftIO $ peekElemOff p (fromIntegral i) + +-- |Index setter. Bounds checking is performed and nothing is done if out of bounds. +writeAt :: (MonadIO m,Storable a,Writable w) => Region w a -> Word32 -> a -> m () +writeAt (Region p (RegionSize nb)) i a + | i >= nb = pure () + | otherwise = liftIO $ pokeElemOff p (fromIntegral i) a + +-- |Index setter. Unsafe version of 'writeAt''. +writeAt' :: (MonadIO m,Storable a,Writable w) => Region w a -> Word32 -> a -> m () +writeAt' (Region p _) i a = liftIO $ pokeElemOff p (fromIntegral i) a diff --git a/src/Graphics/Luminance/Core/Cmd.hs b/src/Graphics/Luminance/Core/Cmd.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Luminance/Core/Cmd.hs @@ -0,0 +1,51 @@ +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2015 Dimitri Sabadie +-- License : BSD3 +-- +-- Maintainer : Dimitri Sabadie +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- + +module Graphics.Luminance.Core.Cmd where + +import Control.Monad.IO.Class ( MonadIO(..) ) +import Graphics.Luminance.Core.Batch +import Graphics.Luminance.Core.Framebuffer +import Graphics.Luminance.Core.RW ( Readable, Writable ) +import Graphics.Luminance.Core.Texture ( Filter ) +import Numeric.Natural ( Natural ) + +-- |Command type. Used to accumulate GPU commands. Use 'runCmd' to execute +-- the whole chain of commands. +newtype Cmd a = Cmd (IO a) deriving (Applicative,Functor,Monad) + +runCmd :: (MonadIO m) => Cmd a -> m a +runCmd (Cmd a) = liftIO a + +-- |Draw a framebuffer batch and return the framebuffer’s output. +draw :: FBBatch rw c d -> Cmd (Output c d) +draw fbb = Cmd $ do + runFBBatch fbb + pure . framebufferOutput $ fbBatchFramebuffer fbb + +-- |Blit a framebuffer batch onto a framebuffer and return the framebuffer’s output of the write +-- framebuffer. +blit :: (Readable r,Writable w) + => Framebuffer r c0 d0 + -> Framebuffer w c1 d1 + -> Int + -> Int + -> Natural + -> Natural + -> Int + -> Int + -> Natural + -> Natural + -> FramebufferBlitMask + -> Filter + -> Cmd (Output c1 d1) +blit r w rx ry rwidth rheight wx wy wwidth wheight mask flt = Cmd $ do + framebufferBlit r w rx ry rwidth rheight wx wy wwidth wheight mask flt + pure (framebufferOutput w) diff --git a/src/Graphics/Luminance/Core/Debug.hs b/src/Graphics/Luminance/Core/Debug.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Luminance/Core/Debug.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2015 Dimitri Sabadie +-- License : BSD3 +-- +-- Maintainer : Dimitri Sabadie +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- + +module Graphics.Luminance.Core.Debug where + +import Control.Monad ( unless ) +import Control.Monad.IO.Class ( MonadIO(..) ) +#if DEBUG_GL +import Data.Foldable ( traverse_ ) +#endif +import Graphics.GL + +-------------------------------------------------------------------------------- +-- Clearing errors ------------------------------------------------------------- + +-- Clear OpenGL errors until we get GL_NO_ERROR. +clearGLError :: (MonadIO m) => m () +clearGLError = do + e <- liftIO glGetError + unless (e == GL_NO_ERROR) clearGLError + +-------------------------------------------------------------------------------- +-- OpenGL errors --------------------------------------------------------------- + +-- |OpenGL error type. +data GLError + = InvalidEnum + | InvalidValue + | InvalidOperation + | InvalidFramebufferOperation + | OutOfMemory + | StackUnderflow + | StackOverflow + deriving (Eq,Show) + +fromGLError :: GLError -> GLenum +fromGLError e = case e of + InvalidEnum -> GL_INVALID_ENUM + InvalidValue -> GL_INVALID_VALUE + InvalidOperation -> GL_INVALID_OPERATION + InvalidFramebufferOperation -> GL_INVALID_FRAMEBUFFER_OPERATION + OutOfMemory -> GL_OUT_OF_MEMORY + StackUnderflow -> GL_STACK_UNDERFLOW + StackOverflow -> GL_STACK_OVERFLOW + +toGLError :: GLenum -> Maybe GLError +toGLError e = case e of + GL_INVALID_ENUM -> Just InvalidEnum + GL_INVALID_VALUE -> Just InvalidValue + GL_INVALID_OPERATION -> Just InvalidOperation + GL_INVALID_FRAMEBUFFER_OPERATION -> Just InvalidFramebufferOperation + GL_OUT_OF_MEMORY -> Just OutOfMemory + GL_STACK_UNDERFLOW -> Just StackUnderflow + GL_STACK_OVERFLOW -> Just StackOverflow + _ -> Nothing + +-- |Given a context 'String' and an action, that function clears the OpenGL errors in order to run +-- the action in a sane and error-free OpenGL context. If an error has occured, print it on 'stderr' +-- along with the 'String' context. Otherwise, simply it returns the action’s result. +-- +-- Keep in mind that you can mute that function’s implementation by disabling the cabal flag +-- 'debug-gl', which is the default setting. +debugGL :: (MonadIO m) => String -> m a -> m a +#if DEBUG_GL +debugGL ctx gl = do + clearGLError + a <- gl + liftIO $ fmap toGLError glGetError >>= traverse_ (\e -> putStrLn ctx >> print e) + pure a +#else +debugGL _ = id +#endif diff --git a/src/Graphics/Luminance/Core/Framebuffer.hs b/src/Graphics/Luminance/Core/Framebuffer.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Luminance/Core/Framebuffer.hs @@ -0,0 +1,309 @@ +{-# LANGUAGE UndecidableInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2015 Dimitri Sabadie +-- License : BSD3 +-- +-- Maintainer : Dimitri Sabadie +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- + +module Graphics.Luminance.Core.Framebuffer where + +import Control.Monad ( unless ) +import Control.Monad.Except ( MonadError(..) ) +import Control.Monad.IO.Class ( MonadIO(..) ) +import Control.Monad.Trans.Resource ( MonadResource, register ) +import Data.Bits ( (.|.) ) +import Data.Proxy ( Proxy(..) ) +import Foreign.Marshal.Alloc ( alloca ) +import Foreign.Marshal.Array ( withArrayLen ) +import Foreign.Marshal.Utils ( with ) +import Foreign.Storable ( peek ) +import Graphics.GL +import Graphics.Luminance.Core.Debug +import Graphics.Luminance.Core.Pixel +import Graphics.Luminance.Core.Renderbuffer ( createRenderbuffer, renderbufferID ) +import Graphics.Luminance.Core.RW +import Graphics.Luminance.Core.Texture +import Graphics.Luminance.Core.Tuple +import Numeric.Natural ( Natural ) + +--------------------------------------------------------------------------------- +-- Framebuffer ------------------------------------------------------------------ + +-- |A 'Framebuffer' represents two buffers: a /color/ buffer and /depth/ buffer. +-- You can select which one you want and specify the formats to use by providing 'Pixel' +-- types. If you want to mute a buffer, use '()'. +data Framebuffer rw c d = Framebuffer { + framebufferID :: GLuint + , framebufferOutput :: Output c d + } + +-- |A 'Framebuffer' with the /depth/ buffer muted. +type ColorFramebuffer rw c = Framebuffer rw c () + +-- |A 'Framebuffer' with the /color/ buffer muted. Can be used to implement fast pre-passes. +type DepthFramebuffer rw d = Framebuffer rw () d + +-- |@'createFramebuffer' w h mipmaps@ creates a new 'Framebuffer' with dimension @w * h@ and +-- allocating spaces for @mipmaps@ level of textures. The textures are created by providing a +-- correct type. +-- +-- For the color part, you can pass either: +-- +-- - '()': that will mute the color buffer of the framebuffer; +-- - @'Format' t c@: that will create a single texture with the wished color format; +-- - or @a ':.' b@: that will create a chain of textures; 'a' and 'b' cannot be '()'. +-- +-- For the depth part, you can pass either: +-- +-- - '()': that will mute the depth buffer of the framebuffer; +-- - @'Format' t c@: that will create a single texture with the wished depth format. +-- +-- Finally, the @rw@ parameter can be set to 'R', 'W' or 'RW' to specify which kind of framebuffer +-- access you’ll need. +createFramebuffer :: forall c d e m rw. (HasFramebufferError e,MonadError e m,MonadIO m,MonadResource m,FramebufferColorAttachment c,FramebufferColorRW rw,FramebufferDepthAttachment d,FramebufferTarget rw) + => Natural + -> Natural + -> Natural + -> m (Framebuffer rw c d) +createFramebuffer w h mipmaps = do + fid <- liftIO . alloca $ \p -> do + debugGL "createFramebuffer" $ glCreateFramebuffers 1 p + peek p + (colorOutputNb,colorTexs) <- addColorOutput fid 0 w h mipmaps (Proxy :: Proxy c) + (hasDepthOutput,depthTex) <- addDepthOutput fid w h mipmaps (Proxy :: Proxy d) + setColorBuffers fid colorOutputNb (Proxy :: Proxy rw) + unless hasDepthOutput $ setDepthRenderbuffer fid w h + _ <- register . with fid $ glDeleteFramebuffers 1 + status <- glCheckNamedFramebufferStatus fid $ framebufferTarget (Proxy :: Proxy rw) + if + | status == GL_FRAMEBUFFER_COMPLETE -> pure $ Framebuffer fid (Output colorTexs depthTex) + | otherwise -> throwError . fromFramebufferError . IncompleteFramebuffer $ translateFramebufferStatus status + +-- Translate OpenGL framebuffer status into human readable versions. +translateFramebufferStatus :: GLenum -> String +translateFramebufferStatus status = case status of + GL_FRAMEBUFFER_UNDEFINED -> "undefined default read or write framebuffer" + GL_FRAMEBUFFER_INCOMPLETE_ATTACHMENT -> "incomplete attachment" + GL_FRAMEBUFFER_INCOMPLETE_MISSING_ATTACHMENT -> "missing image attachment" + GL_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER -> "incomplete draw buffer" + GL_FRAMEBUFFER_INCOMPLETE_READ_BUFFER -> "incomplete read buffer" + GL_FRAMEBUFFER_UNSUPPORTED -> "unsupported (internal) format(s)" + GL_FRAMEBUFFER_INCOMPLETE_MULTISAMPLE -> "incomplete multisample configuration" + GL_FRAMEBUFFER_INCOMPLETE_LAYER_TARGETS -> "layered attachment mismatch" + _ -> "unknown error" + +-------------------------------------------------------------------------------- +-- Framebuffer attachment ------------------------------------------------------ + +-- Framebuffer attachment. +data Attachment + = ColorAttachment Natural + | DepthAttachment + deriving (Eq,Ord,Show) + +fromAttachment :: (Eq a,Num a) => Attachment -> a +fromAttachment a = case a of + ColorAttachment i -> GL_COLOR_ATTACHMENT0 + fromIntegral i + DepthAttachment -> GL_DEPTH_ATTACHMENT + +-------------------------------------------------------------------------------- +-- Framebuffer color attachment ------------------------------------------------ + +-- |Typeclass of possible framebuffer color attachments. +class FramebufferColorAttachment c where + addColorOutput :: (MonadIO m,MonadResource m) + => GLuint + -> Natural + -> Natural + -> Natural + -> Natural + -> proxy c + -> m (Natural,TexturizeFormat c) + +instance FramebufferColorAttachment () where + addColorOutput _ _ _ _ _ _ = pure (0,()) + +instance (ColorPixel (Format t c)) => FramebufferColorAttachment (Format t c) where + addColorOutput fid ca w h mipmaps proxy = + fmap (1,) $ addOutput fid (ColorAttachment ca) w h mipmaps proxy + +instance (ColorPixel a,ColorPixel b,FramebufferColorAttachment a,FramebufferColorAttachment b) => FramebufferColorAttachment (a :. b) where + addColorOutput fid ca w h mipmaps _ = do + (d0,tex0) <- addColorOutput fid ca w h mipmaps (Proxy :: Proxy a) + (d1,tex1) <- addColorOutput fid (succ ca) w h mipmaps (Proxy :: Proxy b) + pure $ (d0 + d1,tex0 :. tex1) + +-- Given the maximum number of attachments in a color attachment, retrieve the list of OpenGL +-- enumerations to represent all the color buffers. +colorAttachmentsFromMax :: Natural -> [GLenum] +colorAttachmentsFromMax m = [fromAttachment (ColorAttachment a) | a <- [0..m-1]] + +-- Set the OpenGL color buffers. +setColorBuffers :: forall m proxy rw. (FramebufferColorRW rw,MonadIO m) + => GLuint + -> Natural + -> proxy rw + -> m () +setColorBuffers fid colorOutputNb _ = case colorOutputNb of + 0 -> do + -- disable color outputs + debugGL "setColorBuffers 1" $ glNamedFramebufferDrawBuffer fid GL_NONE + debugGL "setColorBuffers 2" $ glNamedFramebufferReadBuffer fid GL_NONE + _ -> setFramebufferColorRW fid colorOutputNb (Proxy :: Proxy rw) + +-------------------------------------------------------------------------------- +-- Framebuffer depth attachment ------------------------------------------------ + +-- |Typeclass of possible framebuffer depth attachments. +class FramebufferDepthAttachment d where + addDepthOutput :: (MonadIO m,MonadResource m) + => GLuint + -> Natural + -> Natural + -> Natural + -> proxy d + -> m (Bool,TexturizeFormat d) + +instance FramebufferDepthAttachment () where + addDepthOutput _ _ _ _ _ = pure (False,()) + +instance (Pixel (Format t (CDepth d))) => FramebufferDepthAttachment (Format t (CDepth d)) where + addDepthOutput fid w h mipmaps proxy = fmap (True,) $ addOutput fid DepthAttachment w h mipmaps proxy + +-- Create a renderbuffer used to mute depth information and link it to a framebuffer. +setDepthRenderbuffer :: (MonadIO m,MonadResource m) + => GLuint + -> Natural + -> Natural + -> m () +setDepthRenderbuffer fid w h = do + renderbuffer <- createRenderbuffer w h (Proxy :: Proxy Depth32F) + debugGL "setDepthRenderBuffer" $ glNamedFramebufferRenderbuffer fid (fromAttachment DepthAttachment) GL_RENDERBUFFER + (renderbufferID renderbuffer) + +-------------------------------------------------------------------------------- +-- Framebuffer color read/write configuration ---------------------------------- + +-- |Typeclass used to implement read/write operation per color attachment. +class FramebufferColorRW rw where + setFramebufferColorRW :: (MonadIO m) => GLuint -> Natural -> proxy rw -> m () + +instance FramebufferColorRW W where + setFramebufferColorRW fid nb _ = liftIO $ do + withArrayLen (colorAttachmentsFromMax nb) $ \n buffers -> + debugGL "setFramebufferColorRW[W]" $ glNamedFramebufferDrawBuffers fid (fromIntegral n) buffers + +instance FramebufferColorRW RW where + setFramebufferColorRW fid nb _ = liftIO $ do + withArrayLen (colorAttachmentsFromMax nb) $ \n buffers -> + debugGL "setFramebufferColorRW[RW]" $ glNamedFramebufferDrawBuffers fid (fromIntegral n) buffers + +-------------------------------------------------------------------------------- +-- Framebuffer read/write target configuration --------------------------------- + +-- |Framebuffer representation of 'R', 'W' and 'RW'. +class FramebufferTarget rw where + framebufferTarget :: proxy rw -> GLenum + +instance FramebufferTarget R where + framebufferTarget _ = GL_READ_FRAMEBUFFER + +instance FramebufferTarget W where + framebufferTarget _ = GL_DRAW_FRAMEBUFFER + +instance FramebufferTarget RW where + framebufferTarget _ = GL_FRAMEBUFFER + +-------------------------------------------------------------------------------- +-- Framebuffer outputs --------------------------------------------------------- + +-- Create a new texture and link it to the framebuffer. +addOutput :: forall m p proxy. (MonadIO m,MonadResource m,Pixel p) + => GLuint + -> Attachment + -> Natural + -> Natural + -> Natural + -> proxy p + -> m (Texture2D p) +addOutput fid ca w h mipmaps _ = do + tex :: Texture2D p <- createTexture w h mipmaps defaultSampling + debugGL "addOutput" . liftIO $ glNamedFramebufferTexture fid (fromAttachment ca) + (textureID tex) 0 + pure tex + +-------------------------------------------------------------------------------- +-- Framebuffer textures accessors ---------------------------------------------- + +-- |Given a 'Format', inject it into a 'Texture2D' to handle it. +type family TexturizeFormat a :: * where + TexturizeFormat () = () + TexturizeFormat (Format t c) = Texture2D (Format t c) + TexturizeFormat (a :. b) = TexturizeFormat a :. TexturizeFormat b + +-- |Framebuffer output. +data Output c d = Output (TexturizeFormat c) (TexturizeFormat d) + +-------------------------------------------------------------------------------- +-- Framebuffer blitting -------------------------------------------------------- + +-- |Mask for framebuffer blit operation. +data FramebufferBlitMask + = BlitColor + | BlitDepth + | BlitBoth + deriving (Eq,Show) + +fromFramebufferBlitMask :: FramebufferBlitMask -> GLbitfield +fromFramebufferBlitMask mask = case mask of + BlitColor -> GL_COLOR_BUFFER_BIT + BlitDepth -> GL_DEPTH_BUFFER_BIT + BlitBoth -> GL_COLOR_BUFFER_BIT .|. GL_DEPTH_BUFFER_BIT + +-- Blit two framebuffers. +framebufferBlit :: (MonadIO m,Readable r,Writable w) + => Framebuffer r c d + -> Framebuffer w c' d' + -> Int + -> Int + -> Natural + -> Natural + -> Int + -> Int + -> Natural + -> Natural + -> FramebufferBlitMask + -> Filter + -> m () +framebufferBlit src dst srcX srcY srcW srcH dstX dstY dstW dstH mask flt = liftIO . debugGL "blit" $ + glBlitNamedFramebuffer (framebufferID src) (framebufferID dst) srcX0 srcY0 srcX1 srcY1 dstX0 + dstY0 dstX1 dstY1 (fromFramebufferBlitMask mask) (fromFilter flt) + where + srcX0 = fromIntegral srcX + srcY0 = fromIntegral srcY + srcX1 = srcX0 + fromIntegral srcW + srcY1 = srcY0 + fromIntegral srcH + dstX0 = fromIntegral dstX + dstY0 = fromIntegral dstY + dstX1 = dstX0 + fromIntegral dstW + dstY1 = dstY0 + fromIntegral dstH + +-------------------------------------------------------------------------------- +-- Special framebuffers -------------------------------------------------------- + +-- |The default 'Framebuffer' represents the screen (back buffer with double buffering). +defaultFramebuffer :: Framebuffer RW () () +defaultFramebuffer = Framebuffer 0 (Output () ()) + +--------------------------------------------------------------------------------- +-- Framebuffer errors ----------------------------------------------------------- + +newtype FramebufferError = IncompleteFramebuffer String deriving (Eq,Show) + +class HasFramebufferError a where + fromFramebufferError :: FramebufferError -> a diff --git a/src/Graphics/Luminance/Core/Geometry.hs b/src/Graphics/Luminance/Core/Geometry.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Luminance/Core/Geometry.hs @@ -0,0 +1,97 @@ +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2015 Dimitri Sabadie +-- License : BSD3 +-- +-- Maintainer : Dimitri Sabadie +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- + +module Graphics.Luminance.Core.Geometry where + +import Control.Monad.IO.Class ( MonadIO(..) ) +import Control.Monad.Trans.Resource ( MonadResource, register ) +import Data.Proxy ( Proxy(..) ) +import Data.Word ( Word32 ) +import Foreign.Marshal.Alloc ( alloca ) +import Foreign.Marshal.Utils ( with ) +import Foreign.Storable ( Storable(..) ) +import Graphics.GL +import Graphics.Luminance.Core.Buffer +import Graphics.Luminance.Core.RW ( W ) +import Graphics.Luminance.Core.Vertex + +-- OpenGL vertex array. Used as a shared type for embedding in most complex 'Geometry' type. +data VertexArray = VertexArray { + vertexArrayID :: GLuint + , vertexArrayMode :: GLenum + , vertexArrayCount :: GLsizei + } deriving (Eq,Show) + +-- |A 'Geometry' represents a GPU version of a mesh; that is, vertices attached with indices and a +-- geometry mode. You can have 'Geometry' in two flavours: +-- +-- - *direct geometry*: doesn’t require any indices as all vertices are unique and in the right +-- order to connect vertices between each other ; +-- - *indexed geometry*: requires indices to know how to connect and share vertices between each +-- other. +data Geometry + = DirectGeometry VertexArray + | IndexedGeometry VertexArray + deriving (Eq,Show) + +-- |The 'GeometryMode' is used to specify how vertices should be connected between each other. +-- +-- A 'Point' mode won’t connect vertices at all and will leave them as a vertices cloud. +-- +-- A 'Line' mode will connect vertices two-by-two. You then have to provide pairs of indices to +-- correctly connect vertices and form lines. +-- +-- A 'Triangle' mode will connect vertices three-by-three. You then have to provide triplets of +-- indices to correctly connect vertices and form triangles. +data GeometryMode + = Point + | Line + | Triangle + deriving (Eq,Show) + +fromGeometryMode :: GeometryMode -> GLenum +fromGeometryMode m = case m of + Point -> GL_POINTS + Line -> GL_LINES + Triangle -> GL_TRIANGLES + +-- |This function is the single one to create 'Geometry'. It takes a 'Foldable' type of vertices +-- used to provide the 'Geometry' with vertices and might take a 'Foldable' of indices ('Word32'). +-- If you don’t pass indices ('Nothing'), you end up with a *direct geometry*. Otherwise, you get an +-- *indexed geometry*. You also have to provide a 'GeometryMode' to state how you want the vertices +-- to be connected with each other. +createGeometry :: forall f m v. (Foldable f,MonadIO m,MonadResource m,Storable v,Vertex v) + => f v + -> Maybe (f Word32) + -> GeometryMode + -> m Geometry +createGeometry vertices indices mode = do + -- create the vertex array object (OpenGL-side) + vid <- liftIO . alloca $ \p -> do + glCreateVertexArrays 1 p + peek p + _ <- register . with vid $ glDeleteVertexArrays 1 + -- vertex buffer + (vreg :: Region W v,vbo) <- createBuffer_ $ newRegion (fromIntegral vertNb) + writeWhole vreg vertices + liftIO $ glVertexArrayVertexBuffer vid vertexBindingIndex (bufferID vbo) 0 (fromIntegral $ sizeOf (undefined :: v)) + setFormatV vid 0 (Proxy :: Proxy v) + -- element buffer, if required + case indices of + Just indices' -> do + (ireg :: Region W Word32,ibo) <- createBuffer_ $ newRegion (fromIntegral ixNb) + writeWhole ireg indices' + glVertexArrayElementBuffer vid (bufferID ibo) + pure . IndexedGeometry $ VertexArray vid mode' (fromIntegral ixNb) + Nothing -> pure . DirectGeometry $ VertexArray vid mode' (fromIntegral vertNb) + where + vertNb = length vertices + ixNb = length indices + mode' = fromGeometryMode mode diff --git a/src/Graphics/Luminance/Core/Pixel.hs b/src/Graphics/Luminance/Core/Pixel.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Luminance/Core/Pixel.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE UndecidableInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2015 Dimitri Sabadie +-- License : BSD3 +-- +-- Maintainer : Dimitri Sabadie +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- + +-- FIXME: #13 +module Graphics.Luminance.Core.Pixel where + +import Data.Proxy ( Proxy(..) ) +import Data.Word ( Word8 ) +import Graphics.GL + +-------------------------------------------------------------------------------- +-- Channel size ---------------------------------------------------------------- + +class ChannelSize c where + channelSize :: (Num size) => proxy c -> size + +-- |A 8-bit channel. +data C8 = C8 deriving (Eq,Ord,Show) + +instance ChannelSize C8 where + channelSize _ = 8 + +-- |A 16-bit channel. +data C16 = C16 deriving (Eq,Ord,Show) + +instance ChannelSize C16 where + channelSize _ = 16 + +-- |A 32-bit channel. +data C32 = C32 deriving (Eq,Ord,Show) + +instance ChannelSize C32 where + channelSize _ = 32 + +-------------------------------------------------------------------------------- +-- Channel type ---------------------------------------------------------------- + +class ChannelType t where + channelType :: proxy t -> GLenum + +-- |Channels are integral values. +data CInts = CInts deriving (Eq,Ord,Show) + +instance ChannelType CInts where + channelType _ = GL_INT + +-- |Channels are unsigned integral values. +data CUInts = CUInts deriving (Eq,Ord,Show) + +instance ChannelType CUInts where + channelType _ = GL_UNSIGNED_INT + +-- |Channels are floating values. +data CFloats = CFloats deriving (Eq,Ord,Show) + +instance ChannelType CFloats where + channelType _ = GL_FLOAT + +-------------------------------------------------------------------------------- +-- Channel shape --------------------------------------------------------------- + +-- |A red channel only. +data CR a = CR deriving (Eq,Ord,Show) + +-- |Rd and green channels. +data CRG a b = CRG deriving (Eq,Ord,Show) + +-- |Red, green and blue channels. +data CRGB a b c = CRGB deriving (Eq,Ord,Show) + +-- |Red, green, blue and alpha channels. +data CRGBA a b c d = CRGBA deriving (Eq,Ord,Show) + +-- |A depth channel. +data CDepth a = CDepth deriving (Eq,Ord,Show) + +-------------------------------------------------------------------------------- +-- Pixel format ---------------------------------------------------------------- + +-- |A pixel format. +data Format t c = Format deriving (Eq,Ord,Show) + +instance (ChannelType t) => ChannelType (Format t c) where + channelType _ = channelType (Proxy :: Proxy t) + +type RGB8UI = Format CUInts (CRGB C8 C8 C8) +type RGBA8UI = Format CUInts (CRGBA C8 C8 C8 C8) + +type RGBA8F = Format CFloats (CRGBA C8 C8 C8 C8) + +type RGB32F = Format CFloats (CRGB C32 C32 C32) +type RGBA32F = Format CFloats (CRGBA C32 C32 C32 C32) +type Depth32F = Format CFloats (CDepth C32) + +-------------------------------------------------------------------------------- +-- OpenGL pixels --------------------------------------------------------------- + +class Pixel f where + type PixelBase f :: * + pixelFormat :: p f -> GLenum + pixelIFormat :: p f -> GLenum + pixelType :: p f -> GLenum + +instance Pixel RGB8UI where + type PixelBase RGB8UI = Word8 + pixelFormat _ = GL_RGB_INTEGER + pixelIFormat _ = GL_RGB8UI + pixelType _ = GL_UNSIGNED_BYTE + +instance Pixel RGBA8UI where + type PixelBase RGBA8UI = Word8 + pixelFormat _ = GL_RGBA_INTEGER + pixelIFormat _ = GL_RGBA8UI + pixelType _ = GL_UNSIGNED_BYTE + +instance Pixel RGB32F where + type PixelBase RGB32F = Float + pixelFormat _ = GL_RGB + pixelIFormat _ = GL_RGB32F + pixelType _ = GL_FLOAT + +instance Pixel RGBA32F where + type PixelBase RGBA32F = Float + pixelFormat _ = GL_RGBA + pixelIFormat _ = GL_RGBA32F + pixelType _ = GL_FLOAT + +instance Pixel Depth32F where + type PixelBase Depth32F = Float + pixelFormat _ = GL_DEPTH_COMPONENT + pixelIFormat _ = GL_DEPTH_COMPONENT32F + pixelType _ = GL_FLOAT + +-------------------------------------------------------------------------------- +-- Pixel kind ------------------------------------------------------------------ + +class (Pixel p) => ColorPixel p + +instance (Pixel (Format t (CR r))) => ColorPixel (Format t (CR r)) +instance (Pixel (Format t (CRG r g))) => ColorPixel (Format t (CRG r g)) +instance (Pixel (Format t (CRGB r g b))) => ColorPixel (Format t (CRGB r g b)) +instance (Pixel (Format t (CRGBA r g b a))) => ColorPixel (Format t (CRGBA r g b a)) diff --git a/src/Graphics/Luminance/Core/Query.hs b/src/Graphics/Luminance/Core/Query.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Luminance/Core/Query.hs @@ -0,0 +1,46 @@ +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2015 Dimitri Sabadie +-- License : BSD3 +-- +-- Maintainer : Dimitri Sabadie +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- + +module Graphics.Luminance.Core.Query where + +import Control.Monad ( (>=>) ) +import Control.Monad.IO.Class ( MonadIO(..) ) +import Data.Traversable ( for ) +import Foreign.Marshal.Alloc ( alloca ) +import Foreign.Storable ( peek ) +import Foreign.C.String ( peekCString ) +import Foreign.Ptr ( castPtr ) +import Graphics.GL + +-- Nicer version of 'glGetString'. +getString :: (MonadIO m) => GLenum -> m String +getString name = liftIO $ glGetString name >>= peekCString . castPtr + +-- |Get the OpenGL vendor 'String'. +getGLVendor :: (MonadIO m) => m String +getGLVendor = getString GL_VENDOR + +-- |Get the OpenGL renderer 'String'. +getGLRenderer :: (MonadIO m) => m String +getGLRenderer = getString GL_RENDERER + +-- |Get the OpenGL version 'String'. +getGLVersion :: (MonadIO m) => m String +getGLVersion = getString GL_VERSION + +-- |Get the GLSL version 'String'. +getGLSLVersion :: (MonadIO m) => m String +getGLSLVersion = getString GL_SHADING_LANGUAGE_VERSION + +-- |Retrieve all the supported OpenGL extensions as 'String's. +getGLExtensions :: (MonadIO m) => m [String] +getGLExtensions = liftIO $ do + num <- alloca $ \num -> glGetIntegerv GL_NUM_EXTENSIONS num >> peek num + for [0..fromIntegral num - 1] $ glGetStringi GL_EXTENSIONS >=> peekCString . castPtr diff --git a/src/Graphics/Luminance/Core/RW.hs b/src/Graphics/Luminance/Core/RW.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Luminance/Core/RW.hs @@ -0,0 +1,33 @@ +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2015 Dimitri Sabadie +-- License : BSD3 +-- +-- Maintainer : Dimitri Sabadie +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- + +module Graphics.Luminance.Core.RW where + +-- |Readable typeclass, for types that admit reads. +class Readable r where + +-- |Writable typeclass, for types that admit writes. +class Writable w where + +-- |Read-only type. +data R = R deriving (Eq,Ord,Show) + +instance Readable R + +-- |Write-only type. +data W = W deriving (Eq,Ord,Show) + +instance Writable W + +-- |Read-write type. +data RW = RW deriving (Eq,Ord,Show) + +instance Readable RW +instance Writable RW diff --git a/src/Graphics/Luminance/Core/RenderCmd.hs b/src/Graphics/Luminance/Core/RenderCmd.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Luminance/Core/RenderCmd.hs @@ -0,0 +1,31 @@ +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2015 Dimitri Sabadie +-- License : BSD3 +-- +-- Maintainer : Dimitri Sabadie +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- + +module Graphics.Luminance.Core.RenderCmd where + +import Graphics.Luminance.Core.Blending +import Graphics.Luminance.Core.Shader.Uniform ( U(..) ) + +-- FIXME: we need to make a tighter link between c and blending and between d and the depth test. +data RenderCmd rw c d u a = RenderCmd (Maybe (BlendingMode,BlendingFactor,BlendingFactor)) Bool (U u) u a + +instance Functor (RenderCmd rw c d u) where + fmap f (RenderCmd blending depthTest uni u a) = RenderCmd blending depthTest uni u (f a) + +renderCmd :: Maybe (BlendingMode,BlendingFactor,BlendingFactor) + -> Bool + -> U u + -> u + -> a + -> RenderCmd rw c d u a +renderCmd = RenderCmd + +stdRenderCmd :: U u -> u -> a -> RenderCmd rw c d u a +stdRenderCmd = RenderCmd Nothing True diff --git a/src/Graphics/Luminance/Core/Renderbuffer.hs b/src/Graphics/Luminance/Core/Renderbuffer.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Luminance/Core/Renderbuffer.hs @@ -0,0 +1,33 @@ +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2015 Dimitri Sabadie +-- License : BSD3 +-- +-- Maintainer : Dimitri Sabadie +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- + +module Graphics.Luminance.Core.Renderbuffer where + +import Control.Monad.IO.Class ( MonadIO(..) ) +import Control.Monad.Trans.Resource ( MonadResource, register ) +import Data.Proxy ( Proxy ) +import Foreign.Marshal.Alloc ( alloca ) +import Foreign.Marshal.Utils ( with ) +import Foreign.Storable ( peek ) +import Graphics.GL +import Graphics.Luminance.Core.Pixel ( Pixel(pixelIFormat) ) +import Numeric.Natural ( Natural ) + +newtype Renderbuffer = Renderbuffer { renderbufferID :: GLuint } deriving (Eq,Show) + +createRenderbuffer :: (MonadIO m,MonadResource m,Pixel f) => Natural -> Natural -> Proxy f -> m Renderbuffer +createRenderbuffer w h depthProxy = do + rid <- liftIO . alloca $ \p -> do + glCreateRenderbuffers 1 p + rid <- peek p + glNamedRenderbufferStorage rid (pixelIFormat depthProxy) (fromIntegral w) (fromIntegral h) + pure rid + _ <- register . with rid $ glDeleteRenderbuffers 1 + pure $ Renderbuffer rid diff --git a/src/Graphics/Luminance/Core/Shader/Program.hs b/src/Graphics/Luminance/Core/Shader/Program.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Luminance/Core/Shader/Program.hs @@ -0,0 +1,127 @@ +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2015 Dimitri Sabadie +-- License : BSD3 +-- +-- Maintainer : Dimitri Sabadie +-- Stability : experimental +-- Portability : portable +---------------------------------------------------------------------------- + +module Graphics.Luminance.Core.Shader.Program where + +import Control.Applicative ( liftA2 ) +import Control.Monad.Except ( MonadError(throwError) ) +import Control.Monad.IO.Class ( MonadIO(..) ) +import Control.Monad.Trans.Resource ( MonadResource, register ) +import Data.Foldable ( traverse_ ) +import Foreign.C ( peekCString, withCString ) +import Foreign.Marshal.Alloc ( alloca ) +import Foreign.Marshal.Array ( allocaArray ) +import Foreign.Ptr ( castPtr, nullPtr ) +import Foreign.Storable ( peek ) +import Graphics.Luminance.Core.Shader.Stage ( Stage(..) ) +import Graphics.Luminance.Core.Shader.Uniform ( U, Uniform(..) ) +import Graphics.GL +import Numeric.Natural ( Natural ) + +-------------------------------------------------------------------------------- +-- Shader program -------------------------------------------------------------- + +-- |Shader program. +newtype Program = Program { programID :: GLuint } + +-- |Create a new shader 'Program'. +-- +-- That function takes a list of 'Stage's and a uniform interface builder function and yields a +-- 'Program' and the interface. +-- +-- The builder function takes a function you can use to retrieve uniforms. You can pass +-- 'Left name' to map a 'String' to a uniform or you can pass 'Right sem' to map a semantic +-- 'Natural' to a uniform. If the uniform can’t be retrieved, throws 'InactiveUniform'. +-- +-- In the end, you get the new 'Program' and a polymorphic value you can choose the type of in +-- the function you pass as argument. You can use that value to gather uniforms for instance. +createProgram :: (HasProgramError e,MonadError e m,MonadIO m,MonadResource m) + => [Stage] + -> ((forall a. (Uniform a) => Either String Natural -> m (U a)) -> m i) + -> m (Program,i) +createProgram stages buildIface = do + (pid,linked,cl) <- liftIO $ do + pid <- glCreateProgram + traverse_ (glAttachShader pid . stageID) stages + glLinkProgram pid + linked <- isLinked pid + ll <- clogLength pid + cl <- clog ll pid + pure (pid,linked,cl) + if + | linked -> do + _ <- register $ glDeleteProgram pid + let prog = Program pid + iface <- buildIface $ ifaceWith prog + pure (prog,iface) + | otherwise -> throwError . fromProgramError $ LinkFailed cl + +-- |A simpler version of 'createProgram'. That function assumes you don’t need a uniform interface +-- and then just returns the 'Program'. +createProgram_ :: (HasProgramError e,MonadError e m,MonadIO m,MonadResource m) + => [Stage] + -> m Program +createProgram_ stages = fmap fst $ createProgram stages (\_ -> pure ()) + +-- |Is a shader program linked? +isLinked :: GLuint -> IO Bool +isLinked pid = do + ok <- alloca $ liftA2 (*>) (glGetProgramiv pid GL_LINK_STATUS) peek + pure $ ok == GL_TRUE + +-- |Shader program link log’s length. +clogLength :: GLuint -> IO Int +clogLength pid = + fmap fromIntegral . + alloca $ liftA2 (*>) (glGetProgramiv pid GL_INFO_LOG_LENGTH) peek + +-- |Shader program link log. +clog :: Int -> GLuint -> IO String +clog l pid = + allocaArray l $ + liftA2 (*>) (glGetProgramInfoLog pid (fromIntegral l) nullPtr) + (peekCString . castPtr) + +-- |Either map a 'String' or 'Natural' to a uniform. +ifaceWith :: (HasProgramError e,MonadError e m,MonadIO m,Uniform a) + => Program + -> Either String Natural + -> m (U a) +ifaceWith prog access = case access of + Left name -> do + location <- liftIO . withCString name $ glGetUniformLocation pid + if + | isActive location -> pure $ toU pid location + | otherwise -> throwError . fromProgramError $ InactiveUniform access + Right sem + | isActive sem -> pure $ toU pid (fromIntegral sem) + | otherwise -> throwError . fromProgramError $ InactiveUniform access + where + pid = programID prog + isActive :: (Ord a,Num a) => a -> Bool + isActive = (> -1) + +-------------------------------------------------------------------------------- +-- Shader program errors ------------------------------------------------------- + +-- |Shader program error. +-- +-- 'LinkFailed reason' happens when a program fails to link. 'reason' contains the error message. +-- +-- 'InactiveUniform uni' happens at linking when a uniform is inactive in the program; that +-- is, unused or semantically set to a negative value. +data ProgramError + = LinkFailed String + | InactiveUniform (Either String Natural) + deriving (Eq,Show) + +-- |Types that can handle 'ProgramError' – read as, “have”. +class HasProgramError a where + fromProgramError :: ProgramError -> a diff --git a/src/Graphics/Luminance/Core/Shader/Stage.hs b/src/Graphics/Luminance/Core/Shader/Stage.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Luminance/Core/Shader/Stage.hs @@ -0,0 +1,106 @@ +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2015 Dimitri Sabadie +-- License : BSD3 +-- +-- Maintainer : Dimitri Sabadie +-- Stability : experimental +-- Portability : portable +---------------------------------------------------------------------------- + +module Graphics.Luminance.Core.Shader.Stage where + +import Control.Applicative ( liftA2 ) +import Control.Monad.Except ( MonadError(throwError) ) +import Control.Monad.IO.Class ( MonadIO(..) ) +import Control.Monad.Trans.Resource ( MonadResource, register ) +import Graphics.GL +import Foreign.C.String ( peekCString, withCString ) +import Foreign.Marshal.Alloc ( alloca ) +import Foreign.Marshal.Array ( allocaArray ) +import Foreign.Marshal.Utils ( with ) +import Foreign.Ptr ( castPtr, nullPtr ) +import Foreign.Storable ( peek ) + +-------------------------------------------------------------------------------- +-- Shader stages --------------------------------------------------------------- + +-- |A shader 'Stage'. +newtype Stage = Stage { stageID :: GLuint } + +-- |Create a new tessellation control shader from a 'String' representation of its source code. +createTessCtrlShader :: (HasStageError e,MonadError e m,MonadIO m,MonadResource m) => String -> m Stage +createTessCtrlShader = mkShader GL_TESS_CONTROL_SHADER + +-- |Create a new tessellation evaluation shader from a 'String' representation of its source code. +createTessEvalShader :: (HasStageError e,MonadError e m,MonadIO m,MonadResource m) => String -> m Stage +createTessEvalShader = mkShader GL_TESS_EVALUATION_SHADER + +-- |Create a new vertex shader from a 'String' representation of its source code. +createVertexShader :: (HasStageError e,MonadError e m,MonadIO m,MonadResource m) => String -> m Stage +createVertexShader = mkShader GL_VERTEX_SHADER + +-- |Create a new geometry shader from a 'String' representation of its source code. +createGeometryShader :: (HasStageError e,MonadError e m,MonadIO m,MonadResource m) => String -> m Stage +createGeometryShader = mkShader GL_GEOMETRY_SHADER + +-- |Create a new fragment shader from a 'String' representation of its source code. +createFragmentShader :: (HasStageError e,MonadError e m,MonadIO m,MonadResource m) => String -> m Stage +createFragmentShader = mkShader GL_FRAGMENT_SHADER + +-- |Create a new compute shader from a 'String' representation of its source code. +createComputeShader :: (HasStageError e,MonadError e m,MonadIO m,MonadResource m) => String -> m Stage +createComputeShader = mkShader GL_COMPUTE_SHADER + +-- Create a shader from the kind of shader and its source code 'String' representation. +mkShader :: (HasStageError e,MonadError e m,MonadIO m,MonadResource m) + => GLenum + -> String + -> m Stage +mkShader target src = do + (sid,compiled,cl) <- liftIO $ do + sid <- glCreateShader target + withCString src $ \cstr -> do + with cstr $ \pcstr -> glShaderSource sid 1 pcstr nullPtr + glCompileShader sid + compiled <- isCompiled sid + ll <- clogLength sid + cl <- clog ll sid + pure (sid,compiled,cl) + if + | compiled -> do + _ <- register $ glDeleteShader sid + pure $ Stage sid + | otherwise -> throwError . fromStageError $ CompilationFailed cl + +-- Is a shader compiled? +isCompiled :: GLuint -> IO Bool +isCompiled sid = do + ok <- alloca $ liftA2 (*>) (glGetShaderiv sid GL_COMPILE_STATUS) peek + pure $ ok == GL_TRUE + +-- Shader compilation log’s length. +clogLength :: GLuint -> IO Int +clogLength sid = + fmap fromIntegral . alloca $ + liftA2 (*>) (glGetShaderiv sid GL_INFO_LOG_LENGTH) peek + +-- Shader compilation log. +clog :: Int -> GLuint -> IO String +clog l sid = + allocaArray l $ + liftA2 (*>) (glGetShaderInfoLog sid (fromIntegral l) nullPtr) + (peekCString . castPtr) + +-------------------------------------------------------------------------------- +-- Shader stage errors --------------------------------------------------------- + +-- |Error type of shaders. +-- +-- 'CompilationFailed reason' occurs when a shader fails to compile, and the 'String' 'reason' +-- contains a description of the failure. +newtype StageError = CompilationFailed String deriving (Eq,Show) + +-- |Types that can handle 'StageError'. +class HasStageError a where + fromStageError :: StageError -> a diff --git a/src/Graphics/Luminance/Core/Shader/Uniform.hs b/src/Graphics/Luminance/Core/Shader/Uniform.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Luminance/Core/Shader/Uniform.hs @@ -0,0 +1,206 @@ +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2015 Dimitri Sabadie +-- License : BSD3 +-- +-- Maintainer : Dimitri Sabadie +-- Stability : experimental +-- Portability : portable +---------------------------------------------------------------------------- + +module Graphics.Luminance.Core.Shader.Uniform where + +import Data.Functor.Contravariant ( Contravariant(..) ) +import Data.Functor.Contravariant.Divisible ( Decidable(..), Divisible(..) ) +import Data.Int ( Int32 ) +import Data.Semigroup ( Semigroup(..) ) +import Data.Void ( absurd ) +import Data.Word ( Word32 ) +import Foreign.Marshal.Array ( withArrayLen ) +import Graphics.GL +import Graphics.GL.Ext.ARB.BindlessTexture ( glProgramUniformHandleui64ARB ) +import Graphics.Luminance.Core.Texture ( Texture2D(textureHandle) ) + +-------------------------------------------------------------------------------- +-- Uniform --------------------------------------------------------------------- + +-- |Class of types that can be sent down to shaders. That class is closed because shaders cannot +-- handle a lot of uniform types. However, you should have a look at the 'U' documentation for +-- further information about how to augment the scope of the types you can send down to shaders. +class Uniform a where + toU :: GLuint -> GLint -> U a + +-- |A shader uniform. @'U' a@ doesn’t hold any value. It’s more like a mapping between the host +-- code and the shader the uniform was retrieved from. +-- +-- 'U' is contravariant in its argument. That means that you can use 'contramap' to build more +-- interesting uniform types. It’s also a divisible contravariant functor, then you can divide +-- structures to take advantage of divisible contravariant properties and then glue several 'U' +-- with different types. That can be useful to build a uniform type by gluing its fields. +-- +-- Another interesting part is the fact that 'U' is also monoidal. You can accumulate several of +-- them with '(<>)' if they have the same type. That means that you can join them so that when you +-- pass an actual value, it gets shared inside the resulting value. +-- +-- The '()' instance doesn’t do anything and doesn’t even use its argument ('()'). +newtype U a = U { runU :: a -> IO () } + +instance Contravariant U where + contramap f u = U $ runU u . f + +instance Decidable U where + lose f = U $ absurd . f + choose f p q = U $ either (runU p) (runU q) . f + +instance Divisible U where + divide f p q = U $ \a -> do + let (b,c) = f a + runU p b + runU q c + conquer = mempty + +instance Monoid (U a) where + mempty = U . const $ pure () + mappend = (<>) + +instance Semigroup (U a) where + u <> v = U $ \a -> runU u a >> runU v a + +-------------------------------------------------------------------------------- +-- Unit instance --------------------------------------------------------------- + +instance Uniform () where + toU _ _ = mempty + +-------------------------------------------------------------------------------- +-- Int32 instances ------------------------------------------------------------- + +-- scalar +instance Uniform Int32 where + toU prog l = U $ glProgramUniform1i prog l + +-- D2 +instance Uniform (Int32,Int32) where + toU prog l = U $ \(x,y) -> glProgramUniform2i prog l x y + +-- D3 +instance Uniform (Int32,Int32,Int32) where + toU prog l = U $ \(x,y,z) -> glProgramUniform3i prog l x y z + +-- D4 +instance Uniform (Int32,Int32,Int32,Int32) where + toU prog l = U $ \(x,y,z,w) -> glProgramUniform4i prog l x y z w + +-- scalar array +instance Uniform [Int32] where + toU prog l = U $ \v -> withArrayLen v $ glProgramUniform1iv prog l . fromIntegral + +-- D2 array +instance Uniform [(Int32,Int32)] where + toU prog l = U $ \v -> withArrayLen (concatMap unPair v) $ + glProgramUniform2iv prog l . fromIntegral + +-- D3 array +instance Uniform [(Int32,Int32,Int32)] where + toU prog l = U $ \v -> withArrayLen (concatMap unTriple v) $ + glProgramUniform3iv prog l . fromIntegral + +-- D4 array +instance Uniform [(Int32,Int32,Int32,Int32)] where + toU prog l = U $ \v -> withArrayLen (concatMap unQuad v) $ + glProgramUniform4iv prog l . fromIntegral + +-------------------------------------------------------------------------------- +-- Word32 instances ------------------------------------------------------------ + +-- scalar +instance Uniform Word32 where + toU prog l = U $ glProgramUniform1ui prog l + +-- D2 +instance Uniform (Word32,Word32) where + toU prog l = U $ \(x,y) -> glProgramUniform2ui prog l x y + +-- D3 +instance Uniform (Word32,Word32,Word32) where + toU prog l = U $ \(x,y,z) -> glProgramUniform3ui prog l x y z + +-- D4 +instance Uniform (Word32,Word32,Word32,Word32) where + toU prog l = U $ \(x,y,z,w) -> glProgramUniform4ui prog l x y z w + +-- scalar array +instance Uniform [Word32] where + toU prog l = U $ \v -> withArrayLen v $ + glProgramUniform1uiv prog l . fromIntegral + +-- D2 array +instance Uniform [(Word32,Word32)] where + toU prog l = U $ \v -> withArrayLen (concatMap unPair v) $ + glProgramUniform2uiv prog l . fromIntegral + +-- D3 array +instance Uniform [(Word32,Word32,Word32)] where + toU prog l = U $ \v -> withArrayLen (concatMap unTriple v) $ + glProgramUniform3uiv prog l . fromIntegral + +-- D4 array +instance Uniform [(Word32,Word32,Word32,Word32)] where + toU prog l = U $ \v -> withArrayLen (concatMap unQuad v) $ + glProgramUniform4uiv prog l . fromIntegral + +-------------------------------------------------------------------------------- +-- Float instances ------------------------------------------------------------- + +-- scalar +instance Uniform Float where + toU prog l = U $ glProgramUniform1f prog l + +-- D2 +instance Uniform (Float,Float) where + toU prog l = U $ \(x,y) -> glProgramUniform2f prog l x y + +-- D3 +instance Uniform (Float,Float,Float) where + toU prog l = U $ \(x,y,z) -> glProgramUniform3f prog l x y z + +-- D4 +instance Uniform (Float,Float,Float,Float) where + toU prog l = U $ \(x,y,z,w) -> glProgramUniform4f prog l x y z w + +-- scalar array +instance Uniform [Float] where + toU prog l = U $ \v -> withArrayLen v $ + glProgramUniform1fv prog l . fromIntegral + +-- D2 array +instance Uniform [(Float,Float)] where + toU prog l = U $ \v -> withArrayLen (concatMap unPair v) $ + glProgramUniform2fv prog l . fromIntegral + +-- D3 array +instance Uniform [(Float,Float,Float)] where + toU prog l = U $ \v -> withArrayLen (concatMap unTriple v) $ + glProgramUniform3fv prog l . fromIntegral + +-- D4 array +instance Uniform [(Float,Float,Float,Float)] where + toU prog l = U $ \v -> withArrayLen (concatMap unQuad v) $ + glProgramUniform4fv prog l . fromIntegral + +-------------------------------------------------------------------------------- +-- Texture2D ------------------------------------------------------------------- +instance Uniform (Texture2D f) where + toU prog l = U $ glProgramUniformHandleui64ARB prog l . textureHandle + +-------------------------------------------------------------------------------- +-- Untuple functions ----------------------------------------------------------- + +unPair :: (a,a) -> [a] +unPair (x,y) = [x,y] + +unTriple :: (a,a,a) -> [a] +unTriple (x,y,z) = [x,y,z] + +unQuad :: (a,a,a,a) -> [a] +unQuad (x,y,z,w) = [x,y,z,w] diff --git a/src/Graphics/Luminance/Core/Texture.hs b/src/Graphics/Luminance/Core/Texture.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Luminance/Core/Texture.hs @@ -0,0 +1,211 @@ +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2015 Dimitri Sabadie +-- License : BSD3 +-- +-- Maintainer : Dimitri Sabadie +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- + +module Graphics.Luminance.Core.Texture where + +import Control.Monad ( when ) +import Control.Monad.IO.Class ( MonadIO(..) ) +import Control.Monad.Trans.Resource ( MonadResource, register ) +import Data.Foldable ( toList ) +import Data.Proxy ( Proxy(..) ) +import Foreign.Marshal.Alloc ( alloca ) +import Foreign.Marshal.Array ( withArray ) +import Foreign.Marshal.Utils ( with ) +import Foreign.Ptr ( castPtr ) +import Foreign.Storable ( Storable(peek) ) +import Graphics.GL +import Graphics.GL.Ext.ARB.BindlessTexture +import Graphics.Luminance.Core.Pixel +import Numeric.Natural ( Natural ) + +data Wrap + = ClampToEdge + | ClampToBorder + | Repeat + deriving (Eq,Show) + +fromWrap :: (Eq a,Num a) => Wrap -> a +fromWrap w = case w of + ClampToEdge -> GL_CLAMP_TO_EDGE + ClampToBorder -> GL_CLAMP_TO_BORDER + Repeat -> GL_REPEAT + +data Filter + = Nearest + | Linear + deriving (Eq,Show) + +fromFilter :: (Eq a,Num a) => Filter -> a +fromFilter f = case f of + Nearest -> GL_NEAREST + Linear -> GL_LINEAR + +data CompareFunc + = Never + | Less + | Equal + | LessOrEqual + | Greater + | GreaterOrEqual + | NotEqual + | Always + deriving (Eq,Show) + +fromCompareFunc :: (Eq a,Num a) => CompareFunc -> a +fromCompareFunc f = case f of + Never -> GL_NEVER + Less -> GL_LESS + Equal -> GL_EQUAL + LessOrEqual -> GL_LEQUAL + Greater -> GL_GREATER + GreaterOrEqual -> GL_GEQUAL + NotEqual -> GL_NOTEQUAL + Always -> GL_ALWAYS + +-- |2D Texture. +data Texture2D f = Texture2D { + textureID :: GLuint + , textureHandle :: GLuint64 + , textureW :: GLsizei + , textureH :: GLsizei + , textureFormat :: GLenum + , textureType :: GLenum + } deriving (Eq,Show) + +createTexture :: forall p m. (Pixel p,MonadIO m,MonadResource m) + => Natural + -> Natural + -> Natural + -> Sampling + -> m (Texture2D p) +createTexture w h mipmaps sampling = do + (tid,texH) <- liftIO . alloca $ \p -> do + glCreateTextures GL_TEXTURE_2D 1 p + tid <- peek p + glTextureStorage2D tid (fromIntegral mipmaps) ift w' h' + glTextureParameteri tid GL_TEXTURE_BASE_LEVEL 0 + glTextureParameteri tid GL_TEXTURE_MAX_LEVEL (fromIntegral mipmaps - 1) + setTextureSampling tid sampling + texH <- glGetTextureHandleARB tid + glMakeTextureHandleResidentARB texH + pure (tid,texH) + _ <- register $ do + glMakeTextureHandleNonResidentARB texH + with tid $ glDeleteTextures 1 + pure $ Texture2D tid texH w' h' ft typ + where + ft = pixelFormat (Proxy :: Proxy p) + ift = pixelIFormat (Proxy :: Proxy p) + typ = pixelType (Proxy :: Proxy p) + w' = fromIntegral w + h' = fromIntegral h + +newtype Sampler = Sampler { samplerID :: GLuint } deriving (Eq,Show) + +data Sampling = Sampling { + samplingWrapS :: Wrap + , samplingWrapT :: Wrap + , samplingWrapR :: Wrap + , samplingMinFilter :: Filter + , samplingMagFilter :: Filter + , samplingCompareFunction :: Maybe CompareFunc + } deriving (Eq,Show) + +defaultSampling :: Sampling +defaultSampling = Sampling { + samplingWrapS = ClampToEdge + , samplingWrapT = ClampToEdge + , samplingWrapR = ClampToEdge + , samplingMinFilter = Linear + , samplingMagFilter = Linear + , samplingCompareFunction = Nothing + } + +createSampler :: (MonadIO m,MonadResource m) + => Sampling + -> m Sampler +createSampler s = do + sid <- liftIO . alloca $ \p -> do + glCreateSamplers 1 p + sid <- peek p + setSamplerSampling sid s + pure sid + _ <- register . with sid $ glDeleteSamplers 1 + pure $ Sampler sid + +setSampling :: (Eq a,Eq b,MonadIO m,Num a,Num b) => (GLenum -> a -> b -> IO ()) -> GLenum -> Sampling -> m () +setSampling f objID s = liftIO $ do + -- wraps + f objID GL_TEXTURE_WRAP_S . fromWrap $ samplingWrapS s + f objID GL_TEXTURE_WRAP_T . fromWrap $ samplingWrapT s + f objID GL_TEXTURE_WRAP_R . fromWrap $ samplingWrapR s + -- filters + f objID GL_TEXTURE_MIN_FILTER . fromFilter $ samplingMinFilter s + f objID GL_TEXTURE_MAG_FILTER . fromFilter $ samplingMagFilter s + -- comparison function + case samplingCompareFunction s of + Just cmpf -> do + f objID GL_TEXTURE_COMPARE_FUNC $ fromCompareFunc cmpf + f objID GL_TEXTURE_COMPARE_MODE GL_COMPARE_REF_TO_TEXTURE + Nothing -> + f objID GL_TEXTURE_COMPARE_MODE GL_NONE + +setTextureSampling :: (MonadIO m) => GLenum -> Sampling -> m () +setTextureSampling = setSampling glTextureParameteri + +setSamplerSampling :: (MonadIO m) => GLenum -> Sampling -> m () +setSamplerSampling = setSampling glSamplerParameteri + +uploadWhole :: (Foldable f,MonadIO m,PixelBase p ~ a,Storable a) + => Texture2D p + -> Bool + -> f a + -> m () +uploadWhole (Texture2D tid _ w h fmt typ) autolvl dat = + liftIO $ do + withArray (toList dat) $ glTextureSubImage2D tid 0 0 0 w h fmt typ . castPtr + when autolvl $ glGenerateTextureMipmap tid + +uploadSub :: (Foldable f,MonadIO m,PixelBase p ~ a,Storable a) + => Texture2D p + -> Int + -> Int + -> Natural + -> Natural + -> Bool + -> f a + -> m () +uploadSub (Texture2D tid _ _ _ fmt typ) x y w h autolvl dat = + liftIO $ do + withArray (toList dat) $ glTextureSubImage2D tid 0 (fromIntegral x) + (fromIntegral y) (fromIntegral w) (fromIntegral h) fmt typ . castPtr + when autolvl $ glGenerateTextureMipmap tid + +fillWhole :: (Foldable f, MonadIO m,PixelBase p ~ a,Storable a) + => Texture2D p + -> Bool + -> f a + -> m () +fillWhole tex = fillSub tex 0 0 (fromIntegral $ textureW tex) (fromIntegral $ textureH tex) + +fillSub :: (Foldable f,MonadIO m,PixelBase p ~ a,Storable a) + => Texture2D p + -> Int + -> Int + -> Natural + -> Natural + -> Bool + -> f a + -> m () +fillSub (Texture2D tid _ _ _ fmt typ) x y w h autolvl filling = + liftIO $ do + withArray (toList filling) $ glClearTexSubImage tid 0 (fromIntegral x) + (fromIntegral y) 0 (fromIntegral w) (fromIntegral h) 1 fmt typ . castPtr + when autolvl $ glGenerateTextureMipmap tid diff --git a/src/Graphics/Luminance/Core/Tuple.hs b/src/Graphics/Luminance/Core/Tuple.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Luminance/Core/Tuple.hs @@ -0,0 +1,32 @@ +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2015 Dimitri Sabadie +-- License : BSD3 +-- +-- Maintainer : Dimitri Sabadie +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- + +module Graphics.Luminance.Core.Tuple where + +import Foreign.Storable ( Storable(..) ) +import Foreign.Ptr ( castPtr, plusPtr ) + +-- |A tuple of types, right-associated. +-- +-- The 'Storable' instance is used for foreign packing on 32-bit. +data a :. b = a :. b deriving (Eq,Functor,Ord,Show) + +infixr 6 :. + +instance (Storable a,Storable b) => Storable (a :. b) where + sizeOf (a :. b) = sizeOf a + sizeOf b + alignment _ = 4 -- packed data + peek p = do + a <- peek $ castPtr p + b <- peek . castPtr $ p `plusPtr` sizeOf (undefined :: a) + pure $ a :. b + poke p (a :. b) = do + poke (castPtr p) a + poke (castPtr $ p `plusPtr` sizeOf (undefined :: a)) b diff --git a/src/Graphics/Luminance/Core/Vertex.hs b/src/Graphics/Luminance/Core/Vertex.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Luminance/Core/Vertex.hs @@ -0,0 +1,94 @@ +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2015 Dimitri Sabadie +-- License : BSD3 +-- +-- Maintainer : Dimitri Sabadie +-- Stability : experimental +-- Portability : portable +---------------------------------------------------------------------------- + +module Graphics.Luminance.Core.Vertex where + +import Control.Monad.IO.Class ( MonadIO(..) ) +import Data.Int ( Int32 ) +import Data.Proxy ( Proxy(..) ) +import Data.Word ( Word32 ) +import Foreign.Marshal.Array ( peekArray, pokeArray ) +import Foreign.Ptr ( Ptr, castPtr ) +import Foreign.Storable ( Storable(..) ) +import GHC.TypeLits ( KnownNat, Nat, natVal ) +import Graphics.GL +import Graphics.Luminance.Core.Tuple + +-- FIXME: use linear’s one? +data V :: Nat -> * -> * where + V1 :: !a -> V 1 a + V2 :: !a -> !a -> V 2 a + V3 :: !a -> !a -> !a -> V 3 a + V4 :: !a -> !a -> !a -> !a -> V 4 a + +instance (Storable a) => Storable (V 1 a) where + sizeOf _ = sizeOf (undefined :: a) + alignment _ = alignment (undefined :: a) + peek p = fmap V1 $ peek (castPtr p :: Ptr a) + poke p (V1 x) = poke (castPtr p) x + +instance (Storable a) => Storable (V 2 a) where + sizeOf _ = 2 * sizeOf (undefined :: a) + alignment _ = alignment (undefined :: a) + peek p = do + [x,y] <- peekArray 2 (castPtr p :: Ptr a) + pure $ V2 x y + poke p (V2 x y) = pokeArray (castPtr p) [x,y] + +instance (Storable a) => Storable (V 3 a) where + sizeOf _ = 3 * sizeOf (undefined :: a) + alignment _ = alignment (undefined :: a) + peek p = do + [x,y,z] <- peekArray 3 (castPtr p :: Ptr a) + pure $ V3 x y z + poke p (V3 x y z) = pokeArray (castPtr p) [x,y,z] + +instance (Storable a) => Storable (V 4 a) where + sizeOf _ = 4 * sizeOf (undefined :: a) + alignment _ = alignment (undefined :: a) + peek p = do + [x,y,z,w] <- peekArray 4 (castPtr p :: Ptr a) + pure $ V4 x y z w + poke p (V4 x y z w) = pokeArray (castPtr p) [x,y,z,w] + +-- |A vertex might have several attributes. The types of those attributes have to implement the +-- 'VertexAttribute' typeclass in order to be used as vertex attributes. +class VertexAttribute a where + vertexGLType :: proxy a -> GLenum + +instance VertexAttribute Float where + vertexGLType _ = GL_FLOAT + +instance VertexAttribute Int32 where + vertexGLType _ = GL_INT + +instance VertexAttribute Word32 where + vertexGLType _ = GL_UNSIGNED_INT + +-- |A vertex has to implement 'Vertex' in order to be used as-is. That typeclass is closed, so you +-- you cannot add anymore instances. However, you shouldn’t need to since you can use the already +-- provided types to build up your vertex type. +class Vertex v where + setFormatV :: (MonadIO m) => GLuint -> GLuint -> proxy v -> m () + +instance (KnownNat n,Storable a,VertexAttribute a) => Vertex (V n a) where + setFormatV vid index _ = do + glVertexArrayAttribFormat vid index (fromIntegral $ natVal (Proxy :: Proxy n)) (vertexGLType (Proxy :: Proxy a)) GL_FALSE 0 + glVertexArrayAttribBinding vid index vertexBindingIndex + glEnableVertexArrayAttrib vid index + +instance (Vertex a,Vertex b) => Vertex (a :. b) where + setFormatV vid index _ = do + setFormatV vid index (Proxy :: Proxy a) + setFormatV vid index (Proxy :: Proxy b) + +-- Used to connect vertex attribute to the vertex buffer binding point. Should be 0. +vertexBindingIndex :: GLuint +vertexBindingIndex = 0 diff --git a/src/Graphics/Luminance/Framebuffer.hs b/src/Graphics/Luminance/Framebuffer.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Luminance/Framebuffer.hs @@ -0,0 +1,37 @@ +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2015 Dimitri Sabadie +-- License : BSD3 +-- +-- Maintainer : Dimitri Sabadie +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- + +module Graphics.Luminance.Framebuffer ( + -- * Framebuffer creation + Framebuffer + , ColorFramebuffer + , DepthFramebuffer + , framebufferID + , framebufferOutput + , createFramebuffer + -- * Framebuffer attachments + , FramebufferColorAttachment + , FramebufferDepthAttachment + -- * Framebuffer access + , FramebufferColorRW + , FramebufferTarget + -- * Framebuffer outputs + , TexturizeFormat + , Output(..) + -- * Blitting + , FramebufferBlitMask(..) + -- * Special framebuffers + , defaultFramebuffer + -- * Framebuffer errors + , FramebufferError(..) + , HasFramebufferError(..) + ) where + +import Graphics.Luminance.Core.Framebuffer diff --git a/src/Graphics/Luminance/Geometry.hs b/src/Graphics/Luminance/Geometry.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Luminance/Geometry.hs @@ -0,0 +1,18 @@ +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2015 Dimitri Sabadie +-- License : BSD3 +-- +-- Maintainer : Dimitri Sabadie +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- + +module Graphics.Luminance.Geometry ( + -- * Geometry creation + Geometry + , GeometryMode(..) + , createGeometry + ) where + +import Graphics.Luminance.Core.Geometry diff --git a/src/Graphics/Luminance/Pixel.hs b/src/Graphics/Luminance/Pixel.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Luminance/Pixel.hs @@ -0,0 +1,41 @@ +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2015 Dimitri Sabadie +-- License : BSD3 +-- +-- Maintainer : Dimitri Sabadie +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- + +module Graphics.Luminance.Pixel ( + -- * Channel size + ChannelSize + , C8(..) + , C16(..) + , C32(..) + -- * Channel type + , ChannelType + , CInts(..) + , CUInts(..) + , CFloats(..) + -- * Channel shape + , CR(..) + , CRG(..) + , CRGB(..) + , CRGBA(..) + , CDepth(..) + -- * Pixel format + , Format(..) + , Pixel + , RGB8UI + , RGBA8UI + , RGBA8F + , RGB32F + , RGBA32F + , Depth32F + -- * Color pixel + , ColorPixel + ) where + +import Graphics.Luminance.Core.Pixel diff --git a/src/Graphics/Luminance/Query.hs b/src/Graphics/Luminance/Query.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Luminance/Query.hs @@ -0,0 +1,20 @@ +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2015 Dimitri Sabadie +-- License : BSD3 +-- +-- Maintainer : Dimitri Sabadie +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- + +module Graphics.Luminance.Query ( + -- * Available queries + getGLVendor + , getGLRenderer + , getGLVersion + , getGLSLVersion + , getGLExtensions + ) where + +import Graphics.Luminance.Core.Query diff --git a/src/Graphics/Luminance/RW.hs b/src/Graphics/Luminance/RW.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Luminance/RW.hs @@ -0,0 +1,22 @@ +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2015 Dimitri Sabadie +-- License : BSD3 +-- +-- Maintainer : Dimitri Sabadie +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- + +module Graphics.Luminance.RW ( + -- * Readable types + Readable + , R + -- * Writable types + , Writable + , W + -- * Read/write types + , RW + ) where + +import Graphics.Luminance.Core.RW diff --git a/src/Graphics/Luminance/RenderCmd.hs b/src/Graphics/Luminance/RenderCmd.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Luminance/RenderCmd.hs @@ -0,0 +1,19 @@ +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2015 Dimitri Sabadie +-- License : BSD3 +-- +-- Maintainer : Dimitri Sabadie +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- + +module Graphics.Luminance.RenderCmd ( + -- * Render commands + RenderCmd + , renderCmd + -- * Special render commands + , stdRenderCmd + ) where + +import Graphics.Luminance.Core.RenderCmd diff --git a/src/Graphics/Luminance/Shader.hs b/src/Graphics/Luminance/Shader.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Luminance/Shader.hs @@ -0,0 +1,17 @@ +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2015 Dimitri Sabadie +-- License : BSD3 +-- +-- Maintainer : Dimitri Sabadie +-- Stability : experimental +-- Portability : portable +---------------------------------------------------------------------------- + +module Graphics.Luminance.Shader ( + module X + ) where + +import Graphics.Luminance.Shader.Program as X +import Graphics.Luminance.Shader.Stage as X +import Graphics.Luminance.Shader.Uniform as X diff --git a/src/Graphics/Luminance/Shader/Program.hs b/src/Graphics/Luminance/Shader/Program.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Luminance/Shader/Program.hs @@ -0,0 +1,22 @@ +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2015 Dimitri Sabadie +-- License : BSD3 +-- +-- Maintainer : Dimitri Sabadie +-- Stability : experimental +-- Portability : portable +---------------------------------------------------------------------------- + +module Graphics.Luminance.Shader.Program ( + -- * Shader program creation + Program + , programID + , createProgram + , createProgram_ + -- * Error handling + , ProgramError(..) + , HasProgramError(..) + ) where + +import Graphics.Luminance.Core.Shader.Program diff --git a/src/Graphics/Luminance/Shader/Stage.hs b/src/Graphics/Luminance/Shader/Stage.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Luminance/Shader/Stage.hs @@ -0,0 +1,26 @@ +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2015 Dimitri Sabadie +-- License : BSD3 +-- +-- Maintainer : Dimitri Sabadie +-- Stability : experimental +-- Portability : portable +---------------------------------------------------------------------------- + +module Graphics.Luminance.Shader.Stage ( + -- * Shader stage creation + Stage + , stageID + , createTessCtrlShader + , createTessEvalShader + , createVertexShader + , createGeometryShader + , createFragmentShader + , createComputeShader + -- * Error handling + , StageError(..) + , HasStageError(..) + ) where + +import Graphics.Luminance.Core.Shader.Stage diff --git a/src/Graphics/Luminance/Shader/Uniform.hs b/src/Graphics/Luminance/Shader/Uniform.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Luminance/Shader/Uniform.hs @@ -0,0 +1,17 @@ +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2015 Dimitri Sabadie +-- License : BSD3 +-- +-- Maintainer : Dimitri Sabadie +-- Stability : experimental +-- Portability : portable +---------------------------------------------------------------------------- + +module Graphics.Luminance.Shader.Uniform ( + -- * Uniform + Uniform + , U + ) where + +import Graphics.Luminance.Core.Shader.Uniform diff --git a/src/Graphics/Luminance/Texture.hs b/src/Graphics/Luminance/Texture.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Luminance/Texture.hs @@ -0,0 +1,35 @@ +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2015 Dimitri Sabadie +-- License : BSD3 +-- +-- Maintainer : Dimitri Sabadie +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- + +module Graphics.Luminance.Texture ( + -- * Texture information and creation + Texture2D + , textureID + , textureHandle + , textureW + , textureH + , textureFormat + , textureType + , createTexture + -- * Sampling + , Sampling(..) + , defaultSampling + -- * Texture sampler customization + , Filter(..) + , Wrap(..) + , CompareFunc(..) + -- * Texture operations + , uploadWhole + , uploadSub + , fillWhole + , fillSub + ) where + +import Graphics.Luminance.Core.Texture diff --git a/src/Graphics/Luminance/Vertex.hs b/src/Graphics/Luminance/Vertex.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Luminance/Vertex.hs @@ -0,0 +1,19 @@ +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2015 Dimitri Sabadie +-- License : BSD3 +-- +-- Maintainer : Dimitri Sabadie +-- Stability : experimental +-- Portability : portable +---------------------------------------------------------------------------- + +module Graphics.Luminance.Vertex ( + -- * Vertex components + V(..) + , VertexAttribute + -- * Vertex + , Vertex + ) where + +import Graphics.Luminance.Core.Vertex