diff --git a/app/Types.hs b/app/Types.hs index f6ce908..bea86b1 100644 --- a/app/Types.hs +++ b/app/Types.hs @@ -4,3 +4,4 @@ module Types import Types.UserData as T import Types.Sprite as T +import Types.CanvasShader as T diff --git a/app/Types/CanvasShader.hs b/app/Types/CanvasShader.hs new file mode 100644 index 0000000..29b6f09 --- /dev/null +++ b/app/Types/CanvasShader.hs @@ -0,0 +1,26 @@ +module Types.CanvasShader where + +import Data.List as L + +import Data.Map.Strict + +import Graphics.Rendering.OpenGL (get) +import qualified Graphics.Rendering.OpenGL as GL + +data CanvasShader = CanvasShader + { shaderAttribs :: Map String (GL.AttribLocation, GL.VariableType) + , shaderUniforms :: Map String (GL.UniformLocation, GL.VariableType) + , shaderProgram :: GL.Program + } + +makeCanvasShader :: GL.Program -> IO CanvasShader +makeCanvasShader p = CanvasShader + <$> (fromList <$> ((get (GL.activeAttribs p) >>= mapM (aux (GL.attribLocation p))))) + <*> (fromList <$> ((get (GL.activeUniforms p) + >>= mapM (aux (GL.uniformLocation p) . on3 trimArray)))) + <*> (pure p) + where aux f (_,t,name) = get (f name) >>= \l -> return (name, (l, t)) + on3 f (a,b,c) = (a, b, f c) + -- An array uniform, foo, is sometimes given the name "foo" and + -- sometimes the name "foo[0]". We strip off the "[0]" if present. + trimArray n = if "[0]" `isSuffixOf` n then L.take (length n - 3) n else n diff --git a/app/Types/Sprite.hs b/app/Types/Sprite.hs index a30ae27..7923b88 100644 --- a/app/Types/Sprite.hs +++ b/app/Types/Sprite.hs @@ -1,18 +1,29 @@ {-# LANGUAGE TypeFamilies #-} module Types.Sprite where +import Data.Maybe (maybe) +import qualified Data.Map.Strict as M + import SDL (get, ($=)) import qualified Graphics.Rendering.OpenGL as GL -import qualified Graphics.GLUtil as GLU +import qualified Graphics.GL.Core33 as GLRaw +-- import qualified Graphics.GLUtil as GLU import Codec.Picture import Linear +import Foreign.Ptr + +import Foreign.Marshal.Utils (with) + +import Unsafe.Coerce (unsafeCoerce) + -- internal imports import Classes.Renderable +import Types.CanvasShader data SpriteRenderObjects = SpriteRenderObjects { roVAO :: GL.VertexArrayObject @@ -20,7 +31,7 @@ data SpriteRenderObjects = SpriteRenderObjects } data SpriteShaderObjects = SpriteShaderObjects - { soProgram :: GLU.ShaderProgram + { soProgram :: CanvasShader } data Sprite = Sprite @@ -35,10 +46,10 @@ instance Renderable Sprite where init (SpriteRenderObjects vao vbo) - (SpriteShaderObjects prog) + (SpriteShaderObjects (CanvasShader att uni prog)) texture _ = do - GL.currentProgram $= Just (GLU.program prog) + GL.currentProgram $= Just prog GL.bindVertexArrayObject $= Just vao GL.activeTexture $= GL.TextureUnit 0 GL.textureBinding GL.Texture2D $= Just texture @@ -47,7 +58,7 @@ instance Renderable Sprite where draw (SpriteRenderObjects vao vbo) - (SpriteShaderObjects prog) + (SpriteShaderObjects (CanvasShader att uni prog)) (Sprite pos@(V2 px py) size) = do let (V2 sx sy) = fmap fromIntegral size model = fmap (fmap fromIntegral) $ V4 @@ -58,8 +69,15 @@ instance Renderable Sprite where :: M44 Float projection = ortho (-960) 960 (-540) 540 (-1) 1 -- putStrLn $ show model - GLU.setUniform prog "pm" (projection !*! model) + maybe + (const (putStrLn warn >> return ())) + (flip asUniform . fst) + (M.lookup "pm" uni) + (projection !*! model) GL.drawArrays GL.Triangles 0 6 + where + warn = "WARNING: uniform pm is not active" + v `asUniform` loc = with v $ GLRaw.glUniformMatrix4fv (unsafeCoerce loc) 1 1 . castPtr clean _ = do GL.currentProgram $= (Nothing :: Maybe GL.Program) diff --git a/app/Types/UserData.hs b/app/Types/UserData.hs index 0556e36..86f29fc 100644 --- a/app/Types/UserData.hs +++ b/app/Types/UserData.hs @@ -45,11 +45,11 @@ data Subsystems = Subsystems , subMouse :: SubMouse } -newtype SubWindow = SubWindow (TVar [(UUID, WindowMessage -> Affection UserData ())]) -newtype SubMouse = SubMouse (TVar [(UUID, MouseMessage -> Affection UserData ())]) +newtype SubWindow = SubWindow (TVar [(UUID, WindowMessage -> Affection ())]) +newtype SubMouse = SubMouse (TVar [(UUID, MouseMessage -> Affection ())]) -instance Participant SubWindow UserData where - type Mesg SubWindow UserData = WindowMessage +instance Participant SubWindow where + type Mesg SubWindow = WindowMessage partSubscribers (SubWindow t) = genericSubscribers t @@ -57,11 +57,11 @@ instance Participant SubWindow UserData where partUnSubscribe (SubWindow t) = genericUnSubscribe t -instance SDLSubsystem SubWindow UserData where +instance SDLSubsystem SubWindow where consumeSDLEvents = consumeSDLWindowEvents -instance Participant SubMouse UserData where - type Mesg SubMouse UserData = MouseMessage +instance Participant SubMouse where + type Mesg SubMouse = MouseMessage partSubscribers (SubMouse t) = genericSubscribers t @@ -69,29 +69,29 @@ instance Participant SubMouse UserData where partUnSubscribe (SubMouse t) = genericUnSubscribe t -instance SDLSubsystem SubMouse UserData where +instance SDLSubsystem SubMouse where consumeSDLEvents = consumeSDLMouseEvents genericSubscribers - :: TVar [(UUID, msg -> Affection UserData ())] - -> Affection UserData [(msg -> Affection UserData ())] + :: TVar [(UUID, msg -> Affection ())] + -> Affection [(msg -> Affection ())] genericSubscribers t = do subTups <- liftIO $ readTVarIO t return $ map snd subTups genericSubscribe - :: TVar [(UUID, msg -> Affection UserData ())] - -> (msg -> Affection UserData ()) - -> Affection UserData UUID + :: TVar [(UUID, msg -> Affection ())] + -> (msg -> Affection ()) + -> Affection UUID genericSubscribe t funct = do uu <- genUUID liftIO $ atomically $ modifyTVar' t ((uu, funct) :) return uu genericUnSubscribe - :: TVar [(UUID, msg -> Affection UserData ())] + :: TVar [(UUID, msg -> Affection ())] -> UUID - -> Affection UserData () + -> Affection () genericUnSubscribe t uu = liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uu)) where diff --git a/canvas.cabal b/canvas.cabal index 2a708f7..9160511 100644 --- a/canvas.cabal +++ b/canvas.cabal @@ -26,12 +26,11 @@ executable canvas Renderer -- other-extensions: ghc-options: -Wall - build-depends: base ^>=4.12.0.0 + build-depends: base >= 4.12.0.0 && < 5 , affection , sdl2 ^>=2.5.0.0 , OpenGL , OpenGLRaw - , GLUtil , JuicyPixels , JuicyPixels-extra , stm diff --git a/shell.nix b/shell.nix index 3f7830b..aaaffe0 100644 --- a/shell.nix +++ b/shell.nix @@ -25,23 +25,23 @@ let doHaddock = false; }) {}; - GLUtil = with haskellPackages; callPackage( - { mkDerivation, array, base, bytestring, containers, directory - , filepath, hpp, JuicyPixels, linear, OpenGL, OpenGLRaw, stdenv - , transformers, vector - }: - mkDerivation { - pname = "GLUtil"; - version = "0.10.3"; - sha256 = "1933540d309209fb90f0632336ee6c54e160a12da8508dadaf16882a2358ec27"; - libraryHaskellDepends = [ - array base bytestring containers directory filepath hpp JuicyPixels - linear OpenGL OpenGLRaw transformers vector - ]; - libraryToolDepends = [ hpp ]; - description = "Miscellaneous OpenGL utilities"; - license = stdenv.lib.licenses.bsd3; - }) {}; + #GLUtil = with haskellPackages; callPackage( + # { mkDerivation, array, base, bytestring, containers, directory + # , filepath, hpp, JuicyPixels, linear, OpenGL, OpenGLRaw, stdenv + # , transformers, vector + # }: + # mkDerivation { + # pname = "GLUtil"; + # version = "0.10.3"; + # sha256 = "1933540d309209fb90f0632336ee6c54e160a12da8508dadaf16882a2358ec27"; + # libraryHaskellDepends = [ + # array base bytestring containers directory filepath hpp JuicyPixels + # linear OpenGL OpenGLRaw transformers vector + # ]; + # libraryToolDepends = [ hpp ]; + # description = "Miscellaneous OpenGL utilities"; + # license = stdenv.lib.licenses.bsd3; + # }) {}; f = { mkDerivation, base, bytestring, containers , JuicyPixels, JuicyPixels-extra, linear, OpenGL, OpenGLRaw @@ -54,7 +54,7 @@ let isLibrary = false; isExecutable = true; executableHaskellDepends = [ - affection base bytestring containers GLUtil JuicyPixels + affection base bytestring containers JuicyPixels JuicyPixels-extra linear OpenGL OpenGLRaw random sdl2 stm ]; description = "A test implementation for drawing images with SDL2 and OpenGL";