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.UserData as T
import Types.Sprite 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 #-} {-# LANGUAGE TypeFamilies #-}
module Types.Sprite where module Types.Sprite where
import Data.Maybe (maybe)
import qualified Data.Map.Strict as M
import SDL (get, ($=)) import SDL (get, ($=))
import qualified Graphics.Rendering.OpenGL as GL 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 Codec.Picture
import Linear import Linear
import Foreign.Ptr
import Foreign.Marshal.Utils (with)
import Unsafe.Coerce (unsafeCoerce)
-- internal imports -- internal imports
import Classes.Renderable import Classes.Renderable
import Types.CanvasShader
data SpriteRenderObjects = SpriteRenderObjects data SpriteRenderObjects = SpriteRenderObjects
{ roVAO :: GL.VertexArrayObject { roVAO :: GL.VertexArrayObject
@ -20,7 +31,7 @@ data SpriteRenderObjects = SpriteRenderObjects
} }
data SpriteShaderObjects = SpriteShaderObjects data SpriteShaderObjects = SpriteShaderObjects
{ soProgram :: GLU.ShaderProgram { soProgram :: CanvasShader
} }
data Sprite = Sprite data Sprite = Sprite
@ -35,10 +46,10 @@ instance Renderable Sprite where
init init
(SpriteRenderObjects vao vbo) (SpriteRenderObjects vao vbo)
(SpriteShaderObjects prog) (SpriteShaderObjects (CanvasShader att uni prog))
texture texture
_ = do _ = do
GL.currentProgram $= Just (GLU.program prog) GL.currentProgram $= Just prog
GL.bindVertexArrayObject $= Just vao GL.bindVertexArrayObject $= Just vao
GL.activeTexture $= GL.TextureUnit 0 GL.activeTexture $= GL.TextureUnit 0
GL.textureBinding GL.Texture2D $= Just texture GL.textureBinding GL.Texture2D $= Just texture
@ -47,7 +58,7 @@ instance Renderable Sprite where
draw draw
(SpriteRenderObjects vao vbo) (SpriteRenderObjects vao vbo)
(SpriteShaderObjects prog) (SpriteShaderObjects (CanvasShader att uni prog))
(Sprite pos@(V2 px py) size) = do (Sprite pos@(V2 px py) size) = do
let (V2 sx sy) = fmap fromIntegral size let (V2 sx sy) = fmap fromIntegral size
model = fmap (fmap fromIntegral) $ V4 model = fmap (fmap fromIntegral) $ V4
@ -58,8 +69,15 @@ instance Renderable Sprite where
:: M44 Float :: M44 Float
projection = ortho (-960) 960 (-540) 540 (-1) 1 projection = ortho (-960) 960 (-540) 540 (-1) 1
-- putStrLn $ show model -- 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 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 clean _ = do
GL.currentProgram $= (Nothing :: Maybe GL.Program) GL.currentProgram $= (Nothing :: Maybe GL.Program)

View file

@ -45,11 +45,11 @@ data Subsystems = Subsystems
, subMouse :: SubMouse , subMouse :: SubMouse
} }
newtype SubWindow = SubWindow (TVar [(UUID, WindowMessage -> Affection UserData ())]) newtype SubWindow = SubWindow (TVar [(UUID, WindowMessage -> Affection ())])
newtype SubMouse = SubMouse (TVar [(UUID, MouseMessage -> Affection UserData ())]) newtype SubMouse = SubMouse (TVar [(UUID, MouseMessage -> Affection ())])
instance Participant SubWindow UserData where instance Participant SubWindow where
type Mesg SubWindow UserData = WindowMessage type Mesg SubWindow = WindowMessage
partSubscribers (SubWindow t) = genericSubscribers t partSubscribers (SubWindow t) = genericSubscribers t
@ -57,11 +57,11 @@ instance Participant SubWindow UserData where
partUnSubscribe (SubWindow t) = genericUnSubscribe t partUnSubscribe (SubWindow t) = genericUnSubscribe t
instance SDLSubsystem SubWindow UserData where instance SDLSubsystem SubWindow where
consumeSDLEvents = consumeSDLWindowEvents consumeSDLEvents = consumeSDLWindowEvents
instance Participant SubMouse UserData where instance Participant SubMouse where
type Mesg SubMouse UserData = MouseMessage type Mesg SubMouse = MouseMessage
partSubscribers (SubMouse t) = genericSubscribers t partSubscribers (SubMouse t) = genericSubscribers t
@ -69,29 +69,29 @@ instance Participant SubMouse UserData where
partUnSubscribe (SubMouse t) = genericUnSubscribe t partUnSubscribe (SubMouse t) = genericUnSubscribe t
instance SDLSubsystem SubMouse UserData where instance SDLSubsystem SubMouse where
consumeSDLEvents = consumeSDLMouseEvents consumeSDLEvents = consumeSDLMouseEvents
genericSubscribers genericSubscribers
:: TVar [(UUID, msg -> Affection UserData ())] :: TVar [(UUID, msg -> Affection ())]
-> Affection UserData [(msg -> Affection UserData ())] -> Affection [(msg -> Affection ())]
genericSubscribers t = do genericSubscribers t = do
subTups <- liftIO $ readTVarIO t subTups <- liftIO $ readTVarIO t
return $ map snd subTups return $ map snd subTups
genericSubscribe genericSubscribe
:: TVar [(UUID, msg -> Affection UserData ())] :: TVar [(UUID, msg -> Affection ())]
-> (msg -> Affection UserData ()) -> (msg -> Affection ())
-> Affection UserData UUID -> Affection UUID
genericSubscribe t funct = do genericSubscribe t funct = do
uu <- genUUID uu <- genUUID
liftIO $ atomically $ modifyTVar' t ((uu, funct) :) liftIO $ atomically $ modifyTVar' t ((uu, funct) :)
return uu return uu
genericUnSubscribe genericUnSubscribe
:: TVar [(UUID, msg -> Affection UserData ())] :: TVar [(UUID, msg -> Affection ())]
-> UUID -> UUID
-> Affection UserData () -> Affection ()
genericUnSubscribe t uu = genericUnSubscribe t uu =
liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uu)) liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uu))
where where

