diff options
Diffstat (limited to 'src/Vivant.hs')
| -rw-r--r-- | src/Vivant.hs | 435 |
1 files changed, 236 insertions, 199 deletions
diff --git a/src/Vivant.hs b/src/Vivant.hs index 4a93b62..19548ce 100644 --- a/src/Vivant.hs +++ b/src/Vivant.hs @@ -14,137 +14,146 @@ module Main where -import Control.Lens ((.~), (^.)) -import Control.Monad -import Data.Fixed (mod') -import Data.Function ((&)) -import Data.Int (Int32) -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Word (Word32) -import Foreign.C.Types -import Foreign.Marshal.Alloc (free, malloc) -import Foreign.Ptr -import Foreign.Storable (poke, sizeOf) -import Linear -import SDL (($=)) -import SDL.Raw.Enum as SDL -import SDL.Raw.Video as SDL (glSetAttribute) -import SDL.Time (ticks) -import SDL.Vect -import System.Exit (exitFailure) -import System.IO - -import qualified Data.ByteString as BS -import qualified Data.Vector.Storable as V -import qualified Graphics.GL.Functions as GL (glUniformMatrix4fv) -import qualified Graphics.Rendering.OpenGL as GL +import Control.Lens ((.~), (^.)) +import Control.Monad +import qualified Data.ByteString as BS +import Data.Fixed (mod') +import Data.Function ((&)) +import Data.Int (Int32) +import Data.Set (Set) +import qualified Data.Set as Set +import qualified Data.Vector.Storable as V +import Data.Word (Word32) +import Foreign.C.Types +import Foreign.Marshal.Alloc (free, malloc) +import Foreign.Ptr +import Foreign.Storable (poke, sizeOf) +import qualified Graphics.GL.Functions as GL (glUniformMatrix4fv) +import qualified Graphics.Rendering.OpenGL as GL import qualified Graphics.Rendering.OpenGL.GL.Shaders.Uniform as GL (UniformLocation (..)) +import Linear +import Paths_vivant (getDataDir) +import SDL (($=)) import qualified SDL - -import Paths_vivant (getDataDir) -import Vivant.Shader (createProgram) +import SDL.Raw.Enum as SDL +import SDL.Raw.Video as SDL (glSetAttribute) +import SDL.Time (ticks) +import SDL.Vect +import System.Exit (exitFailure) +import System.IO +import Vivant.Shader (createProgram) screenWidth, screenHeight :: CInt (screenWidth, screenHeight) = (640, 480) data Camera = Camera - { cameraPos :: V3 Float - , cameraUp :: V3 Float - , cameraFront :: V3 Float - , cameraSpeed :: Float - , cameraPitch :: Float - , cameraYaw :: Float - } deriving (Show) + { cameraPos :: V3 Float, + cameraUp :: V3 Float, + cameraFront :: V3 Float, + cameraSpeed :: Float, + cameraPitch :: Float, + cameraYaw :: Float + } + deriving (Show) initialCamera :: Camera -initialCamera = Camera - { cameraPos = V3 0 0 10 - , cameraUp = V3 0 1 0 - , cameraFront = V3 0 0 (-1) - , cameraSpeed = 0.05 - , cameraPitch = 0 - , cameraYaw = (-90) - } +initialCamera = + Camera + { cameraPos = V3 0 0 10, + cameraUp = V3 0 1 0, + cameraFront = V3 0 0 (-1), + cameraSpeed = 0.05, + cameraPitch = 0, + cameraYaw = (-90) + } data Game = Game - { gameProgram :: Maybe (GL.Program) - , gameVao :: Maybe (GL.VertexArrayObject) - , gameModelP :: Ptr (M44 Float) - , gameViewP :: Ptr (M44 Float) - , gameProjectionP :: Ptr (M44 Float) - , gameCamera :: Camera - } deriving (Show) + { gameProgram :: Maybe (GL.Program), + gameVao :: Maybe (GL.VertexArrayObject), + gameModelP :: Ptr (M44 Float), + gameViewP :: Ptr (M44 Float), + gameProjectionP :: Ptr (M44 Float), + gameCamera :: Camera + } + deriving (Show) initialGameState :: Game -initialGameState = Game - { gameProgram = Nothing - , gameVao = Nothing - , gameModelP = nullPtr - , gameViewP = nullPtr - , gameProjectionP = nullPtr - , gameCamera = initialCamera - } +initialGameState = + Game + { gameProgram = Nothing, + gameVao = Nothing, + gameModelP = nullPtr, + gameViewP = nullPtr, + gameProjectionP = nullPtr, + gameCamera = initialCamera + } data MouseInputs = MouseInputs - { mousePosition :: Point V2 Int32 - , mouseRelative :: V2 Int32 - , mousePositionOld :: Maybe (V2 Int32) - } deriving (Show) + { mousePosition :: Point V2 Int32, + mouseRelative :: V2 Int32, + mousePositionOld :: Maybe (V2 Int32) + } + deriving (Show) initialMouse :: MouseInputs -initialMouse = MouseInputs - { mousePosition = P (V2 400 300) - , mouseRelative = V2 0 0 - , mousePositionOld = Nothing - } +initialMouse = + MouseInputs + { mousePosition = P (V2 400 300), + mouseRelative = V2 0 0, + mousePositionOld = Nothing + } main :: IO () main = do - SDL.initialize [SDL.InitVideo] - SDL.HintRenderScaleQuality $= SDL.ScaleLinear - do renderQuality <- SDL.get SDL.HintRenderScaleQuality - when (renderQuality /= SDL.ScaleLinear) $ - putStrLn "Warning: Linear texture filtering not enabled!" + SDL.initialize [SDL.InitVideo] + SDL.HintRenderScaleQuality $= SDL.ScaleLinear + do + renderQuality <- SDL.get SDL.HintRenderScaleQuality + when (renderQuality /= SDL.ScaleLinear) $ + putStrLn "Warning: Linear texture filtering not enabled!" - window <- - SDL.createWindow - "SDL / OpenGL Example" - SDL.defaultWindow {SDL.windowInitialSize = V2 screenWidth screenHeight, - SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL} + window <- + SDL.createWindow + "SDL / OpenGL Example" + SDL.defaultWindow + { SDL.windowInitialSize = V2 screenWidth screenHeight, + SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL + } - SDL.glSetAttribute SDL_GL_CONTEXT_PROFILE_MASK SDL_GL_CONTEXT_PROFILE_CORE - SDL.glSetAttribute SDL_GL_CONTEXT_MAJOR_VERSION 3 - SDL.glSetAttribute SDL_GL_CONTEXT_MINOR_VERSION 2 + SDL.glSetAttribute SDL_GL_CONTEXT_PROFILE_MASK SDL_GL_CONTEXT_PROFILE_CORE + SDL.glSetAttribute SDL_GL_CONTEXT_MAJOR_VERSION 3 + SDL.glSetAttribute SDL_GL_CONTEXT_MINOR_VERSION 2 - SDL.glSetAttribute SDL_GL_DOUBLEBUFFER 1 - SDL.glSetAttribute SDL_GL_DEPTH_SIZE 24 + SDL.glSetAttribute SDL_GL_DOUBLEBUFFER 1 + SDL.glSetAttribute SDL_GL_DEPTH_SIZE 24 - SDL.showWindow window + SDL.showWindow window - _ <- SDL.glCreateContext window + _ <- SDL.glCreateContext window - GL.viewport $= (GL.Position 0 0, GL.Size (fromIntegral screenWidth) (fromIntegral screenHeight)) + GL.viewport $= (GL.Position 0 0, GL.Size (fromIntegral screenWidth) (fromIntegral screenHeight)) - game <- initResources + game <- initResources - let loop key mouse = do - (keys', mouse') <- parseEvents key mouse + let loop key mouse = do + (keys', mouse') <- parseEvents key mouse - draw game - SDL.glSwapWindow window + draw game + SDL.glSwapWindow window - unless (Set.member escapeKey keys') (loop keys' mouse') + unless (Set.member escapeKey keys') (loop keys' mouse') - loop Set.empty initialMouse + loop Set.empty initialMouse - mapM_ free [ gameModelP game - , gameViewP game - , gameProjectionP game - ] + mapM_ + free + [ gameModelP game, + gameViewP game, + gameProjectionP game + ] - SDL.destroyWindow window - SDL.quit + SDL.destroyWindow window + SDL.quit noKeyModifier :: SDL.KeyModifier noKeyModifier = SDL.KeyModifier False False False False False False False False False False False @@ -154,86 +163,100 @@ escapeKey = SDL.Keysym SDL.ScancodeEscape SDL.KeycodeEscape noKeyModifier parseEvents :: Set SDL.Keysym -> MouseInputs -> IO (Set SDL.Keysym, MouseInputs) parseEvents keys mouse = do - events <- SDL.pollEvents - return $ foldr handleEvents (keys, mouse) (fmap SDL.eventPayload events) + events <- SDL.pollEvents + return $ foldr handleEvents (keys, mouse) (fmap SDL.eventPayload events) -handleEvents - :: SDL.EventPayload - -> (Set SDL.Keysym, MouseInputs) -> (Set SDL.Keysym, MouseInputs) +handleEvents :: + SDL.EventPayload -> + (Set SDL.Keysym, MouseInputs) -> + (Set SDL.Keysym, MouseInputs) handleEvents event (k, m) = - case event of - SDL.KeyboardEvent (SDL.KeyboardEventData { SDL.keyboardEventKeyMotion = e - , SDL.keyboardEventKeysym = k'}) -> + case event of + SDL.KeyboardEvent + ( SDL.KeyboardEventData + { SDL.keyboardEventKeyMotion = e, + SDL.keyboardEventKeysym = k' + } + ) -> ((if e == SDL.Released then Set.delete else Set.insert) k' k, m) - - SDL.MouseMotionEvent (SDL.MouseMotionEventData { SDL.mouseMotionEventPos = pos - , SDL.mouseMotionEventRelMotion = vel - }) -> + SDL.MouseMotionEvent + ( SDL.MouseMotionEventData + { SDL.mouseMotionEventPos = pos, + SDL.mouseMotionEventRelMotion = vel + } + ) -> (k, MouseInputs pos vel Nothing) - - SDL.QuitEvent{} -> - (Set.insert escapeKey k, m) - - _ -> (k, m) - + SDL.QuitEvent {} -> + (Set.insert escapeKey k, m) + _ -> (k, m) updateMouse :: MouseInputs -> Game -> Game updateMouse mouse game = - game { gameCamera = (gameCamera game) - { cameraFront = front - , cameraPitch = pitchDegrees - , cameraYaw = yawDegrees - } - } + game + { gameCamera = + (gameCamera game) + { cameraFront = front, + cameraPitch = pitchDegrees, + cameraYaw = yawDegrees + } + } where camera = gameCamera game front = normalize $ V3 (cos pitch * cos yaw) (sin pitch) (cos pitch * sin yaw) pitch = toRadians pitchDegrees - yaw = toRadians yawDegrees + yaw = toRadians yawDegrees pitchDegrees = min 89 . max (-89) $ cameraPitch camera + negate dy - yawDegrees = (`mod'` 360) $ cameraYaw camera + dx + yawDegrees = (`mod'` 360) $ cameraYaw camera + dx sensitivity = 0.05 - V2 dx dy = (* sensitivity) . fromIntegral <$> - if P (mouseRelative mouse) == mousePosition mouse - then V2 0 0 - else mouseRelative mouse + V2 dx dy = + (* sensitivity) . fromIntegral + <$> if P (mouseRelative mouse) == mousePosition mouse + then V2 0 0 + else mouseRelative mouse setVertexAttribute :: GL.Program -> String -> Int -> Int -> Int -> IO () setVertexAttribute program name vertices stride offset = do - let floatSize = sizeOf (1.0 :: Float) - attrib <- GL.get $ GL.attribLocation program name - GL.vertexAttribPointer attrib $= (GL.ToFloat, GL.VertexArrayDescriptor 2 GL.Float - (fromIntegral $ stride * floatSize) - (plusPtr nullPtr (offset * floatSize))) - GL.vertexAttribArray attrib $= GL.Enabled + let floatSize = sizeOf (1.0 :: Float) + attrib <- GL.get $ GL.attribLocation program name + GL.vertexAttribPointer attrib + $= ( GL.ToFloat, + GL.VertexArrayDescriptor + 2 + GL.Float + (fromIntegral $ stride * floatSize) + (plusPtr nullPtr (offset * floatSize)) + ) + GL.vertexAttribArray attrib $= GL.Enabled getUniformLocation :: GL.UniformLocation -> GL.GLint getUniformLocation (GL.UniformLocation i) = i initResources :: IO Game initResources = do - vao <- GL.genObjectName - GL.bindVertexArrayObject $= Just vao + vao <- GL.genObjectName + GL.bindVertexArrayObject $= Just vao - vbo <- GL.genObjectName - GL.bindBuffer GL.ArrayBuffer $= Just vbo - V.unsafeWith vertices $ \ptr -> - GL.bufferData GL.ArrayBuffer $= (vectorSize vertices, castPtr ptr, GL.StaticDraw) + vbo <- GL.genObjectName + GL.bindBuffer GL.ArrayBuffer $= Just vbo + V.unsafeWith vertices $ \ptr -> + GL.bufferData GL.ArrayBuffer $= (vectorSize vertices, castPtr ptr, GL.StaticDraw) - prog <- createProgram + prog <- createProgram - setVertexAttribute prog "position" 2 0 0 + setVertexAttribute prog "position" 2 0 0 - modelP <- malloc - viewP <- malloc - projectionP <- malloc + modelP <- malloc + viewP <- malloc + projectionP <- malloc - return $ initialGameState { gameProgram = Just prog - , gameVao = Just vao - , gameModelP = modelP - , gameViewP = viewP - , gameProjectionP = projectionP - } + return $ + initialGameState + { gameProgram = Just prog, + gameVao = Just vao, + gameModelP = modelP, + gameViewP = viewP, + gameProjectionP = projectionP + } -- | Convert degrees to radians toRadians :: Float -> Float @@ -244,68 +267,82 @@ scaledMat n = ((n * identity) & _w . _w .~ 1) draw :: Game -> IO () draw game@(Game {gameProgram = Just p, gameVao = Just v}) = do - tick <- ticks - GL.clearColor $= GL.Color4 1 1 1 1 - GL.clear [GL.ColorBuffer, GL.DepthBuffer] + tick <- ticks + GL.clearColor $= GL.Color4 1 1 1 1 + GL.clear [GL.ColorBuffer, GL.DepthBuffer] - GL.currentProgram $= gameProgram game - GL.bindVertexArrayObject $= gameVao game + GL.currentProgram $= gameProgram game + GL.bindVertexArrayObject $= gameVao game - model <- getUniformLocation <$> GL.uniformLocation p "model" - view <- getUniformLocation <$> GL.uniformLocation p "view" - projection <- getUniformLocation <$> GL.uniformLocation p "projection" + model <- getUniformLocation <$> GL.uniformLocation p "model" + view <- getUniformLocation <$> GL.uniformLocation p "view" + projection <- getUniformLocation <$> GL.uniformLocation p "projection" - let camera = gameCamera game - cameraPosition = cameraPos camera - targetPosition = cameraPosition ^+^ cameraFront camera - viewMatrix = lookAt cameraPosition targetPosition (cameraUp camera) - projectionMatrix = perspective (toRadians 45) (640/480) 0.1 100 + let camera = gameCamera game + cameraPosition = cameraPos camera + targetPosition = cameraPosition ^+^ cameraFront camera + viewMatrix = lookAt cameraPosition targetPosition (cameraUp camera) + projectionMatrix = perspective (toRadians 45) (640 / 480) 0.1 100 - poke (gameViewP game) viewMatrix - poke (gameProjectionP game) projectionMatrix + poke (gameViewP game) viewMatrix + poke (gameProjectionP game) projectionMatrix - GL.glUniformMatrix4fv view 1 1 (castPtr (gameViewP game)) - GL.glUniformMatrix4fv projection 1 1 (castPtr (gameProjectionP game)) + GL.glUniformMatrix4fv view 1 1 (castPtr (gameViewP game)) + GL.glUniformMatrix4fv projection 1 1 (castPtr (gameProjectionP game)) - ourColorLoc <- GL.uniformLocation p "ourColour" - GL.uniform ourColorLoc $= (GL.Vector4 (1::Float) (sin (fromIntegral tick / 500) / 2 + 0.5) 1 1) + ourColorLoc <- GL.uniformLocation p "ourColour" + GL.uniform ourColorLoc $= (GL.Vector4 (1 :: Float) (sin (fromIntegral tick / 500) / 2 + 0.5) 1 1) - forM_ locs $ \l -> do - let modelMatrix = mkTransformation (axisAngle (V3 1 0 0) 0) l - poke (gameModelP game) modelMatrix - GL.glUniformMatrix4fv model 1 1 (castPtr (gameModelP game)) - GL.drawArrays GL.Triangles 0 6 + forM_ locs $ \l -> do + let modelMatrix = mkTransformation (axisAngle (V3 1 0 0) 0) l + poke (gameModelP game) modelMatrix + GL.glUniformMatrix4fv model 1 1 (castPtr (gameModelP game)) + GL.drawArrays GL.Triangles 0 6 - GL.bindVertexArrayObject $= Nothing - return () + GL.bindVertexArrayObject $= Nothing + return () vectorSize :: (Num b, V.Storable a) => V.Vector a -> b vectorSize array = fromIntegral $ V.length array * sizeOf (1.0 :: Float) vertices :: V.Vector Float -vertices = V.fromList [ 0.5, -0.5 - , -0.5, -0.5 - , 0.5, 0.5 - , -0.5, 0.5 - , -0.5, -0.5 - , 0.5, 0.5 - ] +vertices = + V.fromList + [ 0.5, + -0.5, + -0.5, + -0.5, + 0.5, + 0.5, + -0.5, + 0.5, + -0.5, + -0.5, + 0.5, + 0.5 + ] locs :: [V3 Float] -locs = [ V3 0 0 0 - , V3 1 0 0 - , V3 2 0 0 - , V3 3 0 0 - , V3 4 0 0 - , V3 0 1 0 - , V3 1 1 0 - , V3 2 1 0 - , V3 3 1 0 - , V3 4 1 0 - ] +locs = + [ V3 0 0 0, + V3 1 0 0, + V3 2 0 0, + V3 3 0 0, + V3 4 0 0, + V3 0 1 0, + V3 1 1 0, + V3 2 1 0, + V3 3 1 0, + V3 4 1 0 + ] texCoords :: V.Vector Float -texCoords = V.fromList [ 0, 0 - , 1, 0 - , 0.5, 1 - ] +texCoords = + V.fromList + [ 0, + 0, + 1, + 0, + 0.5, + 1 + ] |