renderer-tutorial/src/Main.hs

197 lines
5.1 KiB
Haskell

{-# 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
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 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
-- -- 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)
err <- get GL.errors
print $ "pre-loop errors: " <> show err
-- -- Constructing Scenes
-- 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))
-- <*> (randomRIO (0, 1))
-- <*> (randomRIO (0, 1))
-- <*> pure 1
-- GL.clearColor $= clearcol
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]
-- Switch to different scene on keyboard presses F1 thourgh F?
sceneSwitch curScene currentEvents
err <- get GL.errors
when (not $ null err) (print $ "loop errors: " <> show err)
-- 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!"
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 ()