Compare commits

...

38 commits

Author SHA1 Message Date
nek0 102ff2ec77 finished episode 31 2020-08-29 22:13:25 +02:00
nek0 4f414f1410 finished episode 30. Episodes in between were either theory or trivial. 2020-08-29 17:15:07 +02:00
nek0 74387cf18b finished episode 27 2020-08-29 10:01:04 +02:00
nek0 8f5ea5531c no need to empty already empty MVars 2020-08-29 07:22:26 +02:00
nek0 9cd2ca9298 updated readme 2020-08-29 07:19:34 +02:00
nek0 8be1acee77 updated readme 2020-08-29 07:18:14 +02:00
nek0 055a12e94f finished episode 26 2020-08-29 07:13:49 +02:00
nek0 9fca6a7617 finished episode 25 2020-08-29 05:19:47 +02:00
nek0 fa0c6c4670 finished episode 24 2020-08-29 04:45:51 +02:00
nek0 ad1e3579e8 updated readme 2020-08-11 04:12:30 +02:00
nek0 dc68854f19 finished episode 23 2020-08-10 15:09:23 +02:00
nek0 c27d0a72e3 readability, executional verbosity and correction of y direction 2020-08-10 12:50:29 +02:00
nek0 31976ff185 add new dependency 2020-08-10 12:49:57 +02:00
nek0 0714859e5a purged old code 2020-08-09 22:34:10 +02:00
nek0 51718c2c66 move code to external module 2020-08-09 22:24:32 +02:00
nek0 85f45c71a3 more descriptive comment 2020-08-09 21:43:43 +02:00
nek0 2aaa7331b8 update readme 2020-08-09 21:43:04 +02:00
nek0 3b7237185d move the rendered picture around on key presses 2020-08-04 21:57:08 +02:00
nek0 4bc8b759a6 add view and model matrices 2020-06-12 20:13:36 +02:00
nek0 dc7162e407 visually seperate texture coords from vertex coords 2020-06-08 16:41:55 +02:00
nek0 96dfd765b1 resize to show lynx undistorted 2020-06-08 16:40:43 +02:00
nek0 c379042748 finished episode 20 2020-06-02 03:25:42 +02:00
nek0 747d7379ae deactivate unused uniform 2020-06-02 03:08:03 +02:00
nek0 155be720b3 finished episode 19. episode 18 was theory only 2020-05-23 14:08:34 +02:00
nek0 58db022a7b flip image at loading, not in shader 2020-05-23 11:16:53 +02:00
nek0 3dab16259e hunt errors 2020-05-22 23:59:29 +02:00
nek0 c55cb22ee2 I see cats 2020-05-22 23:49:17 +02:00
nek0 e3be56ab6c get textures halfway working 2020-05-22 16:16:06 +02:00
nek0 1714facb11 cleanup 2020-05-22 02:38:32 +02:00
nek0 750f55fda6 move clear to renderer 2020-05-22 02:31:24 +02:00
nek0 4a499165c4 get initial renderer to run 2020-05-22 02:29:16 +02:00
nek0 90d2ef73e6 Abstract Shaders into own module 2020-05-21 21:04:05 +02:00
nek0 c2014e41c5 abstract bindable stuff as typeclass 2020-05-21 18:17:38 +02:00
nek0 a0f9ffcc6e vertex array abstraction forgotten 2020-05-20 06:10:14 +02:00
nek0 2db17d3fd6 finished episode14 2020-05-20 05:54:43 +02:00
nek0 3046622519 finished episode13 2020-05-18 04:58:45 +02:00
nek0 9830e5d3ed rename project 2020-05-18 04:57:41 +02:00
nek0 7566605ec4 update readme 2020-05-18 03:24:59 +02:00
26 changed files with 1781 additions and 227 deletions

View file

@ -1,4 +1,4 @@
# renderer
# renderer-tutorial
This softwre aims to be an OpenGL renderer written in Haskell following the
OpenGL tutorial by The Cherno
@ -10,10 +10,40 @@ There are some major deviations from the tutorial setup here as follows:
* Code base is entirely written in Haskell, not C++
* Instead of GLFW with GLEW I use SDL2 out of familiarity
* Shaders are actually split into files per type, since IÄmnot willing to
unleash Haskell list magic
* Shaders are actually split into files per type, since I'mn ot willing to
unleash Haskell list magic
* Since I am using the OpenGL core profile from the start there is also a
vertex array creation call present from the start.
vertex array creation call present from the start.
* I don't have not found a suitable GUI library, so all things interactive are
done through input events.
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.

