197 lines
5.1 KiB
Haskell
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 ()
|