Compare commits
11 commits
Author | SHA1 | Date | |
---|---|---|---|
nek0 | 102ff2ec77 | ||
nek0 | 4f414f1410 | ||
nek0 | 74387cf18b | ||
nek0 | 8f5ea5531c | ||
nek0 | 9cd2ca9298 | ||
nek0 | 8be1acee77 | ||
nek0 | 055a12e94f | ||
nek0 | 9fca6a7617 | ||
nek0 | fa0c6c4670 | ||
nek0 | ad1e3579e8 | ||
nek0 | dc68854f19 |
28
README.md
28
README.md
|
@ -19,3 +19,31 @@ There are some major deviations from the tutorial setup here as follows:
|
|||
|
||||
I leave as many helpful comments as possible throughout the code, so feel free
|
||||
to peruse it.
|
||||
|
||||
## Mapped input events
|
||||
|
||||
### Keyboard
|
||||
|
||||
To switch to a scene, press one of the buttons below, To return to the Menu,
|
||||
press `Escape`.
|
||||
|
||||
## `F1` - Colour changer
|
||||
|
||||
Use the keys `1` through `4` to increase the values of R, G, B or A of the
|
||||
background colour. Press `Left Shift` and the number key to decrease it.
|
||||
|
||||
## `F2` - Textured quads
|
||||
|
||||
Use keys `1` and `2` to switch between the textured quads, move them forward on
|
||||
the x and y axis by pressing `X` and `Y` respectively or backward using
|
||||
`Left Shift` and the appropriate key.
|
||||
|
||||
## `F3` - Textured quads batched statically
|
||||
|
||||
Move the quads forward on
|
||||
the x and y axis by pressing `X` and `Y` respectively or backward using
|
||||
`Left Shift` and the appropriate key.
|
||||
|
||||
## `F4` - Textured quads batched dynamically
|
||||
|
||||
No interaction.
|
||||
|
|
|
@ -32,14 +32,21 @@ executable renderer-tutorial
|
|||
, JuicyPixels-extra
|
||||
, StateVar
|
||||
, lens
|
||||
, clock
|
||||
other-modules: BindableClass
|
||||
, BufferClass
|
||||
, VertexBuffer
|
||||
, VertexBufferDynamic
|
||||
, VertexArray
|
||||
, IndexBuffer
|
||||
, Shader
|
||||
, Renderer
|
||||
, Texture
|
||||
, EventHandler
|
||||
, Scenes.SceneClass
|
||||
, Scenes.ClearColor
|
||||
, Scenes.Texture2D
|
||||
, Scenes.Texture2DBatched
|
||||
, Scenes.Texture2DBatchedDynamic
|
||||
hs-source-dirs: src
|
||||
default-language: Haskell2010
|
||||
|
|
16
res/shaders/fragbatch.shader
Normal file
16
res/shaders/fragbatch.shader
Normal file
|
@ -0,0 +1,16 @@
|
|||
#version 330 core
|
||||
|
||||
layout(location = 0) out vec4 color;
|
||||
|
||||
in vec4 v_color;
|
||||
in vec2 v_texCoord;
|
||||
in float v_texIndex;
|
||||
|
||||
uniform sampler2D u_textures[2];
|
||||
|
||||
void main()
|
||||
{
|
||||
//vec4 texColor = texture(u_texture, v_texCoord);
|
||||
int index = int(v_texIndex);
|
||||
color = texture(u_textures[index], v_texCoord);
|
||||
}
|
20
res/shaders/vertbatch.shader
Normal file
20
res/shaders/vertbatch.shader
Normal file
|
@ -0,0 +1,20 @@
|
|||
#version 330 core
|
||||
|
||||
layout(location = 0) in vec3 a_position;
|
||||
layout(location = 1) in vec4 a_color;
|
||||
layout(location = 2) in vec2 a_texCoord;
|
||||
layout(location = 3) in float a_texIndex;
|
||||
|
||||
out vec4 v_color;
|
||||
out vec2 v_texCoord;
|
||||
out float v_texIndex;
|
||||
|
||||
uniform mat4 u_mvp;
|
||||
|
||||
void main()
|
||||
{
|
||||
gl_Position = u_mvp * vec4(a_position, 1);
|
||||
v_texCoord = a_texCoord;
|
||||
v_color = a_color;
|
||||
v_texIndex = a_texIndex;
|
||||
}
|
BIN
res/textures/brainbulb_on.flat.png
Normal file
BIN
res/textures/brainbulb_on.flat.png
Normal file
Binary file not shown.
After Width: | Height: | Size: 106 KiB |
|
@ -4,7 +4,7 @@ let
|
|||
|
||||
inherit (nixpkgs) pkgs;
|
||||
|
||||
f = { mkDerivation, base, bytestring, JuicyPixels
|
||||
f = { mkDerivation, base, bytestring, clock, JuicyPixels
|
||||
, JuicyPixels-extra, lens, linear, monad-loops, OpenGL, OpenGLRaw
|
||||
, random, sdl2, StateVar, stdenv, vector
|
||||
}:
|
||||
|
@ -15,7 +15,7 @@ let
|
|||
isLibrary = false;
|
||||
isExecutable = true;
|
||||
executableHaskellDepends = [
|
||||
base bytestring JuicyPixels JuicyPixels-extra lens linear
|
||||
base bytestring clock JuicyPixels JuicyPixels-extra lens linear
|
||||
monad-loops OpenGL OpenGLRaw random sdl2 StateVar vector
|
||||
];
|
||||
license = stdenv.lib.licenses.gpl3;
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
module EventHandler where
|
||||
|
||||
import Control.Monad (when)
|
||||
import Control.Monad
|
||||
|
||||
import Control.Concurrent.MVar
|
||||
|
||||
|
@ -9,16 +9,17 @@ import Control.Lens as Lens
|
|||
import Linear
|
||||
|
||||
import qualified SDL
|
||||
import qualified SDL.Internal.Numbered as SDL
|
||||
|
||||
import qualified Graphics.Rendering.OpenGL as GL
|
||||
|
||||
moveQuad
|
||||
moveObj
|
||||
:: MVar (M44 GL.GLfloat)
|
||||
-> MVar (M44 GL.GLfloat)
|
||||
-> MVar (M44 GL.GLfloat)
|
||||
-> MVar [SDL.Event]
|
||||
-> IO ()
|
||||
moveQuad proj view model evs =
|
||||
moveObj proj view model evs =
|
||||
modifyMVar_ proj (\mproj -> do
|
||||
modifyMVar_ view (\mview -> do
|
||||
modifyMVar_ model (\mmodel -> do
|
||||
|
@ -34,7 +35,7 @@ moveQuad proj view model evs =
|
|||
let trans =
|
||||
mkTransformationMat
|
||||
(identity :: M33 GL.GLfloat)
|
||||
( ( if not (SDL.keyModifierLeftShift mod)
|
||||
( ( if SDL.keyModifierLeftShift mod
|
||||
then (-1)
|
||||
else 1
|
||||
)
|
||||
|
@ -43,7 +44,7 @@ moveQuad proj view model evs =
|
|||
SDL.KeycodeX ->
|
||||
V3 1 0 0
|
||||
SDL.KeycodeY ->
|
||||
V3 0 (-1) 0
|
||||
V3 0 1 0
|
||||
_ ->
|
||||
V3 0 0 0
|
||||
)
|
||||
|
@ -65,3 +66,36 @@ moveQuad proj view model evs =
|
|||
)
|
||||
return mproj
|
||||
)
|
||||
|
||||
switchObject
|
||||
:: MVar (MVar (M44 GL.GLfloat))
|
||||
-> [MVar (M44 GL.GLfloat)]
|
||||
-> MVar [SDL.Event]
|
||||
-> IO ()
|
||||
switchObject focus elems evs =
|
||||
modifyMVar_ focus (\foc -> do
|
||||
foldM
|
||||
(\acc ev -> case SDL.eventPayload ev of
|
||||
(SDL.KeyboardEvent
|
||||
(SDL.KeyboardEventData
|
||||
_
|
||||
SDL.Pressed
|
||||
_
|
||||
(SDL.Keysym code _ mod)
|
||||
))
|
||||
-> do
|
||||
let selectIndex = fromIntegral (SDL.toNumber code) - 30
|
||||
if ((selectIndex < 10) && (selectIndex >= 0)) &&
|
||||
(SDL.toNumber mod == 0) &&
|
||||
(selectIndex < length elems) &&
|
||||
(acc /= (elems !! selectIndex))
|
||||
then do
|
||||
print ("selected element number: " <> show selectIndex)
|
||||
return $ elems !! selectIndex
|
||||
else
|
||||
return foc
|
||||
_ -> return acc
|
||||
)
|
||||
foc
|
||||
=<< readMVar evs
|
||||
)
|
||||
|
|
175
src/Main.hs
175
src/Main.hs
|
@ -1,9 +1,11 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE Strict #-}
|
||||
module Main where
|
||||
|
||||
import SDL (($=), get)
|
||||
import qualified SDL
|
||||
import qualified SDL.Internal.Numbered as SDL
|
||||
import qualified SDL.Raw.Video as SDL (glSetAttribute)
|
||||
import qualified SDL.Raw.Enum as SDL
|
||||
|
||||
|
@ -29,20 +31,24 @@ import qualified Data.List as L
|
|||
|
||||
import System.Random (randomRIO)
|
||||
|
||||
import System.Clock
|
||||
|
||||
import Linear
|
||||
|
||||
-- internal imports
|
||||
|
||||
import BindableClass
|
||||
import BufferClass
|
||||
import VertexArray
|
||||
import VertexBuffer
|
||||
import IndexBuffer
|
||||
import Shader
|
||||
import Renderer
|
||||
import Texture
|
||||
import IndexBuffer
|
||||
|
||||
import EventHandler
|
||||
|
||||
import Scenes.SceneClass
|
||||
import Scenes.ClearColor
|
||||
import Scenes.Texture2D
|
||||
import Scenes.Texture2DBatched
|
||||
import Scenes.Texture2DBatchedDynamic
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
|
||||
|
@ -78,106 +84,30 @@ main = do
|
|||
version <- peekArray0 (0 :: Word8) =<< GLRaw.glGetString GLRaw.GL_VERSION
|
||||
print (B.pack version)
|
||||
|
||||
-- -- VERTICES
|
||||
|
||||
-- first, create and bind a vertex array object
|
||||
vao <- GL.genObjectName
|
||||
GL.bindVertexArrayObject $= Just vao
|
||||
|
||||
-- define vertices (positions of the rectangle corners) as List of Floats
|
||||
-- with added in texture coordinates
|
||||
let vertexPositions =
|
||||
-- 3D positions | texture coordinates
|
||||
[ 100, 100, 0, 0, 0
|
||||
, 233, 100, 0, 1, 0
|
||||
, 233, 300, 0, 1, 1
|
||||
, 100, 300, 0, 0, 1
|
||||
] :: [GL.GLfloat]
|
||||
|
||||
-- create draw order indices
|
||||
indices = [0, 1, 2, 2, 3, 0] :: [GL.GLuint]
|
||||
|
||||
-- construct new VertexBuffer and fill it with data
|
||||
vao <- newVertexArray
|
||||
vbo <- newVertexBuffer vertexPositions
|
||||
|
||||
-- rebind the vertex buffer
|
||||
bind vbo
|
||||
|
||||
-- enable and specify data layout of the in-memory vertices
|
||||
layout <- newVertexBufferLayout
|
||||
-- push vertex positions
|
||||
pushElements layout GL.Float 3
|
||||
-- pusht texture coordinates
|
||||
pushElements layout GL.Float 2
|
||||
|
||||
addBuffer vao vbo layout
|
||||
|
||||
-- -- MATRICES
|
||||
|
||||
let mproj = ortho 0 800 0 600 (-1) 1 :: M44 GL.GLfloat
|
||||
mview = mkTransformationMat (identity :: M33 GL.GLfloat) (V3 (-100) 0 0)
|
||||
mmodel = mkTransformationMat (identity :: M33 GL.GLfloat) (V3 200 200 0)
|
||||
|
||||
-- store the mtrices for later adjustments
|
||||
proj <- newMVar mproj
|
||||
view <- newMVar mview
|
||||
model <- newMVar mmodel
|
||||
|
||||
-- -- TEXTURE
|
||||
|
||||
-- generate and bind texture
|
||||
tex <- newTexture "res/textures/lynx.jpg" 0
|
||||
bind tex
|
||||
|
||||
-- construct new IndexBuffer and fill it with data
|
||||
ibo <- newIndexBuffer indices
|
||||
|
||||
-- -- SHADERS
|
||||
|
||||
sp <- newShader
|
||||
[ ShaderSource GL.VertexShader "./res/shaders/vert.shader"
|
||||
, ShaderSource GL.FragmentShader "./res/shaders/frag.shader"
|
||||
]
|
||||
[ "u_color"
|
||||
, "u_texture"
|
||||
, "u_mvp"
|
||||
]
|
||||
|
||||
-- -- tell the shader where to find the texture
|
||||
bind sp
|
||||
setUniform sp "u_texture" (texSlot tex)
|
||||
setUniform sp "u_mvp" (mproj !*! mview !*! mmodel)
|
||||
|
||||
-- -- UNIFORMS
|
||||
|
||||
-- create MVars for pulsating red channel
|
||||
red <- newMVar 0
|
||||
increment <- newMVar 0.05
|
||||
|
||||
err <- get GL.errors
|
||||
print $ "pre-loop errors: " <> show err
|
||||
|
||||
-- -- EVENTING AND DRAWING
|
||||
-- -- Constructing Scenes
|
||||
|
||||
-- -- UNBINDING ALL BUFFERS AND VERTEX ARRAYS
|
||||
|
||||
unbind vao
|
||||
unbind vbo
|
||||
unbind ibo
|
||||
unbind sp
|
||||
-- Construct state machine for the Scenes
|
||||
curScene <- newEmptyMVar :: IO (MVar Scene)
|
||||
|
||||
-- -- LOOPING
|
||||
|
||||
-- initial poll for events
|
||||
evs <- newMVar =<< SDL.pollEvents
|
||||
|
||||
-- time container for dt
|
||||
time <- newMVar =<< getTime Monotonic
|
||||
|
||||
-- Loop running until window closes
|
||||
whileM_ (notElem (SDL.WindowClosedEvent (SDL.WindowClosedEventData window))
|
||||
<$> map SDL.eventPayload <$> readMVar evs) $ do
|
||||
-- poll again
|
||||
void $ swapMVar evs =<< SDL.pollEvents
|
||||
|
||||
currentEvents <- readMVar evs
|
||||
|
||||
-- -- OBEY THE HYPNOTOAD!
|
||||
-- clearcol <- GL.Color4
|
||||
-- <$> (randomRIO (0, 1))
|
||||
|
@ -186,19 +116,26 @@ main = do
|
|||
-- <*> pure 1
|
||||
-- GL.clearColor $= clearcol
|
||||
|
||||
-- -- rebind everything neccessary for draw call
|
||||
bind sp
|
||||
hasSelect <- not <$> isEmptyMVar curScene
|
||||
if hasSelect
|
||||
then do
|
||||
now <- getTime Monotonic
|
||||
before <- readMVar time
|
||||
let dt = fromIntegral
|
||||
(toNanoSecs $ diffTimeSpec before now) / (10 ^ (9 :: Int))
|
||||
(Scene sceneObject) <- readMVar curScene
|
||||
onEvents sceneObject currentEvents
|
||||
update sceneObject dt
|
||||
render sceneObject
|
||||
void $ swapMVar time now
|
||||
else do
|
||||
GL.clearColor $= GL.Color4 0 0 0 1
|
||||
GL.clear [GL.ColorBuffer]
|
||||
|
||||
-- retrieve matrices from MVars and modify them on demand
|
||||
moveQuad proj view model evs
|
||||
mproj <- readMVar proj
|
||||
mview <- readMVar view
|
||||
mmodel <- readMVar model
|
||||
setUniform sp "u_mvp" (mproj !*! mview !*! mmodel)
|
||||
-- Switch to different scene on keyboard presses F1 thourgh F?
|
||||
|
||||
sceneSwitch curScene currentEvents
|
||||
|
||||
-- the actual drawing happens here
|
||||
draw vao ibo sp
|
||||
-- GL.drawElements GL.Triangles 6 GL.UnsignedInt nullPtr
|
||||
err <- get GL.errors
|
||||
when (not $ null err) (print $ "loop errors: " <> show err)
|
||||
|
||||
|
@ -221,3 +158,39 @@ main = do
|
|||
|
||||
-- This is the end.
|
||||
putStrLn "Bye!"
|
||||
|
||||
|
||||
sceneSwitch :: MVar Scene -> [SDL.Event] -> IO ()
|
||||
sceneSwitch curScene evs = mapM_ (switch . SDL.eventPayload) evs
|
||||
where
|
||||
switch (SDL.KeyboardEvent
|
||||
(SDL.KeyboardEventData
|
||||
_
|
||||
SDL.Pressed
|
||||
_
|
||||
(SDL.Keysym _ code mod))) =
|
||||
when (SDL.toNumber mod == 0) $
|
||||
case code of
|
||||
SDL.KeycodeEscape -> do
|
||||
isEmpty <- isEmptyMVar curScene
|
||||
when (not isEmpty) $
|
||||
void $ tryTakeMVar curScene
|
||||
SDL.KeycodeF1 -> do
|
||||
isEmpty <- isEmptyMVar curScene
|
||||
when isEmpty $ do
|
||||
putMVar curScene =<< fmap Scene (initScene @ClearColor)
|
||||
SDL.KeycodeF2 -> do
|
||||
isEmpty <- isEmptyMVar curScene
|
||||
when isEmpty $ do
|
||||
putMVar curScene =<< fmap Scene (initScene @Texture2D)
|
||||
SDL.KeycodeF3 -> do
|
||||
isEmpty <- isEmptyMVar curScene
|
||||
when isEmpty $ do
|
||||
putMVar curScene =<< fmap Scene (initScene @Texture2DBatched)
|
||||
SDL.KeycodeF4 -> do
|
||||
isEmpty <- isEmptyMVar curScene
|
||||
when isEmpty $ do
|
||||
putMVar curScene =<< fmap Scene (initScene @Texture2DBatchedDynamic)
|
||||
_ ->
|
||||
return ()
|
||||
switch _ = return ()
|
||||
|
|
|
@ -15,7 +15,6 @@ import Shader
|
|||
|
||||
draw :: VertexArray -> (IndexBuffer a) -> Shader -> IO ()
|
||||
draw va ib sp = do
|
||||
clear
|
||||
bind sp
|
||||
bind va
|
||||
bind ib
|
||||
|
|
77
src/Scenes/ClearColor.hs
Normal file
77
src/Scenes/ClearColor.hs
Normal file
|
@ -0,0 +1,77 @@
|
|||
module Scenes.ClearColor where
|
||||
|
||||
import SDL (($=), get)
|
||||
import qualified SDL
|
||||
import qualified SDL.Internal.Numbered as SDL
|
||||
|
||||
import qualified Graphics.Rendering.OpenGL as GL
|
||||
|
||||
import Control.Monad
|
||||
|
||||
import Control.Concurrent.MVar
|
||||
|
||||
import Linear
|
||||
|
||||
-- internal imports
|
||||
|
||||
import BindableClass
|
||||
import BufferClass
|
||||
import VertexArray
|
||||
import VertexBuffer
|
||||
import IndexBuffer
|
||||
import Shader
|
||||
import Renderer
|
||||
import Texture
|
||||
|
||||
import Scenes.SceneClass
|
||||
|
||||
data ClearColor = ClearColor
|
||||
{ ccColor :: MVar (V4 GL.GLfloat)
|
||||
}
|
||||
|
||||
instance SceneClass ClearColor where
|
||||
|
||||
initScene = do
|
||||
ClearColor <$> newMVar (V4 0 0.2 0.3 1)
|
||||
|
||||
update _ _ = return ()
|
||||
|
||||
onEvents (ClearColor col) evs =
|
||||
modifyMVar_ col (\(V4 r g b a) -> do
|
||||
[nr, ng, nb, na] <- foldM
|
||||
(\acc ev -> case SDL.eventPayload ev of
|
||||
(SDL.KeyboardEvent
|
||||
(SDL.KeyboardEventData
|
||||
_
|
||||
SDL.Pressed
|
||||
_
|
||||
(SDL.Keysym _ code mod)
|
||||
)) -> do
|
||||
-- Scancode for key "1" 1 is 30
|
||||
let alter =
|
||||
map
|
||||
-- flip direction on pressed "Shift" key
|
||||
(if SDL.keyModifierLeftShift mod
|
||||
then ((-1) *)
|
||||
else id
|
||||
)
|
||||
-- alter colors only for key 1 to 4, ignore all others
|
||||
(case code of
|
||||
SDL.Keycode1 -> [1, 0, 0, 0]
|
||||
SDL.Keycode2 -> [0, 1, 0, 0]
|
||||
SDL.Keycode3 -> [0, 0, 1, 0]
|
||||
SDL.Keycode4 -> [0, 0, 0, 1]
|
||||
_ -> [0, 0, 0, 0]
|
||||
)
|
||||
return $ zipWith (+) acc (map (/ 256) alter)
|
||||
_ -> return acc
|
||||
)
|
||||
[r, g, b, a]
|
||||
evs
|
||||
return (V4 nr ng nb na)
|
||||
)
|
||||
|
||||
render (ClearColor col) = do
|
||||
(V4 r g b a) <- readMVar col
|
||||
GL.clearColor $= GL.Color4 r g b a
|
||||
GL.clear [GL.ColorBuffer]
|
23
src/Scenes/SceneClass.hs
Normal file
23
src/Scenes/SceneClass.hs
Normal file
|
@ -0,0 +1,23 @@
|
|||
{-# LANGUAGE ExistentialQuantification #-}
|
||||
module Scenes.SceneClass where
|
||||
|
||||
import qualified SDL
|
||||
|
||||
class SceneClass a where
|
||||
|
||||
-- | Perform initialization.
|
||||
initScene :: IO a
|
||||
|
||||
-- | Run updates on the data given the time elapsed since last frame
|
||||
update :: a -> Float -> IO ()
|
||||
|
||||
-- | Handle input events
|
||||
onEvents :: a -> [SDL.Event] -> IO ()
|
||||
|
||||
-- | perform the drawing
|
||||
render :: a -> IO ()
|
||||
|
||||
-- Existential type wrapper to make all Scenes implementing SceneClass
|
||||
-- homogenous.
|
||||
-- See more at https://wiki.haskell.org/Existential_type#Dynamic_dispatch_mechanism_of_OOP
|
||||
data Scene = forall a. SceneClass a => Scene a
|
249
src/Scenes/Texture2D.hs
Normal file
249
src/Scenes/Texture2D.hs
Normal file
|
@ -0,0 +1,249 @@
|
|||
module Scenes.Texture2D where
|
||||
|
||||
import SDL (($=), get)
|
||||
import qualified SDL
|
||||
import qualified SDL.Internal.Numbered as SDL
|
||||
|
||||
import qualified Graphics.Rendering.OpenGL as GL
|
||||
|
||||
import Control.Monad
|
||||
|
||||
import Control.Concurrent.MVar
|
||||
|
||||
import Linear
|
||||
|
||||
import qualified Control.Lens as Lens
|
||||
|
||||
import Foreign.Storable (sizeOf)
|
||||
|
||||
-- internal imports
|
||||
|
||||
import BindableClass
|
||||
import BufferClass
|
||||
import VertexArray
|
||||
import VertexBuffer
|
||||
import IndexBuffer
|
||||
import Shader
|
||||
import Renderer
|
||||
import Texture
|
||||
|
||||
import Scenes.SceneClass
|
||||
|
||||
data Texture2D = Texture2D
|
||||
{ texModels :: [MVar (M44 GL.GLfloat)]
|
||||
, texView :: MVar (M44 GL.GLfloat)
|
||||
, texProj :: MVar (M44 GL.GLfloat)
|
||||
, texFocus :: MVar Int
|
||||
, texVertArrObj :: GL.VertexArrayObject
|
||||
, texVertArray :: VertexArray
|
||||
, texIdxBUfObj :: IndexBuffer GL.GLuint
|
||||
, texShaderProg :: Shader
|
||||
}
|
||||
|
||||
instance SceneClass Texture2D where
|
||||
|
||||
initScene = do
|
||||
-- -- MATRICES
|
||||
|
||||
let mproj = ortho 0 800 0 600 (-1) 1 :: M44 GL.GLfloat
|
||||
mview = mkTransformationMat (identity :: M33 GL.GLfloat) (V3 0 0 0)
|
||||
mmodel1 = mkTransformationMat (identity :: M33 GL.GLfloat) (V3 200 200 0)
|
||||
mmodel2 = mkTransformationMat (identity :: M33 GL.GLfloat) (V3 400 400 0)
|
||||
|
||||
vao <- GL.genObjectName
|
||||
va <- newVertexArray
|
||||
|
||||
GL.bindVertexArrayObject $= Just vao
|
||||
|
||||
-- define vertices (positions of the rectangle corners) as List of Floats
|
||||
-- with added in texture coordinates
|
||||
let vertexPositions =
|
||||
-- 3D positions | texture coordinates
|
||||
[ -67, -100, 0, 0, 0
|
||||
, 67, -100, 0, 1, 0
|
||||
, 67, 100, 0, 1, 1
|
||||
, -67, 100, 0, 0, 1
|
||||
] :: [GL.GLfloat]
|
||||
|
||||
-- create draw order indices
|
||||
indices = [0, 1, 2, 2, 3, 0] :: [GL.GLuint]
|
||||
|
||||
ibo <- newIndexBuffer indices
|
||||
|
||||
GL.blend $= GL.Enabled
|
||||
GL.blendFunc $= (GL.SrcAlpha, GL.OneMinusSrcAlpha)
|
||||
|
||||
-- construct new VertexBuffer and fill it with data
|
||||
vbo <- newVertexBuffer vertexPositions
|
||||
|
||||
-- rebind the vertex buffer
|
||||
bind vbo
|
||||
|
||||
-- enable and specify data layout of the in-memory vertices
|
||||
layout <- newVertexBufferLayout
|
||||
(fromIntegral $ 5 * sizeOf (undefined :: GL.GLfloat))
|
||||
-- push vertex positions
|
||||
pushElements
|
||||
layout
|
||||
0
|
||||
GL.Float
|
||||
3
|
||||
(0 * (sizeOf (undefined :: GL.GLfloat)))
|
||||
-- pusht texture coordinates
|
||||
pushElements
|
||||
layout
|
||||
1
|
||||
GL.Float
|
||||
2
|
||||
(3 * (sizeOf (undefined :: GL.GLfloat)))
|
||||
|
||||
addBuffer va vbo layout
|
||||
|
||||
-- -- TEXTURE
|
||||
|
||||
-- generate and bind texture
|
||||
tex <- newTexture "res/textures/lynx.jpg" 0
|
||||
bind tex
|
||||
|
||||
-- -- tell the shader where to find the texture
|
||||
sp <- newShader
|
||||
[ ShaderSource GL.VertexShader "./res/shaders/vert.shader"
|
||||
, ShaderSource GL.FragmentShader "./res/shaders/frag.shader"
|
||||
]
|
||||
bind sp
|
||||
setUniform sp "u_texture" (texSlot tex)
|
||||
|
||||
-- unbind everything again
|
||||
|
||||
unbind va
|
||||
unbind vbo
|
||||
unbind ibo
|
||||
unbind sp
|
||||
|
||||
-- store the mtrices for later adjustments
|
||||
proj <- newMVar mproj
|
||||
view <- newMVar mview
|
||||
model1 <- newMVar mmodel1
|
||||
model2 <- newMVar mmodel2
|
||||
|
||||
focus <- newMVar 0
|
||||
|
||||
return $ Texture2D [model1, model2] view proj focus vao va ibo sp
|
||||
|
||||
update _ _ = return ()
|
||||
|
||||
onEvents (Texture2D models view proj focus vao va ibo sp) evs = do
|
||||
-- modify the mvars based on keystrokes
|
||||
switchObject focus models evs
|
||||
foc <- readMVar focus
|
||||
moveObj proj view (models !! foc) evs
|
||||
|
||||
render (Texture2D [model1, model2] view proj _ vao va ibo sp) = do
|
||||
-- retrieve matrices from MVars
|
||||
mproj <- readMVar proj
|
||||
mview <- readMVar view
|
||||
|
||||
GL.clearColor $= GL.Color4 0 0 0 1
|
||||
clear
|
||||
mmodel1 <- readMVar model1
|
||||
bind sp
|
||||
setUniform sp "u_mvp" (mproj !*! mview !*! mmodel1)
|
||||
|
||||
-- the actual drawing happens here
|
||||
draw va ibo sp
|
||||
|
||||
-- -- bind shader and provide mvp for object2 and draw it
|
||||
|
||||
mmodel2 <- readMVar model2
|
||||
bind sp
|
||||
setUniform sp "u_mvp" (mproj !*! mview !*! mmodel2)
|
||||
|
||||
-- the actual drawing happens here
|
||||
draw va ibo sp
|
||||
|
||||
moveObj
|
||||
:: MVar (M44 GL.GLfloat)
|
||||
-> MVar (M44 GL.GLfloat)
|
||||
-> MVar (M44 GL.GLfloat)
|
||||
-> [SDL.Event]
|
||||
-> IO ()
|
||||
moveObj proj view model evs =
|
||||
modifyMVar_ proj (\mproj -> do
|
||||
modifyMVar_ view (\mview -> do
|
||||
modifyMVar_ model (\mmodel -> do
|
||||
let plusModel = foldl (\acc ev -> case SDL.eventPayload ev of
|
||||
(SDL.KeyboardEvent
|
||||
( SDL.KeyboardEventData
|
||||
_
|
||||
SDL.Pressed
|
||||
_
|
||||
(SDL.Keysym _ code mod)
|
||||
))
|
||||
->
|
||||
let trans =
|
||||
mkTransformationMat
|
||||
(identity :: M33 GL.GLfloat)
|
||||
( ( if SDL.keyModifierLeftShift mod
|
||||
then (-1)
|
||||
else 1
|
||||
)
|
||||
*
|
||||
( case code of
|
||||
SDL.KeycodeX ->
|
||||
V3 1 0 0
|
||||
SDL.KeycodeY ->
|
||||
V3 0 1 0
|
||||
_ ->
|
||||
V3 0 0 0
|
||||
)
|
||||
)
|
||||
!-!
|
||||
(identity :: M44 GL.GLfloat)
|
||||
in acc !+! trans
|
||||
_ -> acc
|
||||
)
|
||||
zero
|
||||
evs
|
||||
let retval = mmodel !+! plusModel
|
||||
when (not $ plusModel == zero) $
|
||||
print ("Current Position of object: " <>
|
||||
show (Lens.view translation $ retval))
|
||||
return retval
|
||||
)
|
||||
return mview
|
||||
)
|
||||
return mproj
|
||||
)
|
||||
|
||||
switchObject
|
||||
:: MVar Int
|
||||
-> [MVar (M44 GL.GLfloat)]
|
||||
-> [SDL.Event]
|
||||
-> IO ()
|
||||
switchObject focus elems evs =
|
||||
modifyMVar_ focus (\foc -> do
|
||||
foldM
|
||||
(\acc ev -> case SDL.eventPayload ev of
|
||||
(SDL.KeyboardEvent
|
||||
(SDL.KeyboardEventData
|
||||
_
|
||||
SDL.Pressed
|
||||
_
|
||||
(SDL.Keysym code _ mod)
|
||||
))
|
||||
-> do
|
||||
let selectIndex = fromIntegral (SDL.toNumber code) - 30
|
||||
if ((selectIndex < 10) && (selectIndex >= 0)) &&
|
||||
(SDL.toNumber mod == 0) &&
|
||||
(selectIndex < length elems) &&
|
||||
(acc /= selectIndex)
|
||||
then do
|
||||
print ("selected element number: " <> show selectIndex)
|
||||
return $ selectIndex
|
||||
else
|
||||
return foc
|
||||
_ -> return acc
|
||||
)
|
||||
foc
|
||||
evs
|
||||
)
|
224
src/Scenes/Texture2DBatched.hs
Normal file
224
src/Scenes/Texture2DBatched.hs
Normal file
|
@ -0,0 +1,224 @@
|
|||
module Scenes.Texture2DBatched where
|
||||
|
||||
import SDL (($=), get)
|
||||
import qualified SDL
|
||||
import qualified SDL.Internal.Numbered as SDL
|
||||
|
||||
import qualified Graphics.Rendering.OpenGL as GL
|
||||
|
||||
import qualified Graphics.GL.Functions as GLRaw
|
||||
|
||||
import Control.Monad
|
||||
|
||||
import Control.Concurrent.MVar
|
||||
|
||||
import Linear
|
||||
|
||||
import qualified Control.Lens as Lens
|
||||
|
||||
import Foreign.Storable (sizeOf)
|
||||
|
||||
-- internal imports
|
||||
|
||||
import BindableClass
|
||||
import BufferClass
|
||||
import VertexArray
|
||||
import VertexBuffer
|
||||
import IndexBuffer
|
||||
import Shader
|
||||
import Renderer
|
||||
import Texture
|
||||
|
||||
import Scenes.SceneClass
|
||||
|
||||
data Texture2DBatched = Texture2DBatched
|
||||
{ texModels :: MVar (M44 GL.GLfloat)
|
||||
, texView :: MVar (M44 GL.GLfloat)
|
||||
, texProj :: MVar (M44 GL.GLfloat)
|
||||
, texVertArrObj :: GL.VertexArrayObject
|
||||
, texVertArray :: VertexArray
|
||||
, texIdxBUfObj :: IndexBuffer GL.GLuint
|
||||
, texShaderProg :: Shader
|
||||
}
|
||||
|
||||
instance SceneClass Texture2DBatched where
|
||||
|
||||
initScene = do
|
||||
-- -- MATRICES
|
||||
|
||||
let mproj = ortho 0 800 0 600 (-1) 1 :: M44 GL.GLfloat
|
||||
mview = mkTransformationMat (identity :: M33 GL.GLfloat) (V3 0 0 0)
|
||||
mmodel = mkTransformationMat (identity :: M33 GL.GLfloat) (V3 400 400 0)
|
||||
|
||||
vao <- GL.genObjectName
|
||||
va <- newVertexArray
|
||||
|
||||
GL.bindVertexArrayObject $= Just vao
|
||||
|
||||
-- define vertices (positions of the rectangle corners) as List of Floats
|
||||
-- with added in texture coordinates
|
||||
let vertexPositions =
|
||||
-- 3D positions | VertexColor | tex coords | tex indx
|
||||
[ -67, -100, 0, 0.9, 0.8, 0, 1, 0, 0, 0
|
||||
, 67, -100, 0, 0.9, 0.8, 0, 1, 1, 0, 0
|
||||
, 67, 100, 0, 0.9, 0.8, 0, 1, 1, 1, 0
|
||||
, -67, 100, 0, 0.9, 0.8, 0, 1, 0, 1, 0
|
||||
|
||||
, 133, -100, 0, 0, 0.5, 0.9, 1, 0, 0, 1
|
||||
, 267, -100, 0, 0, 0.5, 0.9, 1, 1, 0, 1
|
||||
, 267, 100, 0, 0, 0.5, 0.9, 1, 1, 1, 1
|
||||
, 133, 100, 0, 0, 0.5, 0.9, 1, 0, 1, 1
|
||||
] :: [GL.GLfloat]
|
||||
|
||||
-- create draw order indices
|
||||
indices = [0, 1, 2, 2, 3, 0, 4, 5, 6, 6, 7, 4] :: [GL.GLuint]
|
||||
|
||||
ibo <- newIndexBuffer indices
|
||||
|
||||
GL.blend $= GL.Enabled
|
||||
GL.blendFunc $= (GL.SrcAlpha, GL.OneMinusSrcAlpha)
|
||||
|
||||
-- construct new VertexBuffer and fill it with data
|
||||
vbo <- newVertexBuffer vertexPositions
|
||||
|
||||
-- rebind the vertex buffer
|
||||
bind vbo
|
||||
|
||||
-- enable and specify data layout of the in-memory vertices
|
||||
layout <- newVertexBufferLayout
|
||||
(fromIntegral $ 10 * sizeOf (undefined :: GL.GLfloat))
|
||||
-- push vertex positions
|
||||
pushElements
|
||||
layout
|
||||
0
|
||||
GL.Float
|
||||
3
|
||||
(0 * (sizeOf (undefined :: GL.GLfloat)))
|
||||
-- push vertex colors
|
||||
pushElements
|
||||
layout
|
||||
1
|
||||
GL.Float
|
||||
4
|
||||
(3 * (sizeOf (undefined :: GL.GLfloat)))
|
||||
-- pusht texture coordinates
|
||||
pushElements
|
||||
layout
|
||||
2
|
||||
GL.Float
|
||||
2
|
||||
(7 * (sizeOf (undefined :: GL.GLfloat)))
|
||||
-- pusht texture index
|
||||
pushElements
|
||||
layout
|
||||
3
|
||||
GL.Float
|
||||
1
|
||||
(9 * (sizeOf (undefined :: GL.GLfloat)))
|
||||
|
||||
addBuffer va vbo layout
|
||||
|
||||
-- -- TEXTURE
|
||||
|
||||
-- generate and bind texture
|
||||
tex1 <- newTexture "res/textures/lynx.jpg" 0
|
||||
tex2 <- newTexture "res/textures/brainbulb_on.flat.png" 1
|
||||
bind tex1
|
||||
bind tex2
|
||||
|
||||
-- -- tell the shader where to find the texture
|
||||
sp <- newShader
|
||||
[ ShaderSource GL.VertexShader "./res/shaders/vertbatch.shader"
|
||||
, ShaderSource GL.FragmentShader "./res/shaders/fragbatch.shader"
|
||||
]
|
||||
bind sp
|
||||
-- setUniform sp "u_texture" (texSlot tex)
|
||||
|
||||
-- unbind everything again
|
||||
setUniformList sp "u_textures" [0 :: GL.GLint, 1]
|
||||
|
||||
unbind va
|
||||
unbind vbo
|
||||
unbind ibo
|
||||
unbind sp
|
||||
|
||||
-- store the mtrices for later adjustments
|
||||
proj <- newMVar mproj
|
||||
view <- newMVar mview
|
||||
model <- newMVar mmodel
|
||||
|
||||
return $ Texture2DBatched model view proj vao va ibo sp
|
||||
|
||||
update _ _ = return ()
|
||||
|
||||
onEvents (Texture2DBatched model view proj vao va ibo sp) evs = do
|
||||
-- modify the mvars based on keystrokes
|
||||
moveObj proj view model evs
|
||||
|
||||
render (Texture2DBatched model view proj vao va ibo sp) = do
|
||||
-- retrieve matrices from MVars
|
||||
mproj <- readMVar proj
|
||||
mview <- readMVar view
|
||||
|
||||
GL.clearColor $= GL.Color4 0 0 0 1
|
||||
clear
|
||||
mmodel <- readMVar model
|
||||
bind sp
|
||||
setUniform sp "u_mvp" (mproj !*! mview !*! mmodel)
|
||||
|
||||
-- the actual drawing happens here
|
||||
draw va ibo sp
|
||||
|
||||
moveObj
|
||||
:: MVar (M44 GL.GLfloat)
|
||||
-> MVar (M44 GL.GLfloat)
|
||||
-> MVar (M44 GL.GLfloat)
|
||||
-> [SDL.Event]
|
||||
-> IO ()
|
||||
moveObj proj view model evs =
|
||||
modifyMVar_ proj (\mproj -> do
|
||||
modifyMVar_ view (\mview -> do
|
||||
modifyMVar_ model (\mmodel -> do
|
||||
let plusModel = foldl (\acc ev -> case SDL.eventPayload ev of
|
||||
(SDL.KeyboardEvent
|
||||
( SDL.KeyboardEventData
|
||||
_
|
||||
SDL.Pressed
|
||||
_
|
||||
(SDL.Keysym _ code mod)
|
||||
))
|
||||
->
|
||||
let trans =
|
||||
mkTransformationMat
|
||||
(identity :: M33 GL.GLfloat)
|
||||
( ( if SDL.keyModifierLeftShift mod
|
||||
then (-1)
|
||||
else 1
|
||||
)
|
||||
*
|
||||
( case code of
|
||||
SDL.KeycodeX ->
|
||||
V3 1 0 0
|
||||
SDL.KeycodeY ->
|
||||
V3 0 1 0
|
||||
_ ->
|
||||
V3 0 0 0
|
||||
)
|
||||
)
|
||||
!-!
|
||||
(identity :: M44 GL.GLfloat)
|
||||
in acc !+! trans
|
||||
_ -> acc
|
||||
)
|
||||
zero
|
||||
evs
|
||||
let retval = mmodel !+! plusModel
|
||||
when (not $ plusModel == zero) $
|
||||
print ("Current Position of object: " <>
|
||||
show (Lens.view translation $ retval))
|
||||
return retval
|
||||
)
|
||||
return mview
|
||||
)
|
||||
return mproj
|
||||
)
|
180
src/Scenes/Texture2DBatchedDynamic.hs
Normal file
180
src/Scenes/Texture2DBatchedDynamic.hs
Normal file
|
@ -0,0 +1,180 @@
|
|||
module Scenes.Texture2DBatchedDynamic where
|
||||
|
||||
import SDL (($=), get)
|
||||
import qualified SDL
|
||||
import qualified SDL.Internal.Numbered as SDL
|
||||
|
||||
import qualified Graphics.Rendering.OpenGL as GL
|
||||
|
||||
import qualified Graphics.GL.Functions as GLRaw
|
||||
|
||||
import Control.Monad
|
||||
|
||||
import Control.Concurrent.MVar
|
||||
|
||||
import Linear
|
||||
|
||||
import qualified Control.Lens as Lens
|
||||
|
||||
import Foreign
|
||||
import Foreign.C.Types
|
||||
|
||||
import Foreign.Marshal.Array (withArray)
|
||||
|
||||
-- internal imports
|
||||
|
||||
import BindableClass
|
||||
import BufferClass
|
||||
import VertexArray
|
||||
import VertexBufferDynamic
|
||||
import IndexBuffer
|
||||
import Shader
|
||||
import Renderer
|
||||
import Texture
|
||||
|
||||
import Scenes.SceneClass
|
||||
|
||||
data Texture2DBatchedDynamic = Texture2DBatchedDynamic
|
||||
{ texModels :: MVar (M44 GL.GLfloat)
|
||||
, texView :: MVar (M44 GL.GLfloat)
|
||||
, texProj :: MVar (M44 GL.GLfloat)
|
||||
, texVertArrObj :: GL.VertexArrayObject
|
||||
, texVertArray :: VertexArray
|
||||
, texVertBuf :: VertexBufferDynamic
|
||||
, texIdxBufObj :: IndexBuffer GL.GLuint
|
||||
, texShaderProg :: Shader
|
||||
}
|
||||
|
||||
instance SceneClass Texture2DBatchedDynamic where
|
||||
|
||||
initScene = do
|
||||
-- -- MATRICES
|
||||
|
||||
let mproj = ortho 0 800 0 600 (-1) 1 :: M44 GL.GLfloat
|
||||
mview = mkTransformationMat (identity :: M33 GL.GLfloat) (V3 0 0 0)
|
||||
mmodel = mkTransformationMat (identity :: M33 GL.GLfloat) (V3 0 0 0)
|
||||
|
||||
vao <- GL.genObjectName
|
||||
va <- newVertexArray
|
||||
|
||||
GL.bindVertexArrayObject $= Just vao
|
||||
|
||||
-- create draw order indices
|
||||
let indices = [0, 1, 2, 2, 3, 0, 4, 5, 6, 6, 7, 4] :: [GL.GLuint]
|
||||
|
||||
ibo <- newIndexBuffer indices
|
||||
|
||||
GL.blend $= GL.Enabled
|
||||
GL.blendFunc $= (GL.SrcAlpha, GL.OneMinusSrcAlpha)
|
||||
|
||||
-- construct new VertexBuffer and fill it with data
|
||||
vbo <- newVertexBufferDynamic
|
||||
|
||||
-- rebind the vertex buffer
|
||||
bind vbo
|
||||
|
||||
-- enable and specify data layout of the in-memory vertices
|
||||
layout <- newVertexBufferLayout
|
||||
(fromIntegral $ 10 * sizeOf (undefined :: GL.GLfloat))
|
||||
-- push vertex positions
|
||||
pushElements
|
||||
layout
|
||||
0
|
||||
GL.Float
|
||||
3
|
||||
(0 * (sizeOf (undefined :: GL.GLfloat)))
|
||||
-- push vertex colors
|
||||
pushElements
|
||||
layout
|
||||
1
|
||||
GL.Float
|
||||
4
|
||||
(3 * (sizeOf (undefined :: GL.GLfloat)))
|
||||
-- pusht texture coordinates
|
||||
pushElements
|
||||
layout
|
||||
2
|
||||
GL.Float
|
||||
2
|
||||
(7 * (sizeOf (undefined :: GL.GLfloat)))
|
||||
-- pusht texture index
|
||||
pushElements
|
||||
layout
|
||||
3
|
||||
GL.Float
|
||||
1
|
||||
(9 * (sizeOf (undefined :: GL.GLfloat)))
|
||||
|
||||
addBuffer va vbo layout
|
||||
|
||||
-- -- TEXTURE
|
||||
|
||||
-- generate and bind texture
|
||||
tex1 <- newTexture "res/textures/lynx.jpg" 0
|
||||
tex2 <- newTexture "res/textures/brainbulb_on.flat.png" 1
|
||||
bind tex1
|
||||
bind tex2
|
||||
|
||||
-- -- tell the shader where to find the texture
|
||||
sp <- newShader
|
||||
[ ShaderSource GL.VertexShader "./res/shaders/vertbatch.shader"
|
||||
, ShaderSource GL.FragmentShader "./res/shaders/fragbatch.shader"
|
||||
]
|
||||
bind sp
|
||||
-- setUniform sp "u_texture" (texSlot tex)
|
||||
|
||||
-- unbind everything again
|
||||
setUniformList sp "u_textures" [0 :: GL.GLint, 1]
|
||||
setUniform sp "u_mvp" (mproj !*! mview !*! mmodel)
|
||||
|
||||
unbind va
|
||||
unbind vbo
|
||||
unbind ibo
|
||||
unbind sp
|
||||
|
||||
-- store the mtrices for later adjustments
|
||||
proj <- newMVar mproj
|
||||
view <- newMVar mview
|
||||
model <- newMVar mmodel
|
||||
|
||||
return $ Texture2DBatchedDynamic model view proj vao va vbo ibo sp
|
||||
|
||||
update (Texture2DBatchedDynamic _ _ _ vao _ vbo _ _) dt = do
|
||||
let vertices = verticesToFloatList $ createQuad (V2 (dt * 500) 500) 0
|
||||
++ createQuad (V2 500 (dt * 500)) 1
|
||||
GL.bindVertexArrayObject $= Just vao
|
||||
bind vbo
|
||||
withArray vertices $ \ptr ->
|
||||
GL.bufferSubData
|
||||
(target vbo) -- ^ The target buffer
|
||||
GL.WriteToBuffer -- ^ transfer direction
|
||||
(CPtrdiff 0) -- ^ Offset of the written data in the buffer
|
||||
(CPtrdiff (fromIntegral $ length vertices * sizeOf (undefined :: GL.GLfloat)))
|
||||
-- ^ The size of the written data
|
||||
ptr -- ^ Pointer to data
|
||||
|
||||
|
||||
|
||||
onEvents _ _ =
|
||||
return ()
|
||||
|
||||
render (Texture2DBatchedDynamic model view proj vao va _ ibo sp) = do
|
||||
-- retrieve matrices from MVars
|
||||
GL.clearColor $= GL.Color4 0 0 0 1
|
||||
clear
|
||||
|
||||
-- the actual drawing happens here
|
||||
draw va ibo sp
|
||||
|
||||
createQuad :: V2 GL.GLfloat -> Int -> [Vertex]
|
||||
createQuad pos@(V2 x y) index =
|
||||
[ newVertex (V3 (x - 67) (y - 100) 0) (V4 0 0 0 1) (V2 0 0) (fromIntegral index)
|
||||
, newVertex (V3 (x + 67) (y - 100) 0) (V4 0 0 0 1) (V2 1 0) (fromIntegral index)
|
||||
, newVertex (V3 (x + 67) (y + 100) 0) (V4 0 0 0 1) (V2 1 1) (fromIntegral index)
|
||||
, newVertex (V3 (x - 67) (y + 100) 0) (V4 0 0 0 1) (V2 0 1) (fromIntegral index)
|
||||
]
|
||||
|
||||
verticesToFloatList :: [Vertex] -> [GL.GLfloat]
|
||||
verticesToFloatList [] = []
|
||||
verticesToFloatList ((Vertex (V3 x y z) (V4 r g b a) (V2 u v) idx _):verts) =
|
||||
[x, y, z, r, g, b, a, u, v, idx] ++ verticesToFloatList verts
|
|
@ -16,9 +16,13 @@ import qualified Data.ByteString as B
|
|||
|
||||
import Data.Maybe (fromJust)
|
||||
|
||||
import Control.Concurrent.MVar
|
||||
|
||||
import Linear
|
||||
|
||||
import Foreign.Marshal.Utils (with)
|
||||
import Foreign.Marshal.Array (withArray)
|
||||
import Foreign.Storable
|
||||
import Foreign.Ptr
|
||||
|
||||
-- internal imports
|
||||
|
@ -28,7 +32,7 @@ import BindableClass
|
|||
data Shader = Shader
|
||||
{ shaderId :: GL.Program
|
||||
, shaderSources :: [ShaderSource]
|
||||
, shaderUniforms :: [ShaderUniform]
|
||||
, shaderUniforms :: MVar [ShaderUniform]
|
||||
}
|
||||
|
||||
-- make Shader Bindable
|
||||
|
@ -75,8 +79,8 @@ isRowMajor :: GL.MatrixOrder -> GL.GLboolean
|
|||
isRowMajor p = if (GL.RowMajor == p) then 1 else 0
|
||||
|
||||
-- create new data object of type Shader
|
||||
newShader :: [ShaderSource] -> [String] -> IO Shader
|
||||
newShader shaderSrc uniforms = do
|
||||
newShader :: [ShaderSource] -> IO Shader
|
||||
newShader shaderSrc = do
|
||||
-- create program Object
|
||||
program <- GL.createProgram
|
||||
|
||||
|
@ -110,27 +114,70 @@ newShader shaderSrc uniforms = do
|
|||
-- throw away the shaders, since they are linked into the shader program
|
||||
mapM_ (\s -> GL.deleteObjectName s) (map snd compilates)
|
||||
|
||||
-- retrieve locations of all uniforms and store them
|
||||
uniLocs <- mapM
|
||||
(\name -> do
|
||||
loc <- get $ GL.uniformLocation program name
|
||||
return (ShaderUniform name loc)
|
||||
)
|
||||
uniforms
|
||||
|
||||
-- return data object
|
||||
return (Shader program shaderSrc uniLocs)
|
||||
Shader program shaderSrc <$> newMVar []
|
||||
|
||||
-- pass uniform values into Shader program
|
||||
setUniform :: (GL.Uniform a) => Shader -> String -> a -> IO ()
|
||||
setUniform shader uniname data_ = do
|
||||
-- retrieve uniform location
|
||||
let [ShaderUniform _ loc] = filter
|
||||
(\(ShaderUniform name _) -> name == uniname)
|
||||
(shaderUniforms shader)
|
||||
setUniformList :: (Storable a, GL.Uniform a) => Shader -> String -> [a] -> IO ()
|
||||
setUniformList (Shader shaderProgram _ shaderUniforms) uniname data_ = do
|
||||
-- check if uniform location is already cached
|
||||
locs <- readMVar shaderUniforms
|
||||
|
||||
-- set the data
|
||||
GL.uniform loc $= data_
|
||||
-- retrieve uniform location
|
||||
let unilocs = filter
|
||||
(\(ShaderUniform name _) -> name == uniname)
|
||||
locs
|
||||
|
||||
case unilocs of
|
||||
[] -> do
|
||||
print ("Unknown uniform: " <> uniname)
|
||||
print "Retrieving uniform location from shader program"
|
||||
loc@(GL.UniformLocation locNum) <- get $ GL.uniformLocation shaderProgram uniname
|
||||
if locNum < 0
|
||||
then
|
||||
print ("Uniform does not exist in shader program: " <> uniname)
|
||||
else do
|
||||
-- set the data
|
||||
withArray data_ $ \ptr ->
|
||||
GL.uniformv loc (fromIntegral $ length data_) ptr
|
||||
--GL.uniform loc $= data_
|
||||
-- add uniform to cache
|
||||
modifyMVar_ shaderUniforms
|
||||
(\list -> return $ ShaderUniform uniname loc : list)
|
||||
[ShaderUniform _ loc] ->
|
||||
-- set the data
|
||||
withArray data_ $ \ptr ->
|
||||
GL.uniformv loc (fromIntegral $ length data_) ptr
|
||||
|
||||
setUniform :: (GL.Uniform a) => Shader -> String -> a -> IO ()
|
||||
setUniform (Shader shaderProgram _ shaderUniforms) uniname data_ = do
|
||||
-- check if uniform location is already cached
|
||||
locs <- readMVar shaderUniforms
|
||||
|
||||
-- retrieve uniform location
|
||||
let unilocs = filter
|
||||
(\(ShaderUniform name _) -> name == uniname)
|
||||
locs
|
||||
|
||||
case unilocs of
|
||||
[] -> do
|
||||
print ("Unknown uniform: " <> uniname)
|
||||
print "Retrieving uniform location from shader program"
|
||||
loc@(GL.UniformLocation locNum) <- get $ GL.uniformLocation shaderProgram uniname
|
||||
if locNum < 0
|
||||
then
|
||||
print ("Uniform does not exist in shader program: " <> uniname)
|
||||
else do
|
||||
-- set the data
|
||||
--withArray data_ $ \ptr ->
|
||||
-- GL.uniformv loc (length data_) ptr
|
||||
GL.uniform loc $= data_
|
||||
-- add uniform to cache
|
||||
modifyMVar_ shaderUniforms
|
||||
(\list -> return $ ShaderUniform uniname loc : list)
|
||||
[ShaderUniform _ loc] ->
|
||||
-- set the data
|
||||
GL.uniform loc $= data_
|
||||
|
||||
-- | compile a shader from source
|
||||
compileShaderSource
|
||||
|
|
|
@ -23,10 +23,10 @@ import BindableClass
|
|||
data Texture = Texture
|
||||
{ texId :: GL.TextureObject
|
||||
, texSlot :: GL.TextureUnit
|
||||
, texPath :: FilePath
|
||||
, texDimensions :: V2 GL.GLsizei
|
||||
, texBPP :: Int
|
||||
, texData :: Ptr ()
|
||||
-- , texPath :: FilePath
|
||||
-- , texDimensions :: V2 GL.GLsizei
|
||||
-- , texBPP :: Int
|
||||
-- , texData :: Ptr ()
|
||||
}
|
||||
|
||||
instance Bindable Texture where
|
||||
|
@ -51,10 +51,10 @@ newTexture fp slot = do
|
|||
tex <- Texture
|
||||
<$> GL.genObjectName
|
||||
<*> (pure $ GL.TextureUnit slot)
|
||||
<*> (pure fp)
|
||||
<*> (pure $ fmap fromIntegral $ V2 (imageWidth img) (imageHeight img))
|
||||
<*> (pure $ componentCount (VS.head $ imageData img))
|
||||
<*> (pure $ castPtr ptr)
|
||||
-- <*> (pure fp)
|
||||
let dimensions = fromIntegral <$> V2 (imageWidth img) (imageHeight img)
|
||||
-- <*> (pure $ componentCount (VS.head $ imageData img))
|
||||
data_ = castPtr ptr
|
||||
|
||||
-- bind texture
|
||||
bind tex
|
||||
|
@ -65,7 +65,7 @@ newTexture fp slot = do
|
|||
GL.textureWrapMode GL.Texture2D GL.T $= (GL.Repeated, GL.Clamp)
|
||||
|
||||
-- put data into GPU memory
|
||||
loadTexture tex
|
||||
loadTexture tex dimensions data_
|
||||
|
||||
-- unbind texture
|
||||
unbind tex
|
||||
|
@ -76,9 +76,9 @@ newTexture fp slot = do
|
|||
-- pass texture object out
|
||||
return tex
|
||||
|
||||
loadTexture :: Texture -> IO ()
|
||||
loadTexture tex =
|
||||
let (V2 w h) = texDimensions tex
|
||||
loadTexture :: Texture -> V2 GL.GLsizei -> Ptr () -> IO ()
|
||||
loadTexture tex dimensions data_ =
|
||||
let (V2 w h) = dimensions
|
||||
in GL.texImage2D
|
||||
GL.Texture2D
|
||||
GL.NoProxy
|
||||
|
@ -86,4 +86,4 @@ loadTexture tex =
|
|||
GL.RGBA'
|
||||
(GL.TextureSize2D w h)
|
||||
0
|
||||
(GL.PixelData GL.RGBA GL.UnsignedByte (texData tex))
|
||||
(GL.PixelData GL.RGBA GL.UnsignedByte data_)
|
||||
|
|
|
@ -42,8 +42,9 @@ newVertexArray = VertexArray
|
|||
<$> GL.genObjectName
|
||||
|
||||
addBuffer
|
||||
:: VertexArray
|
||||
-> VertexBuffer a
|
||||
:: (Buffer buf)
|
||||
=> VertexArray
|
||||
-> buf
|
||||
-> VertexBufferLayout
|
||||
-> IO ()
|
||||
addBuffer va vb layout = do
|
||||
|
@ -52,51 +53,64 @@ addBuffer va vb layout = do
|
|||
bind vb
|
||||
-- enable and fill out the vertex attrib pointer(s)
|
||||
list <- readMVar (vblElements layout)
|
||||
let indexed = zip [0 ..] list
|
||||
dataElementSize e = case e of
|
||||
let dataElementSize e = case e of
|
||||
GL.Float -> sizeOf (undefined :: GL.GLfloat)
|
||||
x -> error ("No size computation implemented fof: " <> show x)
|
||||
mapM_
|
||||
(\(index, elem) -> do
|
||||
let offset = fromIntegral $
|
||||
foldl
|
||||
(\acc (index, elem) -> acc + vbleCount elem)
|
||||
0
|
||||
(filter ((< index) . fst) indexed) :: Int
|
||||
GL.vertexAttribArray (GL.AttribLocation $ fromIntegral index) $=
|
||||
(\(VertexBufferLayoutElement index type_ count offset handling) -> do
|
||||
GL.vertexAttribArray (GL.AttribLocation index) $=
|
||||
GL.Enabled
|
||||
GL.vertexAttribPointer (GL.AttribLocation $ fromIntegral index) $=
|
||||
( vbleHandling elem
|
||||
GL.vertexAttribPointer (GL.AttribLocation index) $=
|
||||
( handling
|
||||
, GL.VertexArrayDescriptor
|
||||
-- number of components to our attribute
|
||||
(vbleCount elem)
|
||||
count
|
||||
-- datatype of elements
|
||||
(vbleType elem)
|
||||
-- ???
|
||||
(sum (map vbleCount list) * fromIntegral (dataElementSize (vbleType elem)))
|
||||
-- offset from beginnning of vertex
|
||||
(plusPtr nullPtr (offset * dataElementSize (vbleType elem)))
|
||||
type_
|
||||
-- Stride (How big is one Vertex in bytes)
|
||||
(vblStride layout)
|
||||
-- offset from beginnning of vertex in bytes
|
||||
(plusPtr nullPtr offset)
|
||||
)
|
||||
)
|
||||
indexed
|
||||
list
|
||||
unbind va
|
||||
unbind vb
|
||||
|
||||
newtype VertexBufferLayout = VertexBufferLayout
|
||||
data VertexBufferLayout = VertexBufferLayout
|
||||
{ vblElements :: MVar [VertexBufferLayoutElement]
|
||||
, vblStride :: GL.GLsizei
|
||||
}
|
||||
|
||||
data VertexBufferLayoutElement = VertexBufferLayoutElement
|
||||
{ vbleType :: GL.DataType
|
||||
{ vbleIndex :: GL.GLuint
|
||||
, vbleType :: GL.DataType
|
||||
, vbleCount :: GL.GLint
|
||||
, vbleOffset :: Int
|
||||
, vbleHandling :: GL.IntegerHandling
|
||||
}
|
||||
|
||||
newVertexBufferLayout :: IO VertexBufferLayout
|
||||
newVertexBufferLayout = VertexBufferLayout
|
||||
newVertexBufferLayout :: GL.GLsizei -> IO VertexBufferLayout
|
||||
newVertexBufferLayout stride = VertexBufferLayout
|
||||
<$> newMVar []
|
||||
<*> pure stride
|
||||
|
||||
pushElements :: VertexBufferLayout -> GL.DataType -> GL.GLint -> IO ()
|
||||
pushElements vbl type_ count = do
|
||||
pushElements
|
||||
:: VertexBufferLayout
|
||||
-> GL.GLuint
|
||||
-> GL.DataType
|
||||
-> GL.GLint
|
||||
-> Int
|
||||
-> IO ()
|
||||
pushElements vbl index type_ count offset = do
|
||||
modifyMVar_ (vblElements vbl) $ \list ->
|
||||
return (list ++ [VertexBufferLayoutElement type_ count GL.ToNormalizedFloat])
|
||||
return
|
||||
(list ++
|
||||
[VertexBufferLayoutElement
|
||||
index
|
||||
type_
|
||||
count
|
||||
offset
|
||||
GL.ToNormalizedFloat
|
||||
]
|
||||
)
|
||||
|
|
93
src/VertexBufferDynamic.hs
Normal file
93
src/VertexBufferDynamic.hs
Normal file
|
@ -0,0 +1,93 @@
|
|||
{-# LANGUAGE TypeFamilies #-}
|
||||
module VertexBufferDynamic where
|
||||
|
||||
import qualified Graphics.Rendering.OpenGL as GL
|
||||
|
||||
import SDL (($=), get)
|
||||
|
||||
import Linear
|
||||
|
||||
import Foreign
|
||||
import Foreign.C.Types
|
||||
|
||||
-- internal imports
|
||||
|
||||
import BindableClass
|
||||
import BufferClass
|
||||
|
||||
-- layout of the VertexBuffer data object
|
||||
data VertexBufferDynamic = VertexBufferDynamic
|
||||
{ vBufId :: GL.BufferObject -- buffer id
|
||||
, vBufSize :: GL.GLsizeiptr -- size of data
|
||||
-- , vBufData :: Ptr a -- pointer to data
|
||||
}
|
||||
|
||||
data Vertex = Vertex
|
||||
{ vertPosition :: V3 GL.GLfloat
|
||||
, vertColor :: V4 GL.GLfloat
|
||||
, vertTexCoord :: V2 GL.GLfloat
|
||||
, vertTexID :: GL.GLfloat
|
||||
, vertSize :: GL.GLsizei
|
||||
}
|
||||
|
||||
-- | Smart constructor for a new Vertex
|
||||
newVertex
|
||||
:: V3 GL.GLfloat
|
||||
-> V4 GL.GLfloat
|
||||
-> V2 GL.GLfloat
|
||||
-> GL.GLfloat
|
||||
-> Vertex
|
||||
newVertex pos color texcoord index =
|
||||
Vertex
|
||||
pos
|
||||
color
|
||||
texcoord
|
||||
index
|
||||
(fromIntegral $ 10 * (sizeOf (undefined :: GL.GLfloat)))
|
||||
|
||||
-- instanciate typeclass from BufferClass and fill in missing implementations
|
||||
instance Buffer VertexBufferDynamic where
|
||||
|
||||
type ObjName VertexBufferDynamic = GL.BufferObject
|
||||
|
||||
target _ = GL.ArrayBuffer
|
||||
|
||||
glId = vBufId
|
||||
|
||||
initialize buf = do
|
||||
-- bind the buffer using the default iplementation of the typeclass
|
||||
bind buf
|
||||
-- fill in the data
|
||||
GL.bufferData (target buf) $=
|
||||
( vBufSize buf
|
||||
, nullPtr
|
||||
, GL.DynamicDraw
|
||||
)
|
||||
-- release the buffer using the default implementation of the typeclass
|
||||
unbind buf
|
||||
|
||||
|
||||
instance Bindable VertexBufferDynamic where
|
||||
|
||||
-- bind the buffer
|
||||
bind buf = GL.bindBuffer (target buf) $= Just (glId buf)
|
||||
|
||||
-- unbind the buffer
|
||||
unbind buf = GL.bindBuffer (target buf) $= Nothing
|
||||
|
||||
newVertexBufferDynamic
|
||||
:: IO VertexBufferDynamic -- newly built VertexBuffer data object
|
||||
newVertexBufferDynamic = do
|
||||
let dummyVertex = newVertex (V3 0 0 0) (V4 0 0 0 0) (V2 0 0) 0
|
||||
-- create the buffer object in applicative style
|
||||
buf <- VertexBufferDynamic
|
||||
-- generate the ID
|
||||
<$> GL.genObjectName
|
||||
-- compute buffer size
|
||||
<*> pure (CPtrdiff (fromIntegral $ 1024 * vertSize dummyVertex))
|
||||
-- make pointer out of list
|
||||
-- <*> newArray list
|
||||
-- fill the data in to the buffer
|
||||
initialize buf
|
||||
-- return the data object
|
||||
return buf
|
Loading…
Reference in a new issue