225 lines
5.3 KiB
Haskell
225 lines
5.3 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE Strict #-}
|
|
module Main where
|
|
|
|
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
|
|
import qualified Data.ByteString.Char8 as B8
|
|
|
|
import qualified Data.List as L
|
|
|
|
import System.Random (randomRIO)
|
|
|
|
import Linear
|
|
|
|
-- internal imports
|
|
|
|
import BindableClass
|
|
import BufferClass
|
|
import VertexArray
|
|
import VertexBuffer
|
|
import IndexBuffer
|
|
import Shader
|
|
import Renderer
|
|
import Texture
|
|
|
|
main :: IO ()
|
|
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
|
|
|
|
-- synchronize buffer swapping with monitor's vsync
|
|
SDL.swapInterval $= SDL.SynchronizedUpdates
|
|
|
|
-- 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
|
|
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 -- 0
|
|
, 200, 100, 0, 1, 0 -- 1
|
|
, 200, 200, 0, 1, 1 -- 2
|
|
, 100, 200, 0, 0, 1 -- 3
|
|
] :: [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 proj = ortho 0 800 0 600 (-1) 1 :: M44 GL.GLfloat
|
|
|
|
-- -- 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" proj
|
|
|
|
-- -- 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
|
|
|
|
-- -- UNBINDING ALL BUFFERS AND VERTEX ARRAYS
|
|
|
|
unbind vao
|
|
unbind vbo
|
|
unbind ibo
|
|
unbind sp
|
|
|
|
-- -- LOOPING
|
|
|
|
-- 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
|
|
|
|
-- -- rebind everything neccessary for draw call
|
|
bind sp
|
|
|
|
incrementValue <- takeMVar increment
|
|
redValue <- takeMVar red
|
|
let newRed = redValue + incrementValue
|
|
|
|
-- write data to the uniform
|
|
-- setUniform sp "u_color" (GL.Color4 newRed 0.5 0 1 :: GL.Color4 GL.GLfloat)
|
|
|
|
-- 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)
|
|
|
|
-- 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
|
|
-- 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!"
|