packages feed

gelatin-gl (empty) → 0.1.0.0

raw patch · 10 files changed

+1384/−0 lines, 10 filesdep +JuicyPixelsdep +basedep +bytestringsetup-changed

Dependencies added: JuicyPixels, base, bytestring, containers, directory, either, filepath, gelatin, gelatin-gl, gelatin-shaders, gl, lens, linear, mtl, template-haskell, transformers, vector

Files

+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Example.hs view
@@ -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"
+ gelatin-gl.cabal view
@@ -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
+ src/Gelatin/GL.hs view
@@ -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 <schell@takt.com>+--+-- ["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
+ src/Gelatin/GL/Common.hs view
@@ -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+               }
+ src/Gelatin/GL/Compiler.hs view
@@ -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+  }
+ src/Gelatin/GL/Renderer.hs view
@@ -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 ()
+ src/Gelatin/GL/Shader.hs view
@@ -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
+ src/Gelatin/GL/TH.hs view
@@ -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 ()++  |]