throw out more of GLUtil

This commit is contained in:
nek0 2020-05-13 05:42:32 +02:00
parent 4b37d5f51c
commit 1acf7f2a0f
6 changed files with 85 additions and 41 deletions

View file

@ -4,3 +4,4 @@ module Types
import Types.UserData as T
import Types.Sprite as T
import Types.CanvasShader as T

26
app/Types/CanvasShader.hs Normal file
View file

@ -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

View file

@ -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)

View file

@ -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

View file

@ -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

View file

@ -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";