renderer-tutorial/src/Main.hs

290 lines
7.6 KiB
Haskell
Raw Normal View History

2020-05-17 04:40:30 +00:00
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Strict #-}
2020-05-15 18:04:18 +00:00
module Main where
2020-05-17 04:40:30 +00:00
import SDL (($=), get)
import qualified SDL
import qualified SDL.Raw.Video as SDL (glSetAttribute)
import qualified SDL.Raw.Enum as SDL
import qualified Graphics.Rendering.OpenGL as GL
import qualified Graphics.GL as GLRaw
import Control.Concurrent.MVar
import Control.Monad
import Control.Monad.Loops
import Foreign hiding (void)
import Foreign.Ptr
import Foreign.Marshal.Array
import Foreign.Storable
import Data.Word
import qualified Data.ByteString as B
2020-05-17 08:59:15 +00:00
import qualified Data.ByteString.Char8 as B8
import qualified Data.List as L
2020-05-17 04:40:30 +00:00
import System.Random (randomRIO)
2020-05-18 02:58:45 +00:00
-- internal imports
import BufferClass
2020-05-20 03:54:14 +00:00
import VertexArray
2020-05-18 02:58:45 +00:00
import VertexBuffer
import IndexBuffer
2020-05-15 18:04:18 +00:00
main :: IO ()
2020-05-17 04:40:30 +00:00
main = do
-- -- INITIALIZATION
-- Initialize all the things! (including wacky stuff like joysticks and so on)
SDL.initializeAll
-- create an actual window with OpenGL 3.3
window <- SDL.createWindow "renderer" (SDL.defaultWindow
{ SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL
{ SDL.glProfile = SDL.Core SDL.Normal 3 3
}
}
)
-- enable context sharing (this is not absolutely neccessary)
void $ SDL.glSetAttribute SDL.SDL_GL_SHARE_WITH_CURRENT_CONTEXT 1
-- create ancutal context
context <- SDL.glCreateContext window
-- window should be a window, not fullscreen or so
SDL.setWindowMode window SDL.Windowed
2020-05-17 15:27:18 +00:00
-- synchronize buffer swapping with monitor's vsync
SDL.swapInterval $= SDL.SynchronizedUpdates
2020-05-17 04:40:30 +00:00
-- show the window
SDL.showWindow window
-- print OpenGL version of active context
version <- peekArray0 (0 :: Word8) =<< GLRaw.glGetString GLRaw.GL_VERSION
print (B.pack version)
-- -- VERTICES
-- first, create and bind a vertex array object
2020-05-17 19:27:35 +00:00
vao <- GL.genObjectName
GL.bindVertexArrayObject $= Just vao
2020-05-17 04:40:30 +00:00
2020-05-17 10:26:57 +00:00
-- define vertices (positions of the triangle corners) as List of Floats
2020-05-17 04:40:30 +00:00
let vertexPositions =
2020-05-17 10:26:57 +00:00
[ (-0.5), (-0.5) -- 0
, 0.5 , (-0.5) -- 1
, 0.5 , 0.5 -- 2
, (-0.5), 0.5 -- 3
2020-05-17 11:04:13 +00:00
] :: [GL.GLfloat]
2020-05-17 04:40:30 +00:00
2020-05-17 10:26:57 +00:00
-- create draw order indices
2020-05-17 11:04:13 +00:00
indices = [0, 1, 2, 2, 3, 0] :: [GL.GLuint]
2020-05-17 10:26:57 +00:00
2020-05-18 02:58:45 +00:00
-- construct new VertexBuffer and fill it with data
2020-05-20 03:54:14 +00:00
vao <- newVertexArray
2020-05-18 02:58:45 +00:00
vbo <- newVertexBuffer vertexPositions
-- rebind the vertex buffer
bind vbo
2020-05-20 03:54:14 +00:00
2020-05-17 04:40:30 +00:00
-- enable and specify data layout of the in-memory vertices
2020-05-20 03:54:14 +00:00
layout <- newVertexBufferLayout
pushElements layout GL.Float 2
addBuffer vao vbo layout
-- 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
2020-05-17 04:40:30 +00:00
2020-05-18 02:58:45 +00:00
-- construct new IndexBuffer and fill it with data
ibo <- newIndexBuffer indices
2020-05-17 10:26:57 +00:00
2020-05-17 04:40:30 +00:00
-- -- SHADERS
2020-05-17 08:59:15 +00:00
-- read in shaders from source file
vertSrc <- B.readFile "./res/shaders/vert.shader"
fragSrc <- B.readFile "./res/shaders/frag.shader"
sp <- createShaderProgram vertSrc fragSrc
2020-05-17 04:40:30 +00:00
GL.currentProgram $= Just sp
2020-05-17 11:37:59 +00:00
-- -- UNIFORMS
2020-05-17 15:28:39 +00:00
-- -- 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
2020-05-17 11:37:59 +00:00
2020-05-17 11:06:09 +00:00
err <- get GL.errors
print $ "pre-loop errors: " <> show err
2020-05-17 04:40:30 +00:00
-- -- EVENTING AND DRAWING
2020-05-17 19:27:35 +00:00
-- -- UNBINDING ALL BUFFERS AND VERTEX ARRAYS
GL.bindVertexArrayObject $= Nothing
2020-05-18 02:58:45 +00:00
unbind vbo
unbind ibo
2020-05-17 19:27:35 +00:00
GL.currentProgram $= Nothing
-- -- LOOPING
2020-05-17 04:40:30 +00:00
-- initial poll for events
evs <- newMVar =<< SDL.pollEvents
-- 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
-- -- OBEY THE HYPNOTOAD!
-- clearcol <- GL.Color4
-- <$> (randomRIO (0, 1))
-- <*> (randomRIO (0, 1))
-- <*> (randomRIO (0, 1))
-- <*> pure 1
-- GL.clearColor $= clearcol
-- clear buffers before drawing
GL.clear [GL.ColorBuffer]
2020-05-17 19:27:35 +00:00
-- rebind everything neccessary for draw call
2020-05-20 03:54:14 +00:00
bind vao
2020-05-17 19:27:35 +00:00
-- (note the missing bindings to the vertex buffer and the attrib pointer)
2020-05-18 02:58:45 +00:00
bind ibo
2020-05-17 19:27:35 +00:00
GL.currentProgram $= Just sp
2020-05-17 15:28:39 +00:00
-- throw away previous errors
-- void $ get GL.errors
-- 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)
2020-05-17 10:35:29 +00:00
-- the actual drawing happens here
2020-05-17 10:26:57 +00:00
GL.drawElements GL.Triangles 6 GL.UnsignedInt nullPtr
2020-05-17 11:06:09 +00:00
err <- get GL.errors
when (not $ null err) (print $ "loop errors: " <> show err)
2020-05-17 04:40:30 +00:00
2020-05-17 15:30:05 +00:00
-- 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
2020-05-17 04:40:30 +00:00
-- make GL finish things up
-- GL.flush
-- draw context on screen
SDL.glSwapWindow window
-- -- CLEAN UP
-- wrapping things up
putStrLn "loop exited. shutting down."
-- delete context
SDL.glDeleteContext context
-- destroy window
SDL.destroyWindow window
-- quit SDL
SDL.quit
-- This is the end.
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
2020-05-18 02:58:45 +00:00
putStrLn (show type_ ++ ": compilation successful!")
2020-05-17 04:40:30 +00:00
else do
info <- get (GL.shaderInfoLog shaderObject)
putStrLn (show type_ ++ ": compilation failed!\nInfo log says:")
putStrLn info
GL.deleteObjectName shaderObject
return shaderObject