diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2016 Schell Scivally + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 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/app/Example.hs b/app/Example.hs new file mode 100644 --- /dev/null +++ b/app/Example.hs @@ -0,0 +1,12 @@ +import Gelatin +import Gelatin.GL +import Linear as L +import qualified Data.Vector as B +import qualified Data.Vector.Unboxed as V +import Control.Lens + +-------------------------------------------------------------------------------- +-- Example +-------------------------------------------------------------------------------- +main :: IO () +main = putStrLn "Hello" diff --git a/gelatin-gl.cabal b/gelatin-gl.cabal new file mode 100644 --- /dev/null +++ b/gelatin-gl.cabal @@ -0,0 +1,59 @@ +name: gelatin-gl +version: 0.1.0.0 +synopsis: OpenGL rendering routines for the gelatin-picture graphics + EDSL. +description: This package provides most of a backend to + gelatin-picture, a DSL for decribing two dimensional + pictures. +homepage: https://github.com/schell/gelatin/gelatin-gl +license: MIT +license-file: LICENSE +author: Schell Scivally +maintainer: schell.scivally@synapsegroup.com +category: Graphics +build-type: Simple +cabal-version: >=1.10 +stability: experimental + +library + ghc-options: -Wall + exposed-modules: Gelatin.GL, + Gelatin.GL.Renderer, + Gelatin.GL.Compiler, + Gelatin.GL.Shader, + Gelatin.GL.Common, + Gelatin.GL.TH + build-depends: base >=4.8 && <4.11 + , bytestring >=0.10 && <0.11 + , gelatin >=0.1 && <0.2 + , gelatin-shaders >=0.1 && <0.2 + , linear >=1.20 && <1.21 + , gl >=0.7 && <0.9 + , JuicyPixels >=3.2 && <3.3 + , vector >=0.12 && <0.13 + , directory >=1.2 && <1.4 + , filepath >=1.4 && <1.5 + , transformers >=0.4 && <0.6 + , mtl >=2.2 && <2.3 + , either >=4.4 && <4.6 + , containers >=0.5 && <0.6 + , lens >=4.15 && <4.16 + , template-haskell >=2.10 && <2.13 + + hs-source-dirs: src + default-language: Haskell2010 + +executable gelatin-gl-example + ghc-options: -Wall + + build-depends: base >=4.8 && <4.11 + , gelatin >=0.1 && <0.2 + , gelatin-gl + , linear >=1.20 && <1.21 + , lens >=4.15 && <4.16 + , vector >=0.12 && <0.13 + , mtl >=2.2 && <2.3 + + hs-source-dirs: app + main-is: Example.hs + default-language: Haskell2010 diff --git a/src/Gelatin/GL.hs b/src/Gelatin/GL.hs new file mode 100644 --- /dev/null +++ b/src/Gelatin/GL.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TupleSections #-} +-- | +-- Module: Gelatin.GL +-- Copyright: (c) 2017 Schell Scivally +-- License: MIT +-- Maintainer: Schell Scivally +-- +-- ["Gelatin.GL.Renderer"] +-- Rendering specific geometries in IO. +-- +-- ["Gelatin.GL.Compiler"] +-- Compiling and marshaling general geometries to the renderer. +-- +-- ["Gelatin.GL.Shader"] +-- Loading and compiling the OpenGL shaders needed to run the renderer. +-- +-- ["Gelatin.GL.Common"] +-- Some shared stuff. +-- + + +module Gelatin.GL + ( module Gelatin.GL.Renderer + , module Gelatin.GL.Shader + , module Gelatin.GL.Common + , module Gelatin.GL.Compiler + -- * Re-exports + , module Gelatin + , module Graphics.GL.Types + , module Graphics.GL.Core33 + ) where + +import Gelatin.GL.Renderer +import Gelatin.GL.Shader +import Gelatin.GL.Common +import Gelatin.GL.Compiler +import Gelatin +import Graphics.GL.Types +import Graphics.GL.Core33 diff --git a/src/Gelatin/GL/Common.hs b/src/Gelatin/GL/Common.hs new file mode 100644 --- /dev/null +++ b/src/Gelatin/GL/Common.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +module Gelatin.GL.Common where + +import Gelatin +import Gelatin.GL.Shader + +orthoContextProjection :: Context -> IO (M44 Float) +orthoContextProjection window = do + (ww, wh) <- ctxWindowSize window + let (hw,hh) = (fromIntegral ww, fromIntegral wh) + return $ ortho 0 hw hh 0 0 1 +-------------------------------------------------------------------------------- +-- GL helper types +-------------------------------------------------------------------------------- +data Context = Context { ctxFramebufferSize :: IO (Int,Int) + , ctxWindowSize :: IO (Int,Int) + --, ctxScreenDpi :: IO Int + } + +data Rez = Rez { rezShader :: Simple2DShader + , rezContext :: Context + } diff --git a/src/Gelatin/GL/Compiler.hs b/src/Gelatin/GL/Compiler.hs new file mode 100644 --- /dev/null +++ b/src/Gelatin/GL/Compiler.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Gelatin.GL.Compiler where + +import Control.Lens hiding (op) +import Control.Monad ((>=>)) +import Data.Bits ((.|.)) +import qualified Data.Vector.Unboxed as V +import Graphics.GL.Core33 +import Graphics.GL.Types +import Linear as L + +import Gelatin +import Gelatin.GL.Common +import Gelatin.GL.Renderer +-------------------------------------------------------------------------------- +-- Concrete Picture Types +-------------------------------------------------------------------------------- +type V2V4 = (V2 Float, V4 Float) +type ColorPictureData = PictureData GLuint (V2 Float, V4 Float) +type ColorPictureT = PictureT GLuint (V2 Float, V4 Float) +type ColorPicture = ColorPictureT Identity + +type V2V2 = (V2 Float, V2 Float) +type TexturePictureData = PictureData GLuint (V2 Float, V2 Float) +type TexturePictureT = PictureT GLuint (V2 Float, V2 Float) +type TexturePicture = TexturePictureT Identity + +rgbaCompiler :: Rez + -> GeometryCompiler V2V4 (V2 Float) Float Raster +rgbaCompiler Rez{..} = GeometryCompiler s l + where s VertexTriangles = + uncurry (colorRenderer rezContext rezShader GL_TRIANGLES) . V.unzip + s VertexStrip = + uncurry (colorRenderer rezContext rezShader GL_TRIANGLE_STRIP) . V.unzip + s VertexFan = + uncurry (colorRenderer rezContext rezShader GL_TRIANGLE_FAN) . V.unzip + s VertexBeziers = + uncurry (colorBezRenderer rezContext rezShader) . V.unzip + l Stroke{..} = + uncurry (colorPolylineRenderer rezContext rezShader strokeWidth + strokeFeather strokeLineCaps) . V.unzip + +uvCompiler :: Rez -> GeometryCompiler V2V2 (V2 Float) Float Raster +uvCompiler Rez{..} = GeometryCompiler s l + where s VertexTriangles = + uncurry (textureRenderer rezContext rezShader GL_TRIANGLES) . V.unzip + s VertexStrip = + uncurry (textureRenderer rezContext rezShader GL_TRIANGLE_STRIP) . V.unzip + s VertexFan = + uncurry (textureRenderer rezContext rezShader GL_TRIANGLE_FAN) . V.unzip + s VertexBeziers = + uncurry (textureBezRenderer rezContext rezShader) . V.unzip + l Stroke{..} = + uncurry (texPolylineRenderer rezContext rezShader strokeWidth + strokeFeather strokeLineCaps) . V.unzip + +applyOption :: (c, rs -> IO ()) -> RenderingOption -> (c, rs -> IO ()) +applyOption (c, r) StencilMaskOption = (c, \rs -> stencilMask (r rs) (r rs)) + +glV2V4Compiler :: Rez -> BackendCompiler V2V4 (V2 Float) Float Raster +glV2V4Compiler rz = BackendComp + { backendCompApplyOption = applyOption + , backendCompCompiler = rgbaCompiler rz + } + +glV2V2Compiler :: Rez -> BackendCompiler V2V2 (V2 Float) Float Raster +glV2V2Compiler rz = BackendComp + { backendCompApplyOption = applyOption + , backendCompCompiler = uvCompiler rz + } + +glOps :: Rez -> IO () -> IO [a] -> BackendOps GLuint a +glOps Rez{..} windowUpdate getEvents = BackendOps + { backendOpGetFramebufferSize = uncurry V2 <$> ctxFramebufferSize rezContext + , backendOpGetWindowSize = uncurry V2 <$> ctxWindowSize rezContext + , backendOpClearWindow = do + (fbw,fbh) <- ctxFramebufferSize rezContext + glViewport 0 0 (fromIntegral fbw) (fromIntegral fbh) + glClear $ GL_COLOR_BUFFER_BIT .|. GL_DEPTH_BUFFER_BIT + , backendOpUpdateWindow = windowUpdate + , backendOpSetClearColor = \(V4 r g b a) -> glClearColor r g b a + , backendOpAllocTexture = loadImage >=> \case + Nothing -> return Nothing + Just (sz, tex) -> return $ Just (tex, sz) + , backendOpBindTextures = bindTexsAround + , backendOpGetEvents = getEvents + } diff --git a/src/Gelatin/GL/Renderer.hs b/src/Gelatin/GL/Renderer.hs new file mode 100644 --- /dev/null +++ b/src/Gelatin/GL/Renderer.hs @@ -0,0 +1,705 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Gelatin.GL.Renderer ( + -- * Renderer + Renderer2, + Context(..), + -- * Loading and using textures + allocAndActivateTex, + initializeTexImage2D, + loadImage, + maybeLoadTexture, + loadTexture, + loadTextureUnit, + unloadTexture, + loadImageAsTexture, + bindTexsAround, + bindTexAround, + -- * Line rendering + colorPolylineRenderer, + texPolylineRenderer, + -- * Triangle rendering + colorRenderer, + textureRenderer, + -- * Bezier rendering + colorBezRenderer, + textureBezRenderer, + -- * Masking + maskRenderer, + stencilMask, + alphaMask, + -- * Transforming a rendering + transformRenderer, + -- * Utils + toTexture, + toTextureUnit, + clipTexture +) where + +import Codec.Picture (readImage) +import Codec.Picture.Types +import Control.Exception (assert) +import Control.Monad +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Reader (ReaderT (..)) +import qualified Data.Foldable as F +import Data.Proxy (Proxy (..)) +import qualified Data.Vector.Generic as G +import qualified Data.Vector.Storable as S +import Data.Vector.Unboxed (Unbox, Vector) +import qualified Data.Vector.Unboxed as V +import Foreign.Marshal.Array +import Foreign.Marshal.Utils +import Foreign.Ptr +import Foreign.Storable +import Gelatin +import Gelatin.GL.Common +import Gelatin.GL.Shader +import Gelatin.Shaders +import Graphics.GL.Core33 +import Graphics.GL.Types +import System.Exit + +-------------------------------------------------------------------------------- +-- Uniform updates for the Simple2DShader +-------------------------------------------------------------------------------- +updatePrimitive :& updateProjection :& updateModelView :& updateThickness :& + updateFeather :& updateSumLength :& updateCap :& updateHasUV :& updateSampler :& + updateMainTex :& updateMaskTex :& updateAlpha :& updateMultiply :& + updateShouldReplaceColor :& updateReplacementColor :& () + = genFunction (Proxy :: Proxy Simple2DUniforms) +-------------------------------------------------------------------------------- +-- Attribute toggling +-------------------------------------------------------------------------------- +(enablePosition, disablePosition) :& (enableColor, disableColor) :& + (enableUV, disableUV) :& (enableBez, disableBez) :& + (enableBezUV, disableBezUV) :& (enablePrev, disablePrev) :& + (enableNext, disableNext) :& () + = genFunction (Proxy :: Proxy Simple2DAttribToggles) + +disableAll :: IO () +disableAll = + sequence_ [ disablePosition, disableColor, disableUV, disableBez, disableBezUV + , disablePrev, disableNext + ] + +--enableAll :: IO () +--enableAll = +-- sequence_ [ enablePosition, enableColor, enableUV, enableBez, enableBezUV +-- , enablePrev, enableNext +-- ] + +enableAttribsForLines :: Bool -> IO () +enableAttribsForLines hasUV = do + disableAll + enablePosition + enableBezUV + enablePrev + enableNext + if hasUV + then enableUV + else enableColor + +enableAttribsForTris :: Bool -> IO () +enableAttribsForTris hasUV = + disableAll >> enablePosition >> if hasUV then enableUV + else enableColor + +enableAttribsForBezs :: Bool -> IO () +enableAttribsForBezs hasUV = + disableAll >> enablePosition >> enableBez >> if hasUV then enableUV + else enableColor + +enableAttribsForMask :: IO () +enableAttribsForMask = disableAll >> enablePosition >> enableUV +-------------------------------------------------------------------------------- +-- Attribute buffering +-------------------------------------------------------------------------------- +bufferPosition :& bufferColor :& bufferUV :& bufferBez :& bufferBezUV :& + bufferPrev :& bufferNext :& () + = genFunction (Proxy :: Proxy Simple2DAttribBuffers) +-------------------------------------------------------------------------------- +-- Rendering +-------------------------------------------------------------------------------- +-- | Creates and returns a renderer that renders a colored, expanded 2d polyline +-- projected in 2d space. +colorPolylineRenderer :: Context -> Simple2DShader -> Float -> Float + -> (LineCap,LineCap) -> Vector (V2 Float) + -> Vector (V4 Float) -> IO Renderer2 +colorPolylineRenderer win sh thickness feather caps verts colors = do + let empty = putStrLn "could not expand polyline" >> return mempty + mpoly = expandPolyline verts colors thickness feather + flip (maybe empty) mpoly $ \(vs_,cs_,us_,ns_,ps_,totalLen) -> do + let toFrac :: Float -> GLfloat + toFrac = realToFrac + vs = V.map (fmap toFrac) vs_ + cs = V.map (fmap toFrac) cs_ + uvs = V.map (fmap toFrac) cs_ + us = V.map (fmap toFrac) us_ + ns = V.map (fmap toFrac) ns_ + ps = V.map (fmap toFrac) ps_ + + withVAO $ \vao -> withBuffers 5 $ \bufs@[vbuf, cbuf, buvbuf, nbuf, pbuf] -> do + enableAttribsForLines False + bufferPosition 2 vbuf vs + bufferColor 4 cbuf cs + bufferBezUV 2 buvbuf us + bufferNext 2 nbuf ns + bufferPrev 2 pbuf ps + glBindVertexArray 0 + + let num = fromIntegral $ V.length vs_ + r t = do + glUseProgram sh + let (mv, a, m, mr) = unwrapTransforms t + pj <- orthoContextProjection win + updatePrimitive sh PrimLine + updateModelView sh mv + updateHasUV sh False + updateThickness sh thickness + updateFeather sh feather + updateSumLength sh totalLen + updateCap sh caps + updateAlpha sh a + updateMultiply sh m + case mr of + Just c -> do updateShouldReplaceColor sh True + updateReplacementColor sh c + _ -> updateShouldReplaceColor sh False + drawBuffer sh vao GL_TRIANGLE_STRIP num + c = do withArray bufs $ glDeleteBuffers 5 + withArray [vao] $ glDeleteVertexArrays 1 + return (c,r) + +-- | Creates and returns a renderer that renders a textured, expanded 2d +-- polyline projected in 2d space. +texPolylineRenderer :: Context -> Simple2DShader -> Float + -> Float -> (LineCap,LineCap) -> Vector (V2 Float) + -> Vector (V2 Float) -> IO Renderer2 +texPolylineRenderer win sh thickness feather caps verts uvs = do + let empty = putStrLn "could not expand polyline" >> return mempty + mpoly = expandPolyline verts uvs thickness feather + flip (maybe empty) mpoly $ \(vs_,cs_,us_,ns_,ps_,totalLen) -> do + let toFrac :: Float -> GLfloat + toFrac = realToFrac + vs = V.map (fmap toFrac) vs_ + cs = V.map (fmap toFrac) cs_ + uvs = V.map (fmap toFrac) cs_ + us = V.map (fmap toFrac) us_ + ns = V.map (fmap toFrac) ns_ + ps = V.map (fmap toFrac) ps_ + + withVAO $ \vao -> withBuffers 5 $ \bufs@[vbuf, cbuf, buvbuf, nbuf, pbuf] -> do + enableAttribsForLines True + bufferPosition 2 vbuf vs + bufferUV 2 cbuf cs + bufferBezUV 2 buvbuf us + bufferNext 2 nbuf ns + bufferPrev 2 pbuf ps + glBindVertexArray 0 + + let num = fromIntegral $ V.length vs_ + r t = do + glUseProgram sh + let (mv, a, m, mr) = unwrapTransforms t + pj <- orthoContextProjection win + updatePrimitive sh PrimLine + updateProjection sh pj + updateModelView sh mv + updateHasUV sh True + updateThickness sh thickness + updateFeather sh feather + updateSumLength sh totalLen + updateCap sh caps + updateAlpha sh a + updateMultiply sh m + case mr of + Just c -> do updateShouldReplaceColor sh True + updateReplacementColor sh c + _ -> updateShouldReplaceColor sh False + drawBuffer sh vao GL_TRIANGLE_STRIP num + c = do withArray bufs $ glDeleteBuffers 5 + withArray [vao] $ glDeleteVertexArrays 1 + return (c,r) + +-- | Binds the given textures to GL_TEXTURE0, GL_TEXTURE1, ... in ascending +-- order of the texture unit, runs the IO action and then unbinds the textures. +bindTexsAround :: MonadIO m => [GLuint] -> m a -> m a +bindTexsAround ts f = do + liftIO $ mapM_ (uncurry bindTex) (zip ts [GL_TEXTURE0 ..]) + a <- f + liftIO $ glBindTexture GL_TEXTURE_2D 0 + return a + where bindTex tex u = glActiveTexture u >> glBindTexture GL_TEXTURE_2D tex + +bindTexAround :: MonadIO m => GLuint -> m a -> m a +bindTexAround tx = bindTexsAround [tx] + +-- | Creates and returns a renderer that renders the given colored +-- geometry. +colorRenderer :: Context -> Simple2DShader -> GLuint -> Vector (V2 Float) + -> Vector (V4 Float) -> IO Renderer2 +colorRenderer window sh mode vs gs = + withVAO $ \vao -> withBuffers 2 $ \[pbuf,cbuf] -> do + --let ps = V.map realToFrac $ V.concatMap (V.fromList . F.toList) vs :: Vector GLfloat + -- cs = V.map realToFrac $ V.concatMap (V.fromList . F.toList) $ V.take (V.length vs) gs :: Vector GLfloat + + enableAttribsForTris False + clearErrors "colorRenderer: enable attribs" + bufferPosition 2 pbuf vs + clearErrors "colorRenderer: buffer position" + bufferColor 4 cbuf $ V.take (V.length vs) gs + clearErrors "colorRenderer: buffer color" + let num = fromIntegral $ V.length vs + renderFunction t = do + glUseProgram sh + let (mv,a,m,mr) = unwrapTransforms t + pj <- orthoContextProjection window + updatePrimitive sh PrimTri + updateProjection sh pj + updateModelView sh mv + updateHasUV sh False + updateAlpha sh a + updateMultiply sh m + case mr of + Just c -> do updateShouldReplaceColor sh True + updateReplacementColor sh c + _ -> updateShouldReplaceColor sh False + drawBuffer sh vao mode num + cleanupFunction = do + withArray [pbuf, cbuf] $ glDeleteBuffers 2 + withArray [vao] $ glDeleteVertexArrays 1 + return (cleanupFunction,renderFunction) + +-- | Creates and returns a renderer that renders a textured +-- geometry. +textureRenderer :: Context -> Simple2DShader -> GLuint -> Vector (V2 Float) + -> Vector (V2 Float) -> IO Renderer2 +textureRenderer win sh mode vs uvs = + withVAO $ \vao -> withBuffers 2 $ \[pbuf,cbuf] -> do + --let f xs = V.map realToFrac $ V.concatMap (V.fromList . F.toList) xs :: Vector GLfloat + -- ps = f vs + -- cs = f $ V.take (V.length vs) uvs + + enableAttribsForTris True + bufferPosition 2 pbuf vs + bufferUV 2 cbuf uvs + glBindVertexArray 0 + + let num = fromIntegral $ V.length vs + renderFunction t = do + glUseProgram sh + let (mv,a,m,mr) = unwrapTransforms t + pj <- orthoContextProjection win + updatePrimitive sh PrimTri + updateProjection sh pj + updateModelView sh mv + updateHasUV sh True + updateSampler sh 0 + updateAlpha sh a + updateMultiply sh m + case mr of + Just c -> do updateShouldReplaceColor sh True + updateReplacementColor sh c + _ -> updateShouldReplaceColor sh False + drawBuffer sh vao mode num + cleanupFunction = do + withArray [pbuf, cbuf] $ glDeleteBuffers 2 + withArray [vao] $ glDeleteVertexArrays 1 + return (cleanupFunction,renderFunction) + +--bezAttributes :: (Foldable f, Unbox (f Float)) +-- => Vector (V2 Float) +-- -> Vector (f Float) +-- -> (Vector GLfloat, Vector GLfloat, Vector GLfloat) +--bezAttributes vs cvs = (ps, cs, ws) +-- where ps = V.map realToFrac $ +-- V.concatMap (V.fromList . F.toList) vs :: Vector GLfloat +-- cs = V.map realToFrac $ +-- V.concatMap (V.fromList . F.toList) cvs :: Vector GLfloat +-- getWinding i = +-- let n = i * 3 +-- (a,b,c) = (vs V.! n, vs V.! (n + 1), vs V.! (n + 2)) +-- w = fromBool $ triangleArea a b c <= 0 +-- in V.fromList [ 0, 0, w +-- , 0.5, 0, w +-- , 1, 1, w +-- ] +-- numBezs = floor $ realToFrac (V.length vs) / (3 :: Double) +-- ws :: Vector GLfloat +-- ws = V.concatMap getWinding $ V.generate numBezs id + +bezWinding :: Vector (V2 Float) -> Vector (V3 Float) +bezWinding vs = V.concatMap getWinding $ V.generate numBezs id + where getWinding i = + let n = i * 3 + (a,b,c) = (vs V.! n, vs V.! (n + 1), vs V.! (n + 2)) + w = fromBool $ triangleArea a b c <= 0 + in V.fromList [ V3 0 0 w + , V3 0.5 0 w + , V3 1 1 w + ] + numBezs = floor $ realToFrac (V.length vs) / (3 :: Double) + +-- | Creates and returns a renderer that renders the given colored beziers. +colorBezRenderer :: Context -> Simple2DShader + -> Vector (V2 Float) -> Vector (V4 Float) -> IO Renderer2 +colorBezRenderer win sh vs cs = do + let ws = bezWinding vs + withVAO $ \vao -> withBuffers 3 $ \[pbuf, tbuf, cbuf] -> do + enableAttribsForBezs False + bufferPosition 2 pbuf vs + bufferBez 3 tbuf ws + bufferColor 4 cbuf $ V.take (V.length vs) cs + glBindVertexArray 0 + + let cleanupFunction = do + withArray [pbuf, tbuf, cbuf] $ glDeleteBuffers 3 + withArray [vao] $ glDeleteVertexArrays 1 + num = fromIntegral $ V.length vs + renderFunction t = do + glUseProgram sh + pj <- orthoContextProjection win + let (mv,a,m,mr) = unwrapTransforms t + updatePrimitive sh PrimBez + updateProjection sh pj + updateModelView sh mv + updateHasUV sh False + updateAlpha sh a + updateMultiply sh m + case mr of + Just c -> do updateShouldReplaceColor sh True + updateReplacementColor sh c + _ -> updateShouldReplaceColor sh False + drawBuffer sh vao GL_TRIANGLES num + return (cleanupFunction,renderFunction) + +-- | Creates and returns a renderer that renders the given textured beziers. +textureBezRenderer :: Context -> Simple2DShader + -> Vector (V2 Float) -> Vector (V2 Float) -> IO Renderer2 +textureBezRenderer win sh vs cs = do + let ws = bezWinding vs + withVAO $ \vao -> withBuffers 3 $ \[pbuf, tbuf, cbuf] -> do + enableAttribsForBezs True + bufferPosition 2 pbuf vs + bufferBez 3 tbuf ws + bufferUV 2 cbuf cs + glBindVertexArray 0 + + let cleanupFunction = do + withArray [pbuf, tbuf, cbuf] $ glDeleteBuffers 3 + withArray [vao] $ glDeleteVertexArrays 1 + num = fromIntegral $ V.length vs + renderFunction t = do + glUseProgram sh + pj <- orthoContextProjection win + let (mv,a,m,mr) = unwrapTransforms t + updatePrimitive sh PrimBez + updateProjection sh pj + updateModelView sh mv + updateHasUV sh True + updateSampler sh 0 + updateAlpha sh a + updateMultiply sh m + case mr of + Just c -> do updateShouldReplaceColor sh True + updateReplacementColor sh c + _ -> updateShouldReplaceColor sh False + drawBuffer sh vao GL_TRIANGLES num + return (cleanupFunction,renderFunction) + +-- | Creates and returns a renderer that masks a textured rectangular area with +-- another texture. +maskRenderer :: Context -> Simple2DShader -> GLuint -> Vector (V2 Float) + -> Vector (V2 Float) -> IO Renderer2 +maskRenderer win sh mode vs uvs = + withVAO $ \vao -> withBuffers 2 $ \[pbuf, uvbuf] -> do + --let vs' = V.map realToFrac $ + -- V.concatMap (V.fromList . F.toList) vs :: Vector GLfloat + -- uvs' = V.map realToFrac $ + -- V.concatMap (V.fromList . F.toList) uvs :: Vector GLfloat + + enableAttribsForMask + bufferPosition 2 pbuf vs + bufferUV 2 uvbuf uvs + glBindVertexArray 0 + + let cleanup = do withArray [pbuf, uvbuf] $ glDeleteBuffers 2 + withArray [vao] $ glDeleteVertexArrays 1 + num = fromIntegral $ V.length vs + render t = do + let (mv,a,m,_) = unwrapTransforms t + pj <- orthoContextProjection win + --updateUniformsForMask (unShader sh) pj mv a m 0 1 + updateProjection sh pj + updateModelView sh mv + updateAlpha sh a + updateMultiply sh m + updateMainTex sh 0 + updateMaskTex sh 1 + drawBuffer sh vao mode num + return (cleanup,render) + +-- | Creates a rendering that masks an IO () drawing computation with the alpha +-- value of another. +alphaMask :: Context -> Simple2DShader -> IO () -> IO () -> IO Renderer2 +alphaMask win mrs r2 r1 = do + mainTex <- toTextureUnit (Just GL_TEXTURE0) win r2 + maskTex <- toTextureUnit (Just GL_TEXTURE1) win r1 + (w,h) <- ctxWindowSize win + let vs = V.fromList $ map (fmap fromIntegral) [V2 0 0, V2 w 0, V2 w h, V2 0 h] + uvs = V.fromList [V2 0 1, V2 1 1, V2 1 0, V2 0 0] + (c,f) <- maskRenderer win mrs GL_TRIANGLE_FAN vs uvs + let f' _ = do glActiveTexture GL_TEXTURE0 + glBindTexture GL_TEXTURE_2D mainTex + glActiveTexture GL_TEXTURE1 + glBindTexture GL_TEXTURE_2D maskTex + c' = withArray [mainTex,maskTex] $ glDeleteTextures 2 + f'' _ = do glActiveTexture GL_TEXTURE0 + glBindTexture GL_TEXTURE_2D 0 + glActiveTexture GL_TEXTURE1 + glBindTexture GL_TEXTURE_2D 0 + return (c >> c', \t -> f' t >> f t >> f'' t) + +-- | Creates an IO () drawing computation that masks an IO () drawing +-- computation with another using a stencil test. +stencilMask :: IO () -> IO () -> IO () +stencilMask r2 r1 = do + glClear GL_DEPTH_BUFFER_BIT + -- Enable stencil testing + glEnable GL_STENCIL_TEST + -- Disable writing frame buffer color components + glColorMask GL_FALSE GL_FALSE GL_FALSE GL_FALSE + -- Disable writing into the depth buffer + glDepthMask GL_FALSE + -- Enable writing to all bits of the stencil mask + glStencilMask 0xFF + -- Clear the stencil buffer + glClear GL_STENCIL_BUFFER_BIT + glStencilFunc GL_NEVER 0 1 + glStencilOp GL_INVERT GL_INVERT GL_INVERT + r1 + + glColorMask GL_TRUE GL_TRUE GL_TRUE GL_TRUE + glDepthMask GL_TRUE + glStencilFunc GL_EQUAL 1 1 + glStencilOp GL_ZERO GL_ZERO GL_ZERO + r2 + glDisable GL_STENCIL_TEST + +transformRenderer :: [RenderTransform2] -> Renderer2 -> Renderer2 +transformRenderer ts (c, r) = (c, r . (ts ++)) +-------------------------------------------------------------------------------- +-- Working with textures. +-------------------------------------------------------------------------------- +loadImage :: FilePath -> IO (Maybe (V2 Int, GLuint)) +loadImage fp = readImage fp >>= maybeLoadTexture + +loadImageAsTexture :: FilePath -> IO (Maybe GLuint) +loadImageAsTexture fp = do + edyn <- readImage fp + fmap snd <$> maybeLoadTexture edyn + +maybeLoadTexture :: Either String DynamicImage -> IO (Maybe (V2 Int, GLuint)) +maybeLoadTexture strOrImg = case strOrImg of + Left err -> putStrLn err >> return Nothing + Right i -> Just <$> loadTexture i + +loadTexture :: DynamicImage -> IO (V2 Int, GLuint) +loadTexture = loadTextureUnit Nothing + +allocAndActivateTex :: GLenum -> IO GLuint +allocAndActivateTex u = do + [t] <- allocaArray 1 $ \ptr -> do + glGenTextures 1 ptr + peekArray 1 ptr + glActiveTexture u + glBindTexture GL_TEXTURE_2D t + return t + +loadTextureUnit :: Maybe GLuint -> DynamicImage -> IO (V2 Int, GLuint) +loadTextureUnit Nothing img = loadTextureUnit (Just GL_TEXTURE0) img +loadTextureUnit (Just u) img = do + t <- allocAndActivateTex u + (w,h) <- loadJuicy img + glGenerateMipmap GL_TEXTURE_2D -- Generate mipmaps now!!! + glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_REPEAT + glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_REPEAT + glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_NEAREST + glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_NEAREST_MIPMAP_NEAREST + glBindTexture GL_TEXTURE_2D 0 + return (V2 w h, t) + +unloadTexture :: GLuint -> IO () +unloadTexture t = withArray [t] $ glDeleteTextures 1 + +loadJuicy :: DynamicImage -> IO (Int,Int) +loadJuicy (ImageY8 (Image w h d)) = bufferImageData w h d GL_RED GL_UNSIGNED_BYTE +loadJuicy (ImageY16 (Image w h d)) = bufferImageData w h d GL_RED GL_UNSIGNED_SHORT +loadJuicy (ImageYF (Image w h d)) = bufferImageData w h d GL_RED GL_FLOAT +loadJuicy (ImageYA8 i) = loadJuicy $ ImageRGB8 $ promoteImage i +loadJuicy (ImageYA16 i) = loadJuicy $ ImageRGBA16 $ promoteImage i +loadJuicy (ImageRGB8 (Image w h d)) = bufferImageData w h d GL_RGB GL_UNSIGNED_BYTE +loadJuicy (ImageRGB16 (Image w h d)) = bufferImageData w h d GL_RGB GL_UNSIGNED_SHORT +loadJuicy (ImageRGBF (Image w h d)) = bufferImageData w h d GL_RGB GL_FLOAT +loadJuicy (ImageRGBA8 (Image w h d)) = bufferImageData w h d GL_RGBA GL_UNSIGNED_BYTE +loadJuicy (ImageRGBA16 (Image w h d)) = bufferImageData w h d GL_RGBA GL_UNSIGNED_SHORT +loadJuicy (ImageYCbCr8 i) = loadJuicy $ ImageRGB8 $ convertImage i +loadJuicy (ImageCMYK8 i) = loadJuicy $ ImageRGB8 $ convertImage i +loadJuicy (ImageCMYK16 i) = loadJuicy $ ImageRGB16 $ convertImage i + +toTexture :: Context -> IO () -> IO GLuint +toTexture = toTextureUnit Nothing + +toTextureUnit :: Maybe GLuint -> Context -> IO () -> IO GLuint +toTextureUnit Nothing win r = toTextureUnit (Just GL_TEXTURE0) win r +toTextureUnit (Just u) win r = do + [fb] <- allocaArray 1 $ \ptr -> do + glGenFramebuffers 1 ptr + peekArray 1 ptr + glBindFramebuffer GL_FRAMEBUFFER fb + + t <- allocAndActivateTex u + + (w,h) <- ctxWindowSize win + let [w',h'] = map fromIntegral [w,h] + + initializeTexImage2D w' h' + + glFramebufferTexture GL_FRAMEBUFFER GL_COLOR_ATTACHMENT0 t 0 + withArray [GL_COLOR_ATTACHMENT0] $ glDrawBuffers 1 + + status <- glCheckFramebufferStatus GL_FRAMEBUFFER + if status /= GL_FRAMEBUFFER_COMPLETE + then putStrLn "incomplete framebuffer!" + else do glClearColor 0 0 0 0 + glClear GL_COLOR_BUFFER_BIT + glViewport 0 0 w' h' + r + glBindFramebuffer GL_FRAMEBUFFER 0 + with fb $ glDeleteFramebuffers 1 + (fbw, fbh) <- ctxFramebufferSize win + glViewport 0 0 (fromIntegral fbw) (fromIntegral fbh) + return t + +initializeTexImage2D :: GLsizei -> GLsizei -> IO () +initializeTexImage2D w h = do + glTexImage2D GL_TEXTURE_2D 0 GL_RGBA w h 0 GL_RGBA GL_UNSIGNED_BYTE nullPtr + glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_NEAREST + glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_NEAREST + +type ClippingArea = (V2 Int, V2 Int) + +-- | Sub-samples a texture using the given coordinate box and creates a new +-- texture. Keep in mind that OpenGL texture coordinates are flipped from +-- 'normal' graphics coordinates (y = 0 is the bottom of the texture). That +-- fact has bitten the author a number of times while clipping a texture +-- created with `toTexture` and `toUnitTexture`. +clipTexture :: GLuint -> ClippingArea -> IO GLuint +clipTexture rtex (V2 x1 y1, V2 x2 y2) = do + -- Create our framebuffers + [fbread,fbwrite] <- allocaArray 2 $ \ptr -> do + glGenFramebuffers 2 ptr + peekArray 2 ptr + -- Bind our read frame buffer and attach the input texture to it + glBindFramebuffer GL_READ_FRAMEBUFFER fbread + glFramebufferTexture2D GL_READ_FRAMEBUFFER GL_COLOR_ATTACHMENT0 GL_TEXTURE_2D rtex 0 + clearErrors "clipTexture bind read framebuffer" + -- Generate a new texture and bind our write framebuffer to it + [wtex] <- allocaArray 1 $ \ptr -> do + glGenTextures 1 ptr + peekArray 1 ptr + glActiveTexture GL_TEXTURE0 + glBindTexture GL_TEXTURE_2D wtex + let [x1',y1',x2',y2',w',h'] = map fromIntegral + [x1,y1,x2,y2,abs $ x2 - x1 + ,abs $ y2 - y1] + initializeTexImage2D w' h' + glBindFramebuffer GL_DRAW_FRAMEBUFFER fbwrite + glFramebufferTexture2D GL_DRAW_FRAMEBUFFER GL_COLOR_ATTACHMENT0 GL_TEXTURE_2D wtex 0 + clearErrors "clipTexture bind write framebuffer" + -- Check our frame buffer stati + forM_ [GL_READ_FRAMEBUFFER,GL_DRAW_FRAMEBUFFER] $ \fb -> do + status <- glCheckFramebufferStatus fb + when (status /= GL_FRAMEBUFFER_COMPLETE) $ do + putStrLn "incomplete framebuffer!" + exitFailure + -- Blit the read framebuffer into the write framebuffer + glBlitFramebuffer x1' y1' x2' y2' 0 0 w' h' GL_COLOR_BUFFER_BIT GL_NEAREST + clearErrors "clipTexture blit framebuffers" + -- Cleanup + glBindFramebuffer GL_FRAMEBUFFER 0 + withArray [fbread,fbwrite] $ glDeleteFramebuffers 2 + glBindTexture GL_TEXTURE_2D 0 + return wtex +-------------------------------------------------------------------------------- +-- Buffering, Vertex Array Objects, Uniforms, etc. +-------------------------------------------------------------------------------- +bufferImageData :: forall a a1 a2. (Storable a2, Integral a1, Integral a) => a -> a1 -> S.Vector a2 -> GLenum -> GLenum -> IO (a,a1) +bufferImageData w h dat imgfmt pxfmt = S.unsafeWith dat $ \ptr -> do + glTexImage2D + GL_TEXTURE_2D + 0 + GL_RGBA + (fromIntegral w) + (fromIntegral h) + 0 + imgfmt + pxfmt + (castPtr ptr) + err <- glGetError + when (err /= 0) $ putStrLn $ "glTexImage2D Error: " ++ show err + return (w,h) + +withVAO :: (GLuint -> IO b) -> IO b +withVAO f = do + [vao] <- allocaArray 1 $ \ptr -> do + glGenVertexArrays 1 ptr + peekArray 1 ptr + glBindVertexArray vao + r <- f vao + clearErrors "withVAO" + glBindVertexArray 0 + return r + +withBuffers :: Int -> ([GLuint] -> IO b) -> IO b +withBuffers n f = do + bufs <- allocaArray n $ \ptr -> do + glGenBuffers (fromIntegral n) ptr + peekArray (fromIntegral n) ptr + f bufs + +--bufferAttrib :: (Storable a, Unbox a) +-- => Simple2DAttrib -> GLint -> GLuint -> Vector a -> IO () +--bufferAttrib attr n buf as = do +-- let loc = locToGLuint attr +-- asize = V.length as * sizeOf (V.head as) +-- f = S.convert :: (G.Vector Vector a, Storable a) +-- => Vector a -> S.Vector a +-- glBindBuffer GL_ARRAY_BUFFER buf +-- +-- S.unsafeWith (f as) $ \ptr -> +-- glBufferData GL_ARRAY_BUFFER (fromIntegral asize) (castPtr ptr) GL_STATIC_DRAW +-- glEnableVertexAttribArray loc +-- glVertexAttribPointer loc n GL_FLOAT GL_FALSE 0 nullPtr + +drawBuffer :: GLuint + -> GLuint + -> GLenum + -> GLsizei + -> IO () +drawBuffer program vao mode num = do + glUseProgram program + glBindVertexArray vao + clearErrors "drawBuffer:glBindVertex" + glDrawArrays mode 0 num + clearErrors "drawBuffer:glDrawArrays" + +clearErrors :: String -> IO () +clearErrors str = do + err' <- glGetError + when (err' /= 0) $ do + putStrLn $ unwords [str, show err'] + assert False $ return () diff --git a/src/Gelatin/GL/Shader.hs b/src/Gelatin/GL/Shader.hs new file mode 100644 --- /dev/null +++ b/src/Gelatin/GL/Shader.hs @@ -0,0 +1,379 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fprint-explicit-kinds #-} +module Gelatin.GL.Shader ( + -- * Compiling and loading shaders + Simple2DShader + , compileOGLShader + , compileOGLProgram + , loadSourcePaths + , compileSources + , compileProgram + , loadSimple2DShader + + --loadSumShader, + --loadGLShader, + ---- * GLShader types + --GLShaderProgram, + --GLShader, + --GLShaderDef, + ---- * GLShader prims + --PrimType(..), + ---- * Uniforms + --Simple2DUniform(..), + ---- * Updating uniforms for specific kinds of rendering + --updateUniformsForTris, + --updateUniformsForBezs, + --updateUniformsForLines, + --updateUniformsForMask, + --applyAlpha, + --applyMult, + ---- * Free form uniform updates + --updateUniform, + --updateUniforms, + ---- * Attributes + ---- $layout + --Simple2DAttrib(..), + --locToGLuint, + ---- * Enabling attribs for specific kinds of rendering + --enableAttribsForTris, + --enableAttribsForBezs, + --enableAttribsForLines, + --enableAttribsForMask, + ---- * Enabling and disabling any attribs + --onlyEnableAttribs, + ---- * GLShader compilation + --compileShader, + --compileProgram, +) where + +import Control.Exception (assert) +import Control.Monad +import Control.Monad.Except (MonadError, throwError) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.ByteString.Char8 as B +import qualified Data.Foldable as F +import Data.Proxy (Proxy (..)) +import qualified Data.Vector.Generic as G +import qualified Data.Vector.Storable as S +import Data.Vector.Unboxed (Unbox, Vector) +import qualified Data.Vector.Unboxed as V +import Foreign.C.String +import Foreign.Marshal.Array +import Foreign.Marshal.Utils +import Foreign.Ptr +import Foreign.Storable +import GHC.TypeLits (KnownNat, KnownSymbol, natVal) +import Graphics.GL.Core33 +import Graphics.GL.Types +import Prelude hiding (init) +import Prelude as P + +import Gelatin +import Gelatin.Shaders + +import Gelatin.GL.TH + + +type Simple2DShader = GLuint +-------------------------------------------------------------------------------- +-- Updating shader uniforms +-------------------------------------------------------------------------------- +---- | Updates uniforms for rendering triangles. +--updateUniformsForTris :: GLShader -> M44 Float -> M44 Float -> Bool -> Float +-- -> V4 Float -> Maybe (V4 Float) -> IO () +--updateUniformsForTris sh pj mv hasUV a m mr = +-- updateUniforms (uniformsForTris pj mv hasUV a m mr) sh +--{-# INLINE updateUniformsForTris #-} +-- +---- | Updates uniforms for rendering loop-blinn beziers. +--updateUniformsForBezs :: GLShader -> M44 Float -> M44 Float -> Bool -> Float +-- -> V4 Float -> Maybe (V4 Float) -> IO () +--updateUniformsForBezs sh pj mv hasUV a m mr = +-- updateUniforms (uniformsForBezs pj mv hasUV a m mr) sh +--{-# INLINE updateUniformsForBezs #-} +-- +---- | Updates uniforms for rendering projected polylines. +--updateUniformsForLines :: GLShader -> M44 Float -> M44 Float -> Bool -> Float +-- -> V4 Float -> Maybe (V4 Float) -> Float -> Float -> Float +-- -> (LineCap,LineCap) -> IO () +--updateUniformsForLines sh pj mv hasUV a m mr thickness feather sumlength caps = +-- let us = uniformsForLines pj mv hasUV a m mr thickness feather sumlength caps +-- in updateUniforms us sh +--{-# INLINE updateUniformsForLines #-} +-- +---- | Updates uniforms for rendering alpha masking. +--updateUniformsForMask :: GLShader -> M44 Float -> M44 Float -> Float -> V4 Float +-- -> GLuint -> GLuint -> IO () +--updateUniformsForMask sh pj mv a m main mask = +-- updateUniforms (uniformsForMask pj mv a m main mask) sh +--{-# INLINE updateUniformsForMask #-} +-- +--updateUniforms :: [Simple2DUniform] -> GLShader -> IO () +--updateUniforms us s = mapM_ (`updateUniform` s) us +--{-# INLINE updateUniforms #-} +-- +--updateUniform :: Simple2DUniform -> GLShader -> IO () +--updateUniform u s = withUniform (simple2DUniformIdentifier u) s $ \p loc -> do +-- glUseProgram p +-- uniformUpdateFunc u loc +--{-# INLINE updateUniform #-} +-- +--uniformUpdateFunc :: Simple2DUniform -> GLint -> IO () +--uniformUpdateFunc (UniformPrimType p) u = +-- glUniform1i u $ fromIntegral $ fromEnum p +--uniformUpdateFunc (UniformProjection m44) u = +-- with m44 $ glUniformMatrix4fv u 1 GL_TRUE . castPtr +--uniformUpdateFunc (UniformModelView m44) u = +-- with m44 $ glUniformMatrix4fv u 1 GL_TRUE . castPtr +--uniformUpdateFunc (UniformThickness t) u = glUniform1f u t +--uniformUpdateFunc (UniformFeather f) u = glUniform1f u f +--uniformUpdateFunc (UniformSumLength l) u = glUniform1f u l +--uniformUpdateFunc (UniformLineCaps (capx, capy)) u = +-- let [x,y] = P.map (fromIntegral . fromEnum) [capx,capy] in glUniform2f u x y +--uniformUpdateFunc (UniformHasUV has) u = glUniform1i u $ if has then 1 else 0 +--uniformUpdateFunc (UniformSampler s) u = glUniform1i u $ fromIntegral s +--uniformUpdateFunc (UniformMainTex t) u = glUniform1i u $ fromIntegral t +--uniformUpdateFunc (UniformMaskTex t) u = glUniform1i u $ fromIntegral t +--uniformUpdateFunc (UniformAlpha a) u = glUniform1f u $ realToFrac a +--uniformUpdateFunc (UniformMult v) u = +-- let (V4 r g b a) = realToFrac <$> v in glUniform4f u r g b a +--uniformUpdateFunc (UniformShouldReplaceColor s) u = +-- glUniform1i u $ if s then 1 else 0 +--uniformUpdateFunc (UniformReplaceColor c) u = +-- let (V4 r g b a) = realToFrac <$> c in glUniform4f u r g b a +--{-# INLINE uniformUpdateFunc #-} +-- +--withUniform :: String -> GLShader -> (GLuint -> GLint -> IO ()) -> IO () +--withUniform name (Shader p ls) f = +-- case lookup name ls of +-- Nothing -> do P.putStrLn $ "could not find uniform " ++ name +-- exitFailure +-- Just loc -> f p loc +--{-# INLINE withUniform #-} +-------------------------------------------------------------------------------- +-- $layout +-- Attributes layout locations are unique and global. +-------------------------------------------------------------------------------- +--locToGLuint :: Simple2DAttrib -> GLuint +--locToGLuint = fromIntegral . fromEnum +-- +---- | Enables the provided attributes and disables all others. +--onlyEnableAttribs :: [Simple2DAttrib] -> IO () +--onlyEnableAttribs atts = do +-- mapM_ (glDisableVertexAttribArray . locToGLuint) allAttribs +-- mapM_ (glEnableVertexAttribArray . locToGLuint) atts + +--enableAttribsForTris :: Bool -> IO () +--enableAttribsForTris True = onlyEnableAttribs [PositionLoc,UVLoc] +--enableAttribsForTris False = onlyEnableAttribs [PositionLoc,ColorLoc] +-- +--enableAttribsForBezs :: Bool -> IO () +--enableAttribsForBezs True = onlyEnableAttribs [PositionLoc,UVLoc,BezLoc] +--enableAttribsForBezs False = onlyEnableAttribs [PositionLoc,ColorLoc,BezLoc] +-- +--enableAttribsForLines :: Bool -> IO () +--enableAttribsForLines True = +-- onlyEnableAttribs [PositionLoc,UVLoc,BezUVLoc,NextLoc,PrevLoc] +--enableAttribsForLines False = +-- onlyEnableAttribs [PositionLoc,ColorLoc,BezUVLoc,NextLoc,PrevLoc] +-- +--enableAttribsForMask :: IO () +--enableAttribsForMask = onlyEnableAttribs [PositionLoc,UVLoc] +-------------------------------------------------------------------------------- +-- IsShaderType instances +-------------------------------------------------------------------------------- +instance IsShaderType VertexShader GLenum where + getShaderType _ = GL_VERTEX_SHADER + +instance IsShaderType FragmentShader GLenum where + getShaderType _ = GL_FRAGMENT_SHADER +-------------------------------------------------------------------------------- +-- Uniform marshaling functions +-------------------------------------------------------------------------------- +$(genUniform [t|Bool|] [| \loc bool -> + glUniform1i loc $ if bool then 1 else 0 |]) + +$(genUniform [t|Int|] [| \loc enum -> + glUniform1i loc $ fromIntegral $ fromEnum enum |]) + +$(genUniform [t|PrimType|] [| \loc enum -> + glUniform1i loc $ fromIntegral $ fromEnum enum |]) + +$(genUniform [t|Float|] [| \loc float -> + glUniform1f loc $ realToFrac float |]) + +$(genUniform [t|V2 Float|] [| \loc v -> + let V2 x y = fmap realToFrac v + in glUniform2f loc x y |]) + +$(genUniform [t|V3 Float|] [| \loc v -> + let V3 x y z = fmap realToFrac v + in glUniform3f loc x y z|]) + +$(genUniform [t|V4 Float|] [| \loc v -> + let (V4 r g b a) = realToFrac <$> v + in glUniform4f loc r g b a |]) + +$(genUniform [t|M44 Float|] [| \loc val -> + with val $ glUniformMatrix4fv loc 1 GL_TRUE . castPtr |]) + +$(genUniform [t|(Int,Int)|] [| \loc (a, b) -> + let [x,y] = P.map fromIntegral [a, b] + in glUniform2i loc x y |]) + +$(genUniform [t|(LineCap,LineCap)|] [| \loc (a, b) -> + let [x,y] = P.map (fromIntegral . fromEnum) [a, b] + in glUniform2f loc x y |]) + +$(genUniform [t|V2 Int|] [| \loc v -> + let V2 x y = fmap fromIntegral v + in glUniform2i loc x y |]) +-------------------------------------------------------------------------------- +-- Attribute buffering and toggling +-------------------------------------------------------------------------------- +convertVec + :: (Unbox (f Float), Foldable f) => Vector (f Float) -> S.Vector GLfloat +convertVec = + S.convert . V.map realToFrac . V.concatMap (V.fromList . F.toList) + +instance + ( KnownNat loc, KnownSymbol name + , Foldable f + , Unbox (f Float), Storable (f Float) + ) => HasGenFunc (AttributeBuffering (Attribute name (f Float) loc)) where + + type GenFunc (AttributeBuffering (Attribute name (f Float) loc)) = + GLint -> GLuint -> Vector (f Float) -> IO () + genFunction _ n buf as = do + let loc = fromIntegral $ natVal (Proxy :: Proxy loc) + asize = V.length as * sizeOf (V.head as) + glBindBuffer GL_ARRAY_BUFFER buf + S.unsafeWith (convertVec as) $ \ptr -> + glBufferData GL_ARRAY_BUFFER (fromIntegral asize) (castPtr ptr) GL_STATIC_DRAW + glEnableVertexAttribArray loc + glVertexAttribPointer loc n GL_FLOAT GL_FALSE 0 nullPtr + err <- glGetError + when (err /= 0) $ do + print err + assert False $ return () + +instance (KnownNat loc, KnownSymbol name) + => HasGenFunc (AttributeToggling (Attribute name val loc)) where + type GenFunc (AttributeToggling (Attribute name val loc)) = (IO (), IO ()) + genFunction _ = + let aloc = fromIntegral $ natVal (Proxy :: Proxy loc) + in (glEnableVertexAttribArray aloc, glDisableVertexAttribArray aloc) +-------------------------------------------------------------------------------- +-- OpenGL shader only stuff +-------------------------------------------------------------------------------- +compileOGLShader :: (MonadIO m, MonadError String m) + => ByteString + -- ^ The shader source + -> GLenum + -- ^ The shader type (vertex, frag, etc) + -> m GLuint + -- ^ Either an error message or the generated shader handle. +compileOGLShader src shType = do + shader <- liftIO $ glCreateShader shType + if shader == 0 + then throwError "Could not create shader" + else do + success <- liftIO $ do + withCString (B.unpack src) $ \ptr -> + with ptr $ \ptrptr -> glShaderSource shader 1 ptrptr nullPtr + + glCompileShader shader + with (0 :: GLint) $ \ptr -> do + glGetShaderiv shader GL_COMPILE_STATUS ptr + peek ptr + + if success == GL_FALSE + then do + err <- liftIO $ do + infoLog <- with (0 :: GLint) $ \ptr -> do + glGetShaderiv shader GL_INFO_LOG_LENGTH ptr + logsize <- peek ptr + allocaArray (fromIntegral logsize) $ \logptr -> do + glGetShaderInfoLog shader logsize nullPtr logptr + peekArray (fromIntegral logsize) logptr + + return $ P.unlines [ "Could not compile shader:" + , B.unpack src + , P.map (toEnum . fromEnum) infoLog + ] + throwError err + else return shader + +compileOGLProgram :: (MonadIO m, MonadError String m) + => [(String, Integer)] -> [GLuint] -> m GLuint +compileOGLProgram attribs shaders = do + (program, success) <- liftIO $ do + program <- glCreateProgram + forM_ shaders (glAttachShader program) + forM_ attribs $ \(name, loc) -> + withCString name $ glBindAttribLocation program $ fromIntegral loc + glLinkProgram program + + success <- with (0 :: GLint) $ \ptr -> do + glGetProgramiv program GL_LINK_STATUS ptr + peek ptr + return (program, success) + + if success == GL_FALSE + then do + err <- liftIO $ with (0 :: GLint) $ \ptr -> do + glGetProgramiv program GL_INFO_LOG_LENGTH ptr + logsize <- peek ptr + infoLog <- allocaArray (fromIntegral logsize) $ \logptr -> do + glGetProgramInfoLog program logsize nullPtr logptr + peekArray (fromIntegral logsize) logptr + return $ P.unlines [ "Could not link program" + , P.map (toEnum . fromEnum) infoLog + ] + throwError err + else do + liftIO $ forM_ shaders glDeleteShader + return program +-------------------------------------------------------------------------------- +-- Loading shaders and compiling a program. +-------------------------------------------------------------------------------- +loadSourcePaths :: MonadIO m + => ShaderSteps (ts :: [*]) FilePath + -> m (ShaderSteps ts ByteString) +loadSourcePaths = (ShaderSteps <$>) . mapM (liftIO . B.readFile) . unShaderSteps + +compileSources + :: forall m ts. (MonadIO m, MonadError String m, IsShaderType ts [GLenum]) + => ShaderSteps (ts :: [*]) ByteString + -> m (ShaderSteps ts GLuint) +compileSources = + (ShaderSteps <$>) . zipWithM (flip compileOGLShader) types . unShaderSteps + where types = getShaderType (Proxy :: Proxy ts) + +compileProgram + :: (MonadIO m, MonadError String m, GetLits as [(String, Integer)]) + => Proxy (as :: [*]) + -> ShaderSteps (ts :: [*]) GLuint + -> m GLuint +compileProgram p = compileOGLProgram (getSymbols p) . unShaderSteps + +-- | Compile all shader programs and return a "sum renderer". +loadSimple2DShader :: (MonadIO m, MonadError String m) => m Simple2DShader +loadSimple2DShader = do + vertName <- liftIO simple2dVertFilePath + fragName <- liftIO simple2dFragFilePath + let paths :: ShaderSteps '[VertexShader, FragmentShader] FilePath + paths = ShaderSteps [vertName, fragName] + sources <- loadSourcePaths paths + shaders <- compileSources sources + compileProgram (Proxy :: Proxy Simple2DAttribs) shaders diff --git a/src/Gelatin/GL/TH.hs b/src/Gelatin/GL/TH.hs new file mode 100644 --- /dev/null +++ b/src/Gelatin/GL/TH.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module Gelatin.GL.TH where + +import Control.Exception (assert) +import Data.Proxy (Proxy (..)) +import Foreign.C.String (withCString) +import GHC.TypeLits (KnownSymbol, symbolVal) +import Graphics.GL +import Language.Haskell.TH + +import Gelatin.Shaders + +genUniform :: TypeQ + -- ^ The type of the uniform value. + -- Most likely 'Bool', 'Float', 'V3', 'M44', etc. + -> ExpQ + -- ^ The function that marshals the value to the shader. + -> DecsQ +genUniform typ func = + [d| + instance KnownSymbol name => HasGenFunc (Uniform name $typ) where + type GenFunc (Uniform name $typ) = GLuint -> $typ -> IO () + genFunction _ program val = do + let ident = symbolVal (Proxy :: Proxy name) + loc <- withCString ident $ glGetUniformLocation program + $func loc val + glGetError >>= \case + 0 -> return () + e -> do + putStrLn $ unwords [ "Could not update uniform" + , ident + , "with value" + , show val + , ", encountered error (" ++ show e ++ ")" + , show (GL_INVALID_OPERATION, "invalid operation") + , show (GL_INVALID_VALUE, "invalid value") + ] + assert False $ return () + + |]