View file

@ -26,12 +26,11 @@ executable canvas
Renderer Renderer
-- other-extensions: -- other-extensions:
ghc-options: -Wall ghc-options: -Wall
build-depends: base ^>=4.12.0.0 build-depends: base >= 4.12.0.0 && < 5
, affection , affection
, sdl2 ^>=2.5.0.0 , sdl2 ^>=2.5.0.0
, OpenGL , OpenGL
, OpenGLRaw , OpenGLRaw
, GLUtil
, JuicyPixels , JuicyPixels
, JuicyPixels-extra , JuicyPixels-extra
, stm , stm

View file

@ -25,23 +25,23 @@ let
doHaddock = false; doHaddock = false;
}) {}; }) {};
GLUtil = with haskellPackages; callPackage( #GLUtil = with haskellPackages; callPackage(
{ mkDerivation, array, base, bytestring, containers, directory # { mkDerivation, array, base, bytestring, containers, directory
, filepath, hpp, JuicyPixels, linear, OpenGL, OpenGLRaw, stdenv # , filepath, hpp, JuicyPixels, linear, OpenGL, OpenGLRaw, stdenv
, transformers, vector # , transformers, vector
}: # }:
mkDerivation { # mkDerivation {
pname = "GLUtil"; # pname = "GLUtil";
version = "0.10.3"; # version = "0.10.3";
sha256 = "1933540d309209fb90f0632336ee6c54e160a12da8508dadaf16882a2358ec27"; # sha256 = "1933540d309209fb90f0632336ee6c54e160a12da8508dadaf16882a2358ec27";
libraryHaskellDepends = [ # libraryHaskellDepends = [
array base bytestring containers directory filepath hpp JuicyPixels # array base bytestring containers directory filepath hpp JuicyPixels
linear OpenGL OpenGLRaw transformers vector # linear OpenGL OpenGLRaw transformers vector
]; # ];
libraryToolDepends = [ hpp ]; # libraryToolDepends = [ hpp ];
description = "Miscellaneous OpenGL utilities"; # description = "Miscellaneous OpenGL utilities";
license = stdenv.lib.licenses.bsd3; # license = stdenv.lib.licenses.bsd3;
}) {}; # }) {};
f = { mkDerivation, base, bytestring, containers f = { mkDerivation, base, bytestring, containers
, JuicyPixels, JuicyPixels-extra, linear, OpenGL, OpenGLRaw , JuicyPixels, JuicyPixels-extra, linear, OpenGL, OpenGLRaw
@ -54,7 +54,7 @@ let
isLibrary = false; isLibrary = false;
isExecutable = true; isExecutable = true;
executableHaskellDepends = [ executableHaskellDepends = [
affection base bytestring containers GLUtil JuicyPixels affection base bytestring containers JuicyPixels
JuicyPixels-extra linear OpenGL OpenGLRaw random sdl2 stm JuicyPixels-extra linear OpenGL OpenGLRaw random sdl2 stm
]; ];
description = "A test implementation for drawing images with SDL2 and OpenGL"; description = "A test implementation for drawing images with SDL2 and OpenGL";