{-# 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 ()