52
renderer-tutorial.cabal Normal file
View file

@ -0,0 +1,52 @@
cabal-version: 2.4
-- Initial package description 'renderer.cabal' generated by 'cabal init'.
-- For further documentation, see http://haskell.org/cabal/users-guide/
name: renderer-tutorial
version: 0.0.0.0
-- synopsis:
-- description:
-- bug-reports:
license: GPL-3.0-only
license-file: LICENSE
author: nek0
maintainer: nek0@nek0.eu
-- copyright:
category: Graphics
extra-source-files: CHANGELOG.md
executable renderer-tutorial
main-is: Main.hs
-- other-modules:
-- other-extensions:
build-depends: base >= 4.11.0.0 && < 5
, OpenGL
, OpenGLRaw
, sdl2 >= 2.5.0.0
, bytestring
, vector
, linear
, monad-loops
, random
, JuicyPixels
, 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

View file

@ -1,30 +0,0 @@
cabal-version: 2.4
-- Initial package description 'renderer.cabal' generated by 'cabal init'.
-- For further documentation, see http://haskell.org/cabal/users-guide/
name: renderer
version: 0.0.0.0
-- synopsis:
-- description:
-- bug-reports:
license: GPL-3.0-only
license-file: LICENSE
author: nek0
maintainer: nek0@nek0.eu
-- copyright:
category: Graphics
extra-source-files: CHANGELOG.md
executable renderer
main-is: Main.hs
-- other-modules:
-- other-extensions:
build-depends: base >= 4.11.0.0 && < 5
, OpenGL
, OpenGLRaw
, sdl2 >= 2.5.0.0
, bytestring
, monad-loops
, random
hs-source-dirs: src
default-language: Haskell2010

View file

@ -1,10 +1,14 @@
#version 330 core
out vec4 color;
layout(location = 0) out vec4 color;
in vec2 v_texCoord;
uniform vec4 u_color;
uniform sampler2D u_texture;
void main()
{
color = u_color;
vec4 texColor = texture(u_texture, v_texCoord);
color = texColor;
}

View 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);
}

View file

@ -1,8 +1,14 @@
#version 330 core
layout(location = 0) in vec4 position;
layout(location = 0) in vec3 position;
layout(location = 1) in vec2 texCoord;
out vec2 v_texCoord;
uniform mat4 u_mvp;
void main()
{
gl_Position = position;
gl_Position = u_mvp * vec4(position, 1);
v_texCoord = texCoord;
}

View 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;
}

Binary file not shown.

After

Width:  |  Height:  |  Size: 106 KiB

BIN
res/textures/lynx.jpg Normal file

Binary file not shown.

After

Width:  |  Height:  |  Size: 227 KiB

View file

@ -4,17 +4,19 @@ let
inherit (nixpkgs) pkgs;
f = { mkDerivation, base, bytestring, monad-loops, OpenGL
, OpenGLRaw, random, sdl2, stdenv
f = { mkDerivation, base, bytestring, clock, JuicyPixels
, JuicyPixels-extra, lens, linear, monad-loops, OpenGL, OpenGLRaw
, random, sdl2, StateVar, stdenv, vector
}:
mkDerivation {
pname = "renderer";
pname = "renderer-tutorial";
version = "0.0.0.0";
src = ./.;
isLibrary = false;
isExecutable = true;
executableHaskellDepends = [
base bytestring monad-loops OpenGL OpenGLRaw random sdl2
base bytestring clock JuicyPixels JuicyPixels-extra lens linear
monad-loops OpenGL OpenGLRaw random sdl2 StateVar vector
];
license = stdenv.lib.licenses.gpl3;
};

10
src/BindableClass.hs Normal file
View file

@ -0,0 +1,10 @@
module BindableClass where
-- | typeclass for bindabl eobjects like buffers, vertex arrays or shaders
class Bindable a where
-- bind the object in context
bind :: a -> IO ()
-- release object from context
unbind :: a -> IO ()

26
src/BufferClass.hs Normal file
View file

@ -0,0 +1,26 @@
{-# LANGUAGE TypeFamilies #-}
module BufferClass where
import qualified Graphics.Rendering.OpenGL as GL
import SDL (($=), get)
-- internal imports
import BindableClass
-- this aims to be a typeclass for all used buffer objects throughout the
-- tutorial.
-- think of it as some kind of interface in the object oriented context
class (Bindable a) => Buffer a where
type ObjName a :: *
-- what buffer target does te buffer bind to
target :: a -> GL.BufferTarget
-- what ID does the buffer have
glId :: a -> ObjName a
-- bind the buffer object and fill it with data
initialize :: a -> IO ()

101
src/EventHandler.hs Normal file
View file

@ -0,0 +1,101 @@
module EventHandler where
import Control.Monad
import Control.Concurrent.MVar
import Control.Lens as Lens
import Linear
import qualified SDL
import qualified SDL.Internal.Numbered as SDL
import qualified Graphics.Rendering.OpenGL as GL
moveObj
:: MVar (M44 GL.GLfloat)
-> MVar (M44 GL.GLfloat)
-> MVar (M44 GL.GLfloat)
-> MVar [SDL.Event]
-> IO ()
moveObj proj view model evs =
modifyMVar_ proj (\mproj -> do
modifyMVar_ view (\mview -> do
modifyMVar_ model (\mmodel -> do
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
<$> readMVar 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 (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
)

70
src/IndexBuffer.hs Normal file
View file

@ -0,0 +1,70 @@
{-# LANGUAGE TypeFamilies #-}
module IndexBuffer where
import qualified Graphics.Rendering.OpenGL as GL
import SDL (($=), get)
import Foreign
-- internal imports
import BindableClass
import BufferClass
-- layout of the IndexBuffer data object
data IndexBuffer a = IndexBuffer
{ iBufId :: GL.BufferObject -- buffer id
, iBufSize :: GL.GLsizeiptr -- size of data
, iBufData :: Ptr a -- pointer to data
, iBufCount :: GL.GLint -- number of data elements
}
-- instanciate typeclass from BufferClass and fill in missing implementations
instance Buffer (IndexBuffer a) where
type ObjName (IndexBuffer a) = GL.BufferObject
target _ = GL.ElementArrayBuffer
glId = iBufId
initialize buf = do
-- bind the buffer using the default iplementation of the typeclass
bind buf
-- fill in the data
GL.bufferData (target buf) $=
( iBufSize buf
, iBufData buf
, GL.StaticDraw
)
-- release the buffer using the default implementation of the typeclass
unbind buf
instance Bindable (IndexBuffer a) where
-- bind the buffer
bind buf = GL.bindBuffer (target buf) $= Just (glId buf)
-- unbind the buffer
unbind buf = GL.bindBuffer (target buf) $= Nothing
newIndexBuffer ::
(Storable a) => -- we have to be able to get a pointer to provided data
[a] -> -- list of data elements
IO (IndexBuffer a) -- newly built IndexBuffer data object
newIndexBuffer list = do
-- create the buffer object in applicative style
buf <- IndexBuffer
-- generate the ID
<$> GL.genObjectName
-- compute buffer size
<*> pure (fromIntegral (length list * sizeOf (head list)))
-- make pointer out of list
<*> newArray list
-- get count
<*> pure (fromIntegral $ length list)
-- fill the data in to the buffer
initialize buf
-- return the data object
return buf

View file

@ -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,6 +31,24 @@ import qualified Data.List as L
import System.Random (randomRIO)
import System.Clock
import Linear
-- internal imports
import VertexArray
import Shader
import IndexBuffer
import EventHandler
import Scenes.SceneClass
import Scenes.ClearColor
import Scenes.Texture2D
import Scenes.Texture2DBatched
import Scenes.Texture2DBatchedDynamic
main :: IO ()
main = do
@ -64,115 +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 triangle corners) as List of Floats
let vertexPositions =
[ (-0.5), (-0.5) -- 0
, 0.5 , (-0.5) -- 1
, 0.5 , 0.5 -- 2
, (-0.5), 0.5 -- 3
] :: [GL.GLfloat]
-- create draw order indices
indices = [0, 1, 2, 2, 3, 0] :: [GL.GLuint]
-- create and bind buffer for vertices
buf <- GL.genObjectName
GL.bindBuffer GL.ArrayBuffer $= Just buf
-- put vertices into the buffer
-- turn the list into a pointer
withArray vertexPositions $ \ptr ->
-- Feed the data to the buffer
GL.bufferData GL.ArrayBuffer $=
-- how much bytes of memory we are going to write (as an Int32)
( fromIntegral $ length vertexPositions * sizeOf (undefined :: GL.GLfloat)
-- The pointer to the data
, ptr
-- The data's usage
, GL.StaticDraw
)
-- enable and specify data layout of the in-memory vertices
GL.vertexAttribPointer (GL.AttribLocation 0) $=
( GL.ToFloat
, GL.VertexArrayDescriptor
-- There are 2 components (Floats) to our attribute
2
-- They are Floats
GL.Float
-- ???
0
-- our attribute is directly at the beginning of each vertex
(plusPtr nullPtr 0)
)
GL.vertexAttribArray (GL.AttribLocation 0) $= GL.Enabled
-- create and bind buffer index buffer
ibo <- GL.genObjectName
GL.bindBuffer GL.ElementArrayBuffer $= Just ibo
-- put indices into index buffer
-- turn the list into a pointer
withArray indices $ \ptr -> do
-- Feed the data to the buffer
GL.bufferData GL.ElementArrayBuffer $=
-- how much bytes of memory we are going to write (as an Int32)
( fromIntegral $ length indices * sizeOf (undefined :: GL.GLuint)
-- The pointer to the data
, ptr
-- The data's usage
, GL.StaticDraw
)
-- -- SHADERS
-- read in shaders from source file
vertSrc <- B.readFile "./res/shaders/vert.shader"
fragSrc <- B.readFile "./res/shaders/frag.shader"
sp <- createShaderProgram vertSrc fragSrc
GL.currentProgram $= Just sp
-- -- UNIFORMS
-- -- get the uniform's location out of the shader program
-- uniLoc <- get $ GL.uniformLocation sp "u_color"
-- -- write data to the uniform
-- GL.uniform uniLoc $= (GL.Color4 1 0.5 0 1 :: GL.Color4 GL.GLfloat)
-- create an MVar 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
GL.bindVertexArrayObject $= Nothing
GL.bindBuffer GL.ArrayBuffer $= Nothing
GL.bindBuffer GL.ElementArrayBuffer $= Nothing
GL.currentProgram $= Nothing
-- 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))
@ -181,42 +116,31 @@ main = do
-- <*> pure 1
-- GL.clearColor $= clearcol
-- clear buffers before drawing
GL.clear [GL.ColorBuffer]
-- rebind everything neccessary for draw call
GL.bindVertexArrayObject $= Just vao
-- (note the missing bindings to the vertex buffer and the attrib pointer)
GL.bindBuffer GL.ElementArrayBuffer $= Just ibo
GL.currentProgram $= Just 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]
-- throw away previous errors
-- void $ get GL.errors
-- Switch to different scene on keyboard presses F1 thourgh F?
-- get the uniform's location out of the shader program
uniLoc <- get $ GL.uniformLocation sp "u_color"
-- write data to the uniform
redValue <- takeMVar red
incrementValue <- takeMVar increment
let newRed = redValue + incrementValue
GL.uniform uniLoc $= (GL.Color4 newRed 0.5 0 1 :: GL.Color4 GL.GLfloat)
sceneSwitch curScene currentEvents
-- the actual drawing happens here
GL.drawElements GL.Triangles 6 GL.UnsignedInt nullPtr
err <- get GL.errors
when (not $ null err) (print $ "loop errors: " <> show err)
-- update MVAr values
putMVar red newRed
-- cycle the increment for red if neccessary
if (newRed + incrementValue > 1 || newRed + incrementValue < 0)
then
putMVar increment (-incrementValue)
else
putMVar increment incrementValue
-- make GL finish things up
-- GL.flush
GL.flush
-- draw context on screen
SDL.glSwapWindow window
@ -236,66 +160,37 @@ main = do
putStrLn "Bye!"
----------------------- Supplemantary functions -------------------------------
-- | create the actual Shader programs from source
createShaderProgram
:: B.ByteString -- ^ vertex shader source
-> B.ByteString -- ^ fragment shader source
-> IO GL.Program
createShaderProgram vertSrc fragSrc = do
-- create program Object
program <- GL.createProgram
-- create shaders from the source codes given
vs <- compileShaderSource GL.VertexShader vertSrc
fs <- compileShaderSource GL.FragmentShader fragSrc
-- attach, link and validate the shader program
GL.attachedShaders program $= [vs, fs]
GL.linkProgram program
GL.validateProgram program
ok <- get (GL.validateStatus program)
if ok
then
putStrLn "Shaderprogram linked successfully!"
else do
info <- get (GL.programInfoLog program)
putStrLn "Shaderprogram linking failed!\nInfo log says:"
putStrLn info
GL.deleteObjectName program
-- throw away the shaders, since they are linked into the shader program
mapM_ (\s -> GL.deleteObjectName s) [fs, vs]
return program
-- | compile a shader from source
compileShaderSource
:: GL.ShaderType -- ^ what type of shader we are compiling
-> B.ByteString -- ^ its source code
-> IO GL.Shader
compileShaderSource type_ source = do
-- create shader object of specified type
shaderObject <- GL.createShader type_
-- assign source code to shader object
GL.shaderSourceBS shaderObject $= source
-- actually compile the shader
GL.compileShader shaderObject
-- error handling
ok <- GL.compileStatus shaderObject
if ok
then
putStrLn (show type_ ++ ": compilation successfull!")
else do
info <- get (GL.shaderInfoLog shaderObject)
putStrLn (show type_ ++ ": compilation failed!\nInfo log says:")
putStrLn info
GL.deleteObjectName shaderObject
return shaderObject
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 ()

24
src/Renderer.hs Normal file
View file

@ -0,0 +1,24 @@
module Renderer where
import SDL (($=), get)
import qualified Graphics.Rendering.OpenGL as GL
import Foreign.Ptr
-- internal imports
import BindableClass
import VertexArray
import IndexBuffer
import Shader
draw :: VertexArray -> (IndexBuffer a) -> Shader -> IO ()
draw va ib sp = do
bind sp
bind va
bind ib
GL.drawElements GL.Triangles (iBufCount ib) GL.UnsignedInt nullPtr
clear :: IO ()
clear = GL.clear [GL.ColorBuffer]

77
src/Scenes/ClearColor.hs Normal file
View 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
View 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
View 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
)

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

View 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

209
src/Shader.hs Normal file
View file

@ -0,0 +1,209 @@
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
module Shader where
import SDL (($=), get)
import qualified Graphics.Rendering.OpenGL as GL
import qualified Graphics.GL as GLRaw
import Data.List as L
import Data.StateVar
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
import BindableClass
data Shader = Shader
{ shaderId :: GL.Program
, shaderSources :: [ShaderSource]
, shaderUniforms :: MVar [ShaderUniform]
}
-- make Shader Bindable
instance Bindable Shader where
bind s = GL.currentProgram $= Just (shaderId s)
unbind _ = GL.currentProgram $= Nothing
data ShaderSource = ShaderSource
{ shaderSourceType :: GL.ShaderType
, shaderPath :: FilePath
}
data ShaderUniform = ShaderUniform
{ shaderUniformName :: String
, shaderUniformLocation :: GL.UniformLocation
}
-- orphan instance to make linear's M44 uniforms
instance GL.Uniform (M44 GL.GLfloat) where
uniform loc@(GL.UniformLocation ul) = makeStateVar getter setter
where
getter = error "cannot implement: get uniform M44 GLfloat"
-- GL.withNewMatrix GL.RowMajor $ getUniformWith GLRaw.glGetUniformfv loc
setter (V4
(V4 a b c d)
(V4 e f g h)
(V4 i j k l)
(V4 m n o p)) = do
mat <- GL.newMatrix GL.RowMajor [a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p] :: IO (GL.GLmatrix GL.GLfloat)
GL.withMatrix mat $ GLRaw.glUniformMatrix4fv ul 1 . isRowMajor
uniformv (GL.UniformLocation ul) count buf = error "can not implement uniformv for M44 GLfloat"
-- GLRaw.glUniformMatrix4fv ul count 0 (castPtr buf `asTypeOf` elemType buf)
-- where
-- elemType = undefined :: GL.MatrixComponent c => Ptr (GL.GLmatrix c) -> Ptr c
-- getUniformWith :: (GL.GLuint -> GL.GLint -> Ptr a -> IO ()) -> GL.UniformLocation -> Ptr a -> IO ()
-- getUniformWith getter (GL.UniformLocation ul) buf = do
-- program <- fmap (GL.programID . fromJust) $ get GL.currentProgram
-- getter program ul buf
isRowMajor :: GL.MatrixOrder -> GL.GLboolean
isRowMajor p = if (GL.RowMajor == p) then 1 else 0
-- create new data object of type Shader
newShader :: [ShaderSource] -> IO Shader
newShader shaderSrc = do
-- create program Object
program <- GL.createProgram
-- create shaders from the source codes given
compilates <- mapM
(\(ShaderSource type_ path) -> do
-- read in shader source from File
source<- B.readFile path
-- compile the shader
compiledShader <- compileShaderSource type_ source
return (type_, compiledShader)
)
shaderSrc
-- attach, link and validate the shader program
GL.attachedShaders program $= map snd compilates
GL.linkProgram program
GL.validateProgram program
ok <- get (GL.validateStatus program)
if ok
then
putStrLn "Shaderprogram linked successfully!"
else do
info <- get (GL.programInfoLog program)
putStrLn "Shaderprogram linking failed!\nInfo log says:"
putStrLn info
GL.deleteObjectName program
-- throw away the shaders, since they are linked into the shader program
mapM_ (\s -> GL.deleteObjectName s) (map snd compilates)
-- return data object
Shader program shaderSrc <$> newMVar []
-- pass uniform values into Shader program
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
-- 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
:: GL.ShaderType -- ^ what type of shader we are compiling
-> B.ByteString -- ^ its source code
-> IO GL.Shader
compileShaderSource type_ source = do
-- create shader object of specified type
shaderObject <- GL.createShader type_
-- assign source code to shader object
GL.shaderSourceBS shaderObject $= source
-- actually compile the shader
GL.compileShader shaderObject
-- error handling
ok <- GL.compileStatus shaderObject
if ok
then
putStrLn (show type_ ++ ": compilation successful!")
else do
info <- get (GL.shaderInfoLog shaderObject)
putStrLn (show type_ ++ ": compilation failed!\nInfo log says:")
putStrLn info
GL.deleteObjectName shaderObject
return shaderObject

89
src/Texture.hs Normal file
View file

@ -0,0 +1,89 @@
module Texture where
import SDL (($=), get)
import qualified Graphics.Rendering.OpenGL as GL
import Codec.Picture
import Codec.Picture.Extra
import Data.Either
import Data.Vector.Storable as VS
import Foreign.Ptr
import Foreign.Marshal.Alloc (free)
import Linear
-- internal imports
import BindableClass
data Texture = Texture
{ texId :: GL.TextureObject
, texSlot :: GL.TextureUnit
-- , texPath :: FilePath
-- , texDimensions :: V2 GL.GLsizei
-- , texBPP :: Int
-- , texData :: Ptr ()
}
instance Bindable Texture where
bind t = do
GL.activeTexture $= texSlot t
GL.textureBinding GL.Texture2D $= Just (texId t)
unbind _ = GL.textureBinding GL.Texture2D $= Nothing
newTexture :: FilePath -> GL.GLuint -> IO Texture
newTexture fp slot = do
-- read in image from filesystem
img <- flipVertically <$> convertRGBA8 <$>
either (error $ "reading image file " <> fp <> " failed!") id <$>
readImage fp
-- extract the raw pointer from vector
unsafeWith (imageData img) $ \ptr -> do
-- create texture object
tex <- Texture
<$> GL.genObjectName
<*> (pure $ GL.TextureUnit slot)
-- <*> (pure fp)
let dimensions = fromIntegral <$> V2 (imageWidth img) (imageHeight img)
-- <*> (pure $ componentCount (VS.head $ imageData img))
data_ = castPtr ptr
-- bind texture
bind tex
-- set texture parameters
GL.textureFilter GL.Texture2D $= ((GL.Linear', Nothing), GL.Linear')
GL.textureWrapMode GL.Texture2D GL.S $= (GL.Repeated, GL.Clamp)
GL.textureWrapMode GL.Texture2D GL.T $= (GL.Repeated, GL.Clamp)
-- put data into GPU memory
loadTexture tex dimensions data_
-- unbind texture
unbind tex
-- -- throw away the data on the CPU side
-- free (texData tex)
-- pass texture object out
return tex
loadTexture :: Texture -> V2 GL.GLsizei -> Ptr () -> IO ()
loadTexture tex dimensions data_ =
let (V2 w h) = dimensions
in GL.texImage2D
GL.Texture2D
GL.NoProxy
0
GL.RGBA'
(GL.TextureSize2D w h)
0
(GL.PixelData GL.RGBA GL.UnsignedByte data_)

116
src/VertexArray.hs Normal file
View file

@ -0,0 +1,116 @@
{-# LANGUAGE TypeFamilies #-}
module VertexArray where
import qualified Graphics.Rendering.OpenGL as GL
import SDL (($=), get)
import Foreign
import Control.Concurrent.MVar
-- internal imports
import BindableClass
import BufferClass
import VertexBuffer
data VertexArray = VertexArray
{ vArrId :: GL.VertexArrayObject
}
deriving (Eq, Show)
instance Buffer VertexArray where
type ObjName VertexArray = GL.VertexArrayObject
target _ = undefined
glId = vArrId
initialize va = return ()
instance Bindable VertexArray where
bind va = GL.bindVertexArrayObject $= Just (vArrId va)
unbind va = GL.bindVertexArrayObject $= Nothing
newVertexArray :: IO VertexArray
newVertexArray = VertexArray
<$> GL.genObjectName
addBuffer
:: (Buffer buf)
=> VertexArray
-> buf
-> VertexBufferLayout
-> IO ()
addBuffer va vb layout = do
-- bind the provided vertex buffer
bind va
bind vb
-- enable and fill out the vertex attrib pointer(s)
list <- readMVar (vblElements layout)
let dataElementSize e = case e of
GL.Float -> sizeOf (undefined :: GL.GLfloat)
x -> error ("No size computation implemented fof: " <> show x)
mapM_
(\(VertexBufferLayoutElement index type_ count offset handling) -> do
GL.vertexAttribArray (GL.AttribLocation index) $=
GL.Enabled
GL.vertexAttribPointer (GL.AttribLocation index) $=
( handling
, GL.VertexArrayDescriptor
-- number of components to our attribute
count
-- datatype of elements
type_
-- Stride (How big is one Vertex in bytes)
(vblStride layout)
-- offset from beginnning of vertex in bytes
(plusPtr nullPtr offset)
)
)
list
unbind va
unbind vb
data VertexBufferLayout = VertexBufferLayout
{ vblElements :: MVar [VertexBufferLayoutElement]
, vblStride :: GL.GLsizei
}
data VertexBufferLayoutElement = VertexBufferLayoutElement
{ vbleIndex :: GL.GLuint
, vbleType :: GL.DataType
, vbleCount :: GL.GLint
, vbleOffset :: Int
, vbleHandling :: GL.IntegerHandling
}
newVertexBufferLayout :: GL.GLsizei -> IO VertexBufferLayout
newVertexBufferLayout stride = VertexBufferLayout
<$> newMVar []
<*> pure stride
pushElements
:: VertexBufferLayout
-> GL.GLuint
-> GL.DataType
-> GL.GLint
-> Int
-> IO ()
pushElements vbl index type_ count offset = do
modifyMVar_ (vblElements vbl) $ \list ->
return
(list ++
[VertexBufferLayoutElement
index
type_
count
offset
GL.ToNormalizedFloat
]
)

68
src/VertexBuffer.hs Normal file
View file

@ -0,0 +1,68 @@
{-# LANGUAGE TypeFamilies #-}
module VertexBuffer where
import qualified Graphics.Rendering.OpenGL as GL
import SDL (($=), get)
import Foreign
-- internal imports
import BindableClass
import BufferClass
-- layout of the VertexBuffer data object
data VertexBuffer a = VertexBuffer
{ vBufId :: GL.BufferObject -- buffer id
, vBufSize :: GL.GLsizeiptr -- size of data
, vBufData :: Ptr a -- pointer to data
}
-- instanciate typeclass from BufferClass and fill in missing implementations
instance Buffer (VertexBuffer a) where
type ObjName (VertexBuffer a) = 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
, vBufData buf
, GL.StaticDraw
)
-- release the buffer using the default implementation of the typeclass
unbind buf
instance Bindable (VertexBuffer a) where
-- bind the buffer
bind buf = GL.bindBuffer (target buf) $= Just (glId buf)
-- unbind the buffer
unbind buf = GL.bindBuffer (target buf) $= Nothing
newVertexBuffer ::
(Storable a) => -- we have to be able to get a pointer to provided data
[a] -> -- list of data elements
IO (VertexBuffer a) -- newly built VertexBuffer data object
newVertexBuffer list = do
-- create the buffer object in applicative style
buf <- VertexBuffer
-- generate the ID
<$> GL.genObjectName
-- compute buffer size
<*> pure (fromIntegral $ length list * sizeOf (head list))
-- make pointer out of list
<*> newArray list
-- fill the data in to the buffer
initialize buf
-- return the data object
return buf

View